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