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