t/op/groups.t

   1 #!./perl
   2
   3 $ENV{PATH} ="/bin:/usr/bin:/usr/xpg4/bin:/usr/ucb" .
   4     exists $ENV{PATH} ? ":$ENV{PATH}" : "" unless $^O eq 'VMS';
   5 $ENV{LC_ALL} = "C"; # so that external utilities speak English
   6 $ENV{LANGUAGE} = 'C'; # GNU locale extension
   7
   8 BEGIN {
   9     chdir 't';
  10     @INC = '../lib';
  11
  12     require Config;
  13     if ($@) {
  14         print "1..0 # Skip: no Config\n";
  15     } else {
  16         Config->import;
  17     }
  18 }
  19
  20 sub quit {
  21     print "1..0 # Skip: no `id` or `groups`\n";
  22     exit 0;
  23 }
  24
  25 unless (eval { getgrgid(0); 1 }) {
  26     print "1..0 # Skip: getgrgid() not implemented\n";
  27     exit 0;
  28 }
  29
  30 quit() if (($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS')
  31            or $^O =~ /lynxos/i);
  32
  33 # We have to find a command that prints all (effective
  34 # and real) group names (not ids).  The known commands are:
  35 # groups
  36 # id -Gn
  37 # id -a
  38 # Beware 1: some systems do just 'id -G' even when 'id -Gn' is used.
  39 # Beware 2: id -Gn or id -a format might be id(name) or name(id).
  40 # Beware 3: the groups= might be anywhere in the id output.
  41 # Beware 4: groups can have spaces ('id -a' being the only defense against this)
  42 # Beware 5: id -a might not contain the groups= part.
  43 #
  44 # That is, we might meet the following:
  45 #
  46 # foo bar zot                           # accept
  47 # foo 22 42 bar zot                     # accept
  48 # 1 22 42 2 3                           # reject
  49 # groups=(42),foo(1),bar(2),zot me(3)   # parse
  50 # groups=22,42,1(foo),2(bar),3(zot me)  # parse
  51 #
  52 # and the groups= might be after, before, or between uid=... and gid=...
  53
  54 GROUPS: {
  55     # prefer 'id' over 'groups' (is this ever wrong anywhere?)
  56     # and 'id -a' over 'id -Gn' (the former is good about spaces in group names)
  57     if (($groups = `id -a 2>/dev/null`) ne '') {
  58         # $groups is of the form:
  59         # uid=39957(gsar) gid=22(users) groups=33536,39181,22(users),0(root),1067(dev)
  60         # FreeBSD since 6.2 has a fake id -a:
  61         # uid=1001(tobez) gid=20(staff) groups=20(staff), 0(wheel), 68(dialer)
  62         last GROUPS if $groups =~ /groups=/;
  63     }
  64     if (($groups = `id -Gn 2>/dev/null`) ne '') {
  65         # $groups could be of the form:
  66         # users 33536 39181 root dev
  67         last GROUPS if $groups !~ /^(\d|\s)+$/;
  68     }
  69     if (($groups = `groups 2>/dev/null`) ne '') {
  70         # may not reflect all groups in some places, so do a sanity check
  71         if (-d '/afs') {
  72             print <<EOM;
  73 # These test results *may* be bogus, as you appear to have AFS,
  74 # and I can't find a working 'id' in your PATH (which I have set
  75 # to '$ENV{PATH}').
  76 #
  77 # If these tests fail, report the particular incantation you use
  78 # on this platform to find *all* the groups that an arbitrary
  79 # user may belong to, using the 'perlbug' program.
  80 EOM
  81         }
  82         last GROUPS;
  83     }
  84     # Okay, not today.
  85     quit();
  86 }
  87
  88 chomp($groups);
  89
  90 print "# groups = $groups\n";
  91
  92 # Remember that group names can contain whitespace, '-', et cetera.
  93 # That is: do not \w, do not \S.
  94 if ($groups =~ /groups=(.+)( [ug]id=|$)/) {
  95     my $gr = $1;
  96     my @g0 = split /, ?/, $gr;
  97     my @g1;
  98     # prefer names over numbers
  99     for (@g0) {
 100         # 42(zot me)
 101         if (/^(\d+)(?:\(([^)]+)\))?/) {
 102             push @g1, ($2 || $1);
 103         }
 104         # zot me(42)
 105         elsif (/^([^(]*)\((\d+)\)/) {
 106             push @g1, ($1 || $2);
 107         }
 108         else {
 109             print "# ignoring group entry [$_]\n";
 110         }
 111     }
 112     print "# groups=$gr\n";
 113     print "# g0 = @g0\n";
 114     print "# g1 = @g1\n";
 115     $groups = "@g1";
 116 }
 117
 118 print "1..2\n";
 119
 120 $pwgid = $( + 0;
 121 ($pwgnam) = getgrgid($pwgid);
 122 $seen{$pwgid}++;
 123
 124 print "# pwgid = $pwgid, pwgnam = $pwgnam\n";
 125
 126 for (split(' ', $()) {
 127     ($group) = getgrgid($_);
 128     next if (! defined $group or ! grep { $_ eq $group } @gr) and $seen{$_}++;
 129     if (defined $group) {
 130         push(@gr, $group);
 131     }
 132     else {
 133         push(@gr, $_);
 134     }
 135 }
 136
 137 print "# gr = @gr\n";
 138
 139 my %did;
 140 if ($^O =~ /^(?:uwin|cygwin|interix|solaris|linux|darwin)$/) {
 141         # Or anybody else who can have spaces in group names.
 142         $gr1 = join(' ', grep(!$did{$_}++, sort split(' ', join(' ', @gr))));
 143 } else {
 144         # Don't assume that there aren't duplicate groups
 145         $gr1 = join(' ', sort grep defined $_ && !$did{$_}++, @gr);
 146 }
 147
 148 if ($Config{myuname} =~ /^cygwin_nt/i) { # basegroup on CYGWIN_NT has id = 0.
 149     @basegroup{$pwgid,$pwgnam} = (0,0);
 150 } else {
 151     @basegroup{$pwgid,$pwgnam} = (1,1);
 152 }
 153 $gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups)));
 154
 155 my $ok1 = 0;
 156 if ($gr1 eq $gr2 || ($gr1 eq '' && $gr2 eq $pwgid)) {
 157     print "ok 1\n";
 158     $ok1++;
 159 }
 160 elsif ($Config{myuname} =~ /^cygwin_nt/i) { # basegroup on CYGWIN_NT has id = 0.
 161     # Retry in default unix mode
 162     %basegroup = ( $pwgid => 1, $pwgnam => 1 );
 163     $gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups)));
 164     if ($gr1 eq $gr2 || ($gr1 eq '' && $gr2 eq $pwgid)) {
 165         print "ok 1 # This Cygwin behaves like Unix (Win2k?)\n";
 166         $ok1++;
 167     }
 168 }
 169 unless ($ok1) {
 170     print "#gr1 is <$gr1>\n";
 171     print "#gr2 is <$gr2>\n";
 172     print "not ok 1\n";
 173 }
 174
 175 # multiple 0's indicate GROUPSTYPE is currently long but should be short
 176
 177 if ($pwgid == 0 || $seen{0} < 2) {
 178     print "ok 2\n";
 179 }
 180 else {
 181     print "not ok 2 (groupstype should be type short, not long)\n";
 182 }