[perl #71788] Skip $) test when NGROUPS_MAX is too small or when on darwin

1 files changed, 338 insertions, 115 deletions

diff --git a/t/op/groups.t b/t/op/groups.t
index 0ef15ad5d3..522701407e 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/
+    ^
+    (?<gr_name>.+)
+    \(
+        (?<gid>\d+)
+    \)
+    $
+/x;
+use constant GROUP_RX2 => qr/
+    ^
+    (?<gid>\d+)
+    \(
+        (?<gr_name>.+)
+    \)
+    $
+/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 <<EOM;
+
+    $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}').
@@ -78,105 +228,178 @@ GROUPS: {
 # on this platform to find *all* the groups that an arbitrary
 # user may belong to, using the 'perlbug' program.
 EOM
-	}
-	last GROUPS;
-    }
-    # Okay, not today.
-    quit();
-}
-
-chomp($groups);
-
-print "# groups = $groups\n";
-
-# Remember that group names can contain whitespace, '-', et cetera.
-# That is: do not \w, do not \S.
-if ($groups =~ /groups=(.+)( [ug]id=|$)/) {
-    my $gr = $1;
-    my @g0 = split /, ?/, $gr;
-    my @g1;
-    # prefer names over numbers
-    for (@g0) {
-	# 42(zot me)
-	if (/^(\d+)(?:\(([^)]+)\))?/) {
-	    push @g1, ($2 || $1);
-	}
-	# zot me(42)
-	elsif (/^([^(]*)\((\d+)\)/) {
-	    push @g1, ($1 || $2);
-	}
-	else {
-	    print "# ignoring group entry [$_]\n";
-	}
+        }
+        return ( $cmd, $str );
     }
-    print "# groups=$gr\n";
-    print "# g0 = @g0\n";
-    print "# g1 = @g1\n";
-    $groups = "@g1";
+
+    return ();
 }
 
-print "1..2\n";
+# Convert the strings produced by parsing `id -a' into a list of group
+# names
+sub extract_system_groups {
+    my ( $groups_string ) = @_;
 
-$pwgid = $( + 0;
-($pwgnam) = getgrgid($pwgid);
-$seen{$pwgid}++;
+    # Remember that group names can contain whitespace, '-', '(parens)',
+    # et cetera. That is: do not \w, do not \S.
+    my @extracted;
+    if ($groups_string =~ /groups=(.+)( [ug]id=|$)/) {
+        my $gr = $1;
 
-print "# pwgid = $pwgid, pwgnam = $pwgnam\n";
+        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";
+            }
+        }
 
-for (split(' ', $()) {
-    ($group) = getgrgid($_);
-    next if (! defined $group or ! grep { $_ eq $group } @gr) and $seen{$_}++;
-    if (defined $group) {
-	push(@gr, $group);
-    }
-    else {
-	push(@gr, $_);
+        diag_variable( gr => $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: