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