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