t/op/groups.t

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