t/op/groups.t

   1 #!./perl
   2 BEGIN {
   3     if ( $^O eq 'VMS' ) {
   4         my $p = "/bin:/usr/bin:/usr/xpg4/bin:/usr/ucb";
   5         if ( $ENV{PATH} ) {
   6             $p .= ":$ENV{PATH}";
   7         }
   8         $ENV{PATH} = $p;
   9     }
  10     $ENV{LC_ALL} = "C"; # so that external utilities speak English
  11     $ENV{LANGUAGE} = 'C'; # GNU locale extension
  12
  13     chdir 't';
  14     @INC = '../lib';
  15 }
  16 use 5.010;
  17 use strict;
  18 use Config ();
  19 use POSIX ();
  20
  21 unless (eval { my($foo) = getgrgid(0); 1 }) {
  22     quit( "getgrgid() not implemented" );
  23 }
  24
  25 quit("No `id' or `groups'") if
  26     $^O eq 'MSWin32'
  27     || $^O eq 'NetWare'
  28     || $^O eq 'VMS'
  29     || $^O =~ /lynxos/i;
  30
  31 Test();
  32 exit;
  33
  34
  35
  36 sub Test {
  37
  38     # Get our supplementary groups from the system by running commands
  39     # like `id -a'.
  40     my ( $groups_command, $groups_string ) = system_groups()
  41         or quit( "No `id' or `groups'" );
  42     my @extracted_groups = extract_system_groups( $groups_string )
  43         or quit( "Can't parse `${groups_command}'" );
  44
  45     my $pwgid = $( + 0;
  46     my ($pwgnam) = getgrgid($pwgid);
  47     $pwgnam //= '';
  48     print "# pwgid=$pwgid pwgnam=$pwgnam \$(=$(\n";
  49
  50     # Get perl's supplementary groups by looking at $(
  51     my ( $gid_count, $all_perl_groups ) = perl_groups();
  52     my %basegroup = basegroups( $pwgid, $pwgnam );
  53     my @extracted_supplementary_groups = remove_basegroup( \ %basegroup, \ @extracted_groups );
  54
  55     print "1..2\n";
  56
  57
  58     # Test: The supplementary groups in $( should match the
  59     # getgroups(2) kernal API call.
  60     #
  61     my $ngroups_max = posix_ngroups_max();
  62     if ( defined $ngroups_max && $ngroups_max < @extracted_groups ) {
  63         # Some OSes (like darwin)but conceivably others might return
  64         # more groups from `id -a' than can be handled by the
  65         # kernel. On darwin, NGROUPS_MAX is 16 and 12 are taken up for
  66         # the system already.
  67         #
  68         # There is more fall-out from this than just Perl's unit
  69         # tests. You may be a member of a group according to Active
  70         # Directory (or whatever) but the OS won't respect it because
  71         # it's the 17th (or higher) group and there's no space to
  72         # store your membership.
  73         print "ok 1 # SKIP Your platform's `$groups_command' is broken\n";
  74     }
  75
  76     elsif ( darwin() ) {
  77         # darwin uses getgrouplist(3) or an Open Directory API within
  78         # /usr/bin/id and /usr/bin/groups which while "nice" isn't
  79         # accurate for this test. The hard, real, list of groups we're
  80         # running in derives from getgroups(2) and is not dynamic but
  81         # the Libc API getgrouplist(3) is.
  82         #
  83         # In practical terms, this meant that while `id -a' can be
  84         # relied on in other OSes to purely use getgroups(2) and show
  85         # us what's real, darwin will use getgrouplist(3) to show us
  86         # what might be real if only we'd open a new console.
  87         #
  88         print "ok 1 # SKIP darwin's `${groups_command}' can't be trusted\n";
  89     }
  90
  91     else {
  92
  93         # Read $( but ignore any groups in $( that we failed to parse
  94         # successfully out of the `id -a` mess.
  95         #
  96         my @perl_groups = remove_unparsed_entries( \ @extracted_groups,
  97                                                    \ @$all_perl_groups );
  98         my @supplementary_groups = remove_basegroup( \ %basegroup,
  99                                                      \ @perl_groups );
 100
 101         my $ok1 = 0;
 102         if ( match_groups( \ @supplementary_groups,
 103                            \ @extracted_supplementary_groups,
 104                            $pwgid ) ) {
 105             print "ok 1\n";
 106             $ok1 = 1;
 107         }
 108         elsif ( cygwin_nt() ) {
 109             %basegroup = unixy_cygwin_basegroups();
 110             @extracted_supplementary_groups = remove_basegroup( \ %basegroup, \ @extracted_groups );
 111
 112             if ( match_groups( \ @supplementary_groups,
 113                                \ @extracted_supplementary_groups,
 114                                $pwgid ) ) {
 115                 print "ok 1 # This Cygwin behaves like Unix (Win2k?)\n";
 116                 $ok1 = 1;
 117             }
 118         }
 119
 120         unless ( $ok1 ) {
 121
 122         }
 123     }
 124
 125     # multiple 0's indicate GROUPSTYPE is currently long but should be short
 126     $gid_count->{0} //= 0;
 127     if ( 0 == $pwgid || $gid_count->{0} < 2 ) {
 128         print "ok 2\n";
 129     }
 130     else {
 131         print "not ok 2 (groupstype should be type short, not long)\n";
 132     }
 133
 134     return;
 135 }
 136
 137 # Cleanly abort this entire test file
 138 sub quit {
 139     print "1..0 # SKIP: @_\n";
 140     exit 0;
 141 }
 142
 143 # Get the system groups and the command used to fetch them.
 144 #
 145 sub system_groups {
 146     my ( $cmd, $groups_string ) = _system_groups();
 147
 148     if ( $groups_string ) {
 149         chomp $groups_string;
 150         diag_variable( groups => $groups_string );
 151     }
 152
 153     return ( $cmd, $groups_string );
 154 }
 155
 156 # We have to find a command that prints all (effective
 157 # and real) group names (not ids).  The known commands are:
 158 # groups
 159 # id -Gn
 160 # id -a
 161 # Beware 1: some systems do just 'id -G' even when 'id -Gn' is used.
 162 # Beware 2: id -Gn or id -a format might be id(name) or name(id).
 163 # Beware 3: the groups= might be anywhere in the id output.
 164 # Beware 4: groups can have spaces ('id -a' being the only defense against this)
 165 # Beware 5: id -a might not contain the groups= part.
 166 #
 167 # That is, we might meet the following:
 168 #
 169 # foo bar zot                           # accept
 170 # foo 22 42 bar zot                     # accept
 171 # 1 22 42 2 3                           # reject
 172 # groups=(42),foo(1),bar(2),zot me(3)   # parsed by $GROUP_RX1
 173 # groups=22,42,1(foo),2(bar),3(zot(me)) # parsed by $GROUP_RX2
 174 #
 175 # and the groups= might be after, before, or between uid=... and gid=...
 176 use constant GROUP_RX1 => qr/
 177     ^
 178     (?<gr_name>.+)
 179     \(
 180         (?<gid>\d+)
 181     \)
 182     $
 183 /x;
 184 use constant GROUP_RX2 => qr/
 185     ^
 186     (?<gid>\d+)
 187     \(
 188         (?<gr_name>.+)
 189     \)
 190     $
 191 /x;
 192 sub _system_groups {
 193     my $cmd;
 194     my $str;
 195
 196     # prefer 'id' over 'groups' (is this ever wrong anywhere?)
 197     # and 'id -a' over 'id -Gn' (the former is good about spaces in group names)
 198
 199     $cmd = 'id -a 2>/dev/null || id 2>/dev/null';
 200     $str = `$cmd`;
 201     if ( $str && $str =~ /groups=/ ) {
 202         # $str is of the form:
 203         # uid=39957(gsar) gid=22(users) groups=33536,39181,22(users),0(root),1067(dev)
 204         # FreeBSD since 6.2 has a fake id -a:
 205         # uid=1001(tobez) gid=20(staff) groups=20(staff), 0(wheel), 68(dialer)
 206         # On AIX it's id
 207         #
 208         # Linux may also have a context= field
 209
 210         return ( $cmd, $str );
 211     }
 212
 213     $cmd = 'id -Gn 2>/dev/null';
 214     $str = `$cmd`;
 215     if ( $str && $str !~ /^[\d\s]$/ ) {
 216         # $str could be of the form:
 217         # users 33536 39181 root dev
 218         return ( $cmd, $str );
 219     }
 220
 221     $cmd = 'groups 2>/dev/null';
 222     $str = `$cmd`;
 223     if ( $str ) {
 224         # may not reflect all groups in some places, so do a sanity check
 225         if (-d '/afs') {
 226             print <<EOM;
 227 # These test results *may* be bogus, as you appear to have AFS,
 228 # and I can't find a working 'id' in your PATH (which I have set
 229 # to '$ENV{PATH}').
 230 #
 231 # If these tests fail, report the particular incantation you use
 232 # on this platform to find *all* the groups that an arbitrary
 233 # user may belong to, using the 'perlbug' program.
 234 EOM
 235         }
 236         return ( $cmd, $str );
 237     }
 238
 239     return ();
 240 }
 241
 242 # Convert the strings produced by parsing `id -a' into a list of group
 243 # names
 244 sub extract_system_groups {
 245     my ( $groups_string ) = @_;
 246
 247     # Remember that group names can contain whitespace, '-', '(parens)',
 248     # et cetera. That is: do not \w, do not \S.
 249     my @extracted;
 250
 251     my @fields = split /\b(\w+=)/, $groups_string;
 252     my $gr;
 253     for my $i (0..@fields-2) {
 254         if ($fields[$i] eq 'groups=') {
 255             $gr = $fields[$i+1];
 256             $gr =~ s/ $//;
 257             last;
 258         }
 259     }
 260     if (defined $gr) {
 261         my @g = split m{, ?}, $gr;
 262         # prefer names over numbers
 263         for (@g) {
 264             if ( $_ =~ GROUP_RX1() || $_ =~ GROUP_RX2() ) {
 265                 push @extracted, $+{gr_name} || $+{gid};
 266             }
 267             else {
 268                 print "# ignoring group entry [$_]\n";
 269             }
 270         }
 271
 272         diag_variable( gr => $gr );
 273         diag_variable( g => join ',', @g );
 274         diag_variable( ex_gr => join ',', @extracted );
 275     }
 276
 277     return @extracted;
 278 }
 279
 280 # Get the POSIX value NGROUPS_MAX.
 281 sub posix_ngroups_max {
 282     return eval {
 283         POSIX::NGROUPS_MAX();
 284     };
 285 }
 286
 287 # Test if this is Apple's darwin
 288 sub darwin {
 289     # Observed 'darwin-2level'
 290     return $Config::Config{myuname} =~ /^darwin/;
 291 }
 292
 293 # Test if this is Cygwin
 294 sub cygwin_nt {
 295     return $Config::Config{myuname} =~ /^cygwin_nt/i;
 296 }
 297
 298 # Get perl's supplementary groups and the number of times each gid
 299 # appeared.
 300 sub perl_groups {
 301     # Lookup perl's own groups from $(
 302     my @gids = split ' ', $(;
 303     my %gid_count;
 304     my @gr_name;
 305     for my $gid ( @gids ) {
 306         ++ $gid_count{$gid};
 307
 308         my ($group) = getgrgid $gid;
 309
 310         # Why does this test prefer to not test groups which we don't have
 311         # a name for? One possible answer is that my primary group comes
 312         # from from my entry in the user database but isn't mentioned in
 313         # the group database.  Are there more reasons?
 314         next if ! defined $group;
 315
 316
 317         push @gr_name, $group;
 318     }
 319
 320     diag_variable( gr_name => join ',', @gr_name );
 321
 322     return ( \ %gid_count, \ @gr_name );
 323 }
 324
 325 # Remove entries from our parsing of $( that don't appear in our
 326 # parsing of `id -a`.
 327 sub remove_unparsed_entries {
 328     my ( $extracted_groups, $perl_groups ) = @_;
 329
 330     my %was_extracted =
 331         map { $_ => 1 }
 332         @$extracted_groups;
 333
 334     return
 335         grep { $was_extracted{$_} }
 336         @$perl_groups;
 337 }
 338
 339 # Get a list of base groups. I'm not sure why cygwin by default is
 340 # skipped here.
 341 sub basegroups {
 342     my ( $pwgid, $pwgnam ) = @_;
 343
 344     if ( cygwin_nt() ) {
 345         return;
 346     }
 347     else {
 348         return (
 349             $pwgid  => 1,
 350             $pwgnam => 1,
 351         );
 352     }
 353 }
 354
 355 # Cygwin might have another form of basegroup which we should actually use
 356 sub unixy_cygwin_basegroups {
 357     my ( $pwgid, $pwgnam ) = @_;
 358     return (
 359         $pwgid  => 1,
 360         $pwgnam => 1,
 361     );
 362 }
 363
 364 # Filter a full list of groups and return only the supplementary
 365 # gorups.
 366 sub remove_basegroup {
 367     my ( $basegroups, $groups ) = @_;
 368
 369     return
 370         grep { ! $basegroups->{$_} }
 371         @$groups;
 372 }
 373
 374 # Test supplementary groups to see if they're a close enough match or
 375 # if there aren't any supplementary groups then validate the current
 376 # group against $(.
 377 sub match_groups {
 378     my ( $supplementary_groups, $extracted_supplementary_groups, $pwgid ) = @_;
 379
 380     # Compare perl vs system groups
 381     my %g;
 382     $g{$_}[0] = 1 for @$supplementary_groups;
 383     $g{$_}[1] = 1 for @$extracted_supplementary_groups;
 384
 385     # Find any mismatches
 386     my @misses =
 387         grep { ! ( $g{$_}[0] && $g{$_}[1] ) }
 388         sort keys %g;
 389
 390     return
 391         ! @misses
 392         || ( ! @$supplementary_groups
 393              && 1 == @$extracted_supplementary_groups
 394              && $pwgid == $extracted_supplementary_groups->[0] );
 395 }
 396
 397 # Print a nice little diagnostic.
 398 sub diag_variable {
 399     my ( $label, $content ) = @_;
 400
 401     printf "# %-11s=%s\n", $label, $content;
 402     return;
 403 }
 404
 405 # Removes duplicates from a list
 406 sub uniq {
 407     my %seen;
 408     return
 409         grep { ! $seen{$_}++ }
 410         @_;
 411 }
 412
 413 # Local variables:
 414 # indent-tabs-mode: nil
 415 # End:
 416 #
 417 # ex: set ts=8 sts=4 sw=4 noet: