From: Josh ben Jore Date: Sat, 9 Jan 2010 15:15:52 +0000 (-0800) Subject: [perl #71788] Skip $) test when NGROUPS_MAX is too small or when on darwin X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=651d4685ebdde5512841551572b29e74605bfc38;p=p5sagit%2Fp5-mst-13.2.git [perl #71788] Skip $) test when NGROUPS_MAX is too small or when on darwin --- diff --git a/t/op/groups.t b/t/op/groups.t index 0ef15ad..5227014 100644 --- a/t/op/groups.t +++ b/t/op/groups.t @@ -1,34 +1,157 @@ #!./perl - -$ENV{PATH} ="/bin:/usr/bin:/usr/xpg4/bin:/usr/ucb" . - exists $ENV{PATH} ? ":$ENV{PATH}" : "" unless $^O eq 'VMS'; -$ENV{LC_ALL} = "C"; # so that external utilities speak English -$ENV{LANGUAGE} = 'C'; # GNU locale extension - 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'; +} +use 5.010; +use strict; +use Config (); +use POSIX (); + +unless (eval { my($foo) = getgrgid(0); 1 }) { + quit( "getgrgid() not implemented" ); +} + +quit("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 quit( "No `id' or `groups'" ); + my @extracted_groups = extract_system_groups( $groups_string ) + or quit( "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"; + } - require Config; - if ($@) { - print "1..0 # Skip: no Config\n"; - } else { - Config->import; + 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; } +# Cleanly abort this entire test file sub quit { - print "1..0 # Skip: no `id` or `groups`\n"; + print "1..0 # SKIP: @_\n"; exit 0; } -unless (eval { getgrgid(0); 1 }) { - print "1..0 # Skip: getgrgid() not implemented\n"; - exit 0; -} +# 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 ); + } -quit() if (($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') - or $^O =~ /lynxos/i); + return ( $cmd, $groups_string ); +} # We have to find a command that prints all (effective # and real) group names (not ids). The known commands are: @@ -46,30 +169,57 @@ quit() if (($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') # 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) # parse -# groups=22,42,1(foo),2(bar),3(zot me) # parse +# 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/ + ^ + (?.+) + \( + (?\d+) + \) + $ +/x; +use constant GROUP_RX2 => qr/ + ^ + (?\d+) + \( + (?.+) + \) + $ +/x; +sub _system_groups { + my $cmd; + my $str; -GROUPS: { # prefer 'id' over 'groups' (is this ever wrong anywhere?) # and 'id -a' over 'id -Gn' (the former is good about spaces in group names) - if (($groups = `id -a 2>/dev/null`) ne '') { - # $groups 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) - last GROUPS if $groups =~ /groups=/; + + $cmd = 'id -a 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) + return ( $cmd, $str ); } - if (($groups = `id -Gn 2>/dev/null`) ne '') { - # $groups could be of the form: - # users 33536 39181 root dev - last GROUPS if $groups !~ /^(\d|\s)+$/; + + $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 ); } - if (($groups = `groups 2>/dev/null`) ne '') { - # may not reflect all groups in some places, so do a sanity check - if (-d '/afs') { - print < $gr ); + diag_variable( g => join ',', @g ); + diag_variable( ex_gr => join ',', @extracted ); } + + return @extracted; } -print "# gr = @gr\n"; +# Get the POSIX value NGROUPS_MAX. +sub posix_ngroups_max { + return eval { + POSIX::NGROUPS_MAX(); + }; +} -my %did; -if ($^O =~ /^(?:uwin|cygwin|interix|solaris|linux|darwin)$/) { - # Or anybody else who can have spaces in group names. - $gr1 = join(' ', grep(!$did{$_}++, sort split(' ', join(' ', @gr)))); -} else { - # Don't assume that there aren't duplicate groups - $gr1 = join(' ', sort grep defined $_ && !$did{$_}++, @gr); +# Test if this is Apple's darwin +sub darwin { + # Observed 'darwin-2level' + return $Config::Config{myuname} =~ /^darwin/; } -if ($Config{myuname} =~ /^cygwin_nt/i) { # basegroup on CYGWIN_NT has id = 0. - @basegroup{$pwgid,$pwgnam} = (0,0); -} else { - @basegroup{$pwgid,$pwgnam} = (1,1); +# Test if this is Cygwin +sub cygwin_nt { + return $Config::Config{myuname} =~ /^cygwin_nt/i; } -$gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups))); -my $ok1 = 0; -if ($gr1 eq $gr2 || ($gr1 eq '' && $gr2 eq $pwgid)) { - print "ok 1\n"; - $ok1++; +# 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 ); } -elsif ($Config{myuname} =~ /^cygwin_nt/i) { # basegroup on CYGWIN_NT has id = 0. - # Retry in default unix mode - %basegroup = ( $pwgid => 1, $pwgnam => 1 ); - $gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups))); - if ($gr1 eq $gr2 || ($gr1 eq '' && $gr2 eq $pwgid)) { - print "ok 1 # This Cygwin behaves like Unix (Win2k?)\n"; - $ok1++; + +# 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; } -unless ($ok1) { - print "#gr1 is <$gr1>\n"; - print "#gr2 is <$gr2>\n"; - print "not ok 1\n"; + +# 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] ); } -# multiple 0's indicate GROUPSTYPE is currently long but should be short +# Print a nice little diagnostic. +sub diag_variable { + my ( $label, $content ) = @_; -if ($pwgid == 0 || $seen{0} < 2) { - print "ok 2\n"; + printf "# %-11s=%s\n", $label, $content; + return; } -else { - print "not ok 2 (groupstype should be type short, not long)\n"; + +# 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 noet: