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