mirror of
https://github.com/Perl/perl5.git
synced 2026-01-26 08:38:23 +00:00
14d04a3346
This updates the editor hints in our files for Emacs and vim to request that tabs be inserted as spaces.
410 lines
11 KiB
Perl
410 lines
11 KiB
Perl
#!./perl
|
|
BEGIN {
|
|
if ( $^O eq 'VMS' ) {
|
|
my $p = "/bin:/usr/bin:/usr/xpg4/bin:/usr/ucb";
|
|
if ( $ENV{PATH} ) {
|
|
$p .= ":$ENV{PATH}";
|
|
}
|
|
$ENV{PATH} = $p;
|
|
}
|
|
$ENV{LC_ALL} = "C"; # so that external utilities speak English
|
|
$ENV{LANGUAGE} = 'C'; # GNU locale extension
|
|
|
|
chdir 't';
|
|
@INC = '../lib';
|
|
require './test.pl';
|
|
skip_all_if_miniperl("no dynamic loading on miniperl, no POSIX");
|
|
}
|
|
use 5.010;
|
|
use strict;
|
|
use Config ();
|
|
use POSIX ();
|
|
|
|
skip_all('getgrgid() not implemented')
|
|
unless eval { my($foo) = getgrgid(0); 1 };
|
|
|
|
skip_all("No 'id' or 'groups'") if
|
|
$^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS' || $^O =~ /lynxos/i;
|
|
|
|
Test();
|
|
exit;
|
|
|
|
|
|
|
|
sub Test {
|
|
|
|
# Get our supplementary groups from the system by running commands
|
|
# like `id -a'.
|
|
my ( $groups_command, $groups_string ) = system_groups()
|
|
or skip_all("No 'id' or 'groups'");
|
|
my @extracted_groups = extract_system_groups( $groups_string )
|
|
or skip_all("Can't parse '${groups_command}'");
|
|
|
|
my $pwgid = $( + 0;
|
|
my ($pwgnam) = getgrgid($pwgid);
|
|
$pwgnam //= '';
|
|
print "# pwgid=$pwgid pwgnam=$pwgnam \$(=$(\n";
|
|
|
|
# Get perl's supplementary groups by looking at $(
|
|
my ( $gid_count, $all_perl_groups ) = perl_groups();
|
|
my %basegroup = basegroups( $pwgid, $pwgnam );
|
|
my @extracted_supplementary_groups = remove_basegroup( \ %basegroup, \ @extracted_groups );
|
|
|
|
print "1..2\n";
|
|
|
|
|
|
# Test: The supplementary groups in $( should match the
|
|
# getgroups(2) kernal API call.
|
|
#
|
|
my $ngroups_max = posix_ngroups_max();
|
|
if ( defined $ngroups_max && $ngroups_max < @extracted_groups ) {
|
|
# Some OSes (like darwin)but conceivably others might return
|
|
# more groups from `id -a' than can be handled by the
|
|
# kernel. On darwin, NGROUPS_MAX is 16 and 12 are taken up for
|
|
# the system already.
|
|
#
|
|
# There is more fall-out from this than just Perl's unit
|
|
# tests. You may be a member of a group according to Active
|
|
# Directory (or whatever) but the OS won't respect it because
|
|
# it's the 17th (or higher) group and there's no space to
|
|
# store your membership.
|
|
print "ok 1 # SKIP Your platform's `$groups_command' is broken\n";
|
|
}
|
|
|
|
elsif ( darwin() ) {
|
|
# darwin uses getgrouplist(3) or an Open Directory API within
|
|
# /usr/bin/id and /usr/bin/groups which while "nice" isn't
|
|
# accurate for this test. The hard, real, list of groups we're
|
|
# running in derives from getgroups(2) and is not dynamic but
|
|
# the Libc API getgrouplist(3) is.
|
|
#
|
|
# In practical terms, this meant that while `id -a' can be
|
|
# relied on in other OSes to purely use getgroups(2) and show
|
|
# us what's real, darwin will use getgrouplist(3) to show us
|
|
# what might be real if only we'd open a new console.
|
|
#
|
|
print "ok 1 # SKIP darwin's `${groups_command}' can't be trusted\n";
|
|
}
|
|
|
|
else {
|
|
|
|
# Read $( but ignore any groups in $( that we failed to parse
|
|
# successfully out of the `id -a` mess.
|
|
#
|
|
my @perl_groups = remove_unparsed_entries( \ @extracted_groups,
|
|
\ @$all_perl_groups );
|
|
my @supplementary_groups = remove_basegroup( \ %basegroup,
|
|
\ @perl_groups );
|
|
|
|
my $ok1 = 0;
|
|
if ( match_groups( \ @supplementary_groups,
|
|
\ @extracted_supplementary_groups,
|
|
$pwgid ) ) {
|
|
print "ok 1\n";
|
|
$ok1 = 1;
|
|
}
|
|
elsif ( cygwin_nt() ) {
|
|
%basegroup = unixy_cygwin_basegroups();
|
|
@extracted_supplementary_groups = remove_basegroup( \ %basegroup, \ @extracted_groups );
|
|
|
|
if ( match_groups( \ @supplementary_groups,
|
|
\ @extracted_supplementary_groups,
|
|
$pwgid ) ) {
|
|
print "ok 1 # This Cygwin behaves like Unix (Win2k?)\n";
|
|
$ok1 = 1;
|
|
}
|
|
}
|
|
|
|
unless ( $ok1 ) {
|
|
|
|
}
|
|
}
|
|
|
|
# multiple 0's indicate GROUPSTYPE is currently long but should be short
|
|
$gid_count->{0} //= 0;
|
|
if ( 0 == $pwgid || $gid_count->{0} < 2 ) {
|
|
print "ok 2\n";
|
|
}
|
|
else {
|
|
print "not ok 2 (groupstype should be type short, not long)\n";
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
# Get the system groups and the command used to fetch them.
|
|
#
|
|
sub system_groups {
|
|
my ( $cmd, $groups_string ) = _system_groups();
|
|
|
|
if ( $groups_string ) {
|
|
chomp $groups_string;
|
|
diag_variable( groups => $groups_string );
|
|
}
|
|
|
|
return ( $cmd, $groups_string );
|
|
}
|
|
|
|
# We have to find a command that prints all (effective
|
|
# and real) group names (not ids). The known commands are:
|
|
# groups
|
|
# id -Gn
|
|
# id -a
|
|
# Beware 1: some systems do just 'id -G' even when 'id -Gn' is used.
|
|
# Beware 2: id -Gn or id -a format might be id(name) or name(id).
|
|
# Beware 3: the groups= might be anywhere in the id output.
|
|
# Beware 4: groups can have spaces ('id -a' being the only defense against this)
|
|
# Beware 5: id -a might not contain the groups= part.
|
|
#
|
|
# That is, we might meet the following:
|
|
#
|
|
# foo bar zot # accept
|
|
# foo 22 42 bar zot # accept
|
|
# 1 22 42 2 3 # reject
|
|
# groups=(42),foo(1),bar(2),zot me(3) # parsed by $GROUP_RX1
|
|
# groups=22,42,1(foo),2(bar),3(zot(me)) # parsed by $GROUP_RX2
|
|
#
|
|
# and the groups= might be after, before, or between uid=... and gid=...
|
|
use constant GROUP_RX1 => qr/
|
|
^
|
|
(?<gr_name>.+)
|
|
\(
|
|
(?<gid>\d+)
|
|
\)
|
|
$
|
|
/x;
|
|
use constant GROUP_RX2 => qr/
|
|
^
|
|
(?<gid>\d+)
|
|
\(
|
|
(?<gr_name>.+)
|
|
\)
|
|
$
|
|
/x;
|
|
sub _system_groups {
|
|
my $cmd;
|
|
my $str;
|
|
|
|
# prefer 'id' over 'groups' (is this ever wrong anywhere?)
|
|
# and 'id -a' over 'id -Gn' (the former is good about spaces in group names)
|
|
|
|
$cmd = 'id -a 2>/dev/null || id 2>/dev/null';
|
|
$str = `$cmd`;
|
|
if ( $str && $str =~ /groups=/ ) {
|
|
# $str is of the form:
|
|
# uid=39957(gsar) gid=22(users) groups=33536,39181,22(users),0(root),1067(dev)
|
|
# FreeBSD since 6.2 has a fake id -a:
|
|
# uid=1001(tobez) gid=20(staff) groups=20(staff), 0(wheel), 68(dialer)
|
|
# On AIX it's id
|
|
#
|
|
# Linux may also have a context= field
|
|
|
|
return ( $cmd, $str );
|
|
}
|
|
|
|
$cmd = 'id -Gn 2>/dev/null';
|
|
$str = `$cmd`;
|
|
if ( $str && $str !~ /^[\d\s]$/ ) {
|
|
# $str could be of the form:
|
|
# users 33536 39181 root dev
|
|
return ( $cmd, $str );
|
|
}
|
|
|
|
$cmd = 'groups 2>/dev/null';
|
|
$str = `$cmd`;
|
|
if ( $str ) {
|
|
# may not reflect all groups in some places, so do a sanity check
|
|
if (-d '/afs') {
|
|
print <<EOM;
|
|
# These test results *may* be bogus, as you appear to have AFS,
|
|
# and I can't find a working 'id' in your PATH (which I have set
|
|
# to '$ENV{PATH}').
|
|
#
|
|
# If these tests fail, report the particular incantation you use
|
|
# on this platform to find *all* the groups that an arbitrary
|
|
# user may belong to, using the 'perlbug' program.
|
|
EOM
|
|
}
|
|
return ( $cmd, $str );
|
|
}
|
|
|
|
return ();
|
|
}
|
|
|
|
# Convert the strings produced by parsing `id -a' into a list of group
|
|
# names
|
|
sub extract_system_groups {
|
|
my ( $groups_string ) = @_;
|
|
|
|
# Remember that group names can contain whitespace, '-', '(parens)',
|
|
# et cetera. That is: do not \w, do not \S.
|
|
my @extracted;
|
|
|
|
my @fields = split /\b(\w+=)/, $groups_string;
|
|
my $gr;
|
|
for my $i (0..@fields-2) {
|
|
if ($fields[$i] eq 'groups=') {
|
|
$gr = $fields[$i+1];
|
|
$gr =~ s/ $//;
|
|
last;
|
|
}
|
|
}
|
|
if (defined $gr) {
|
|
my @g = split m{, ?}, $gr;
|
|
# prefer names over numbers
|
|
for (@g) {
|
|
if ( $_ =~ GROUP_RX1() || $_ =~ GROUP_RX2() ) {
|
|
push @extracted, $+{gr_name} || $+{gid};
|
|
}
|
|
else {
|
|
print "# ignoring group entry [$_]\n";
|
|
}
|
|
}
|
|
|
|
diag_variable( gr => $gr );
|
|
diag_variable( g => join ',', @g );
|
|
diag_variable( ex_gr => join ',', @extracted );
|
|
}
|
|
|
|
return @extracted;
|
|
}
|
|
|
|
# Get the POSIX value NGROUPS_MAX.
|
|
sub posix_ngroups_max {
|
|
return eval {
|
|
POSIX::NGROUPS_MAX();
|
|
};
|
|
}
|
|
|
|
# Test if this is Apple's darwin
|
|
sub darwin {
|
|
# Observed 'darwin-2level'
|
|
return $Config::Config{myuname} =~ /^darwin/;
|
|
}
|
|
|
|
# Test if this is Cygwin
|
|
sub cygwin_nt {
|
|
return $Config::Config{myuname} =~ /^cygwin_nt/i;
|
|
}
|
|
|
|
# Get perl's supplementary groups and the number of times each gid
|
|
# appeared.
|
|
sub perl_groups {
|
|
# Lookup perl's own groups from $(
|
|
my @gids = split ' ', $(;
|
|
my %gid_count;
|
|
my @gr_name;
|
|
for my $gid ( @gids ) {
|
|
++ $gid_count{$gid};
|
|
|
|
my ($group) = getgrgid $gid;
|
|
|
|
# Why does this test prefer to not test groups which we don't have
|
|
# a name for? One possible answer is that my primary group comes
|
|
# from from my entry in the user database but isn't mentioned in
|
|
# the group database. Are there more reasons?
|
|
next if ! defined $group;
|
|
|
|
|
|
push @gr_name, $group;
|
|
}
|
|
|
|
diag_variable( gr_name => join ',', @gr_name );
|
|
|
|
return ( \ %gid_count, \ @gr_name );
|
|
}
|
|
|
|
# Remove entries from our parsing of $( that don't appear in our
|
|
# parsing of `id -a`.
|
|
sub remove_unparsed_entries {
|
|
my ( $extracted_groups, $perl_groups ) = @_;
|
|
|
|
my %was_extracted =
|
|
map { $_ => 1 }
|
|
@$extracted_groups;
|
|
|
|
return
|
|
grep { $was_extracted{$_} }
|
|
@$perl_groups;
|
|
}
|
|
|
|
# Get a list of base groups. I'm not sure why cygwin by default is
|
|
# skipped here.
|
|
sub basegroups {
|
|
my ( $pwgid, $pwgnam ) = @_;
|
|
|
|
if ( cygwin_nt() ) {
|
|
return;
|
|
}
|
|
else {
|
|
return (
|
|
$pwgid => 1,
|
|
$pwgnam => 1,
|
|
);
|
|
}
|
|
}
|
|
|
|
# Cygwin might have another form of basegroup which we should actually use
|
|
sub unixy_cygwin_basegroups {
|
|
my ( $pwgid, $pwgnam ) = @_;
|
|
return (
|
|
$pwgid => 1,
|
|
$pwgnam => 1,
|
|
);
|
|
}
|
|
|
|
# Filter a full list of groups and return only the supplementary
|
|
# gorups.
|
|
sub remove_basegroup {
|
|
my ( $basegroups, $groups ) = @_;
|
|
|
|
return
|
|
grep { ! $basegroups->{$_} }
|
|
@$groups;
|
|
}
|
|
|
|
# Test supplementary groups to see if they're a close enough match or
|
|
# if there aren't any supplementary groups then validate the current
|
|
# group against $(.
|
|
sub match_groups {
|
|
my ( $supplementary_groups, $extracted_supplementary_groups, $pwgid ) = @_;
|
|
|
|
# Compare perl vs system groups
|
|
my %g;
|
|
$g{$_}[0] = 1 for @$supplementary_groups;
|
|
$g{$_}[1] = 1 for @$extracted_supplementary_groups;
|
|
|
|
# Find any mismatches
|
|
my @misses =
|
|
grep { ! ( $g{$_}[0] && $g{$_}[1] ) }
|
|
sort keys %g;
|
|
|
|
return
|
|
! @misses
|
|
|| ( ! @$supplementary_groups
|
|
&& 1 == @$extracted_supplementary_groups
|
|
&& $pwgid == $extracted_supplementary_groups->[0] );
|
|
}
|
|
|
|
# Print a nice little diagnostic.
|
|
sub diag_variable {
|
|
my ( $label, $content ) = @_;
|
|
|
|
printf "# %-11s=%s\n", $label, $content;
|
|
return;
|
|
}
|
|
|
|
# Removes duplicates from a list
|
|
sub uniq {
|
|
my %seen;
|
|
return
|
|
grep { ! $seen{$_}++ }
|
|
@_;
|
|
}
|
|
|
|
# Local variables:
|
|
# indent-tabs-mode: nil
|
|
# End:
|
|
#
|
|
# ex: set ts=8 sts=4 sw=4 et:
|