Commit | Line | Data |
---|---|---|
fe14fcc3 LW |
1 | #!./perl |
2 | ||
61ae2fbf | 3 | $ENV{PATH} ="/bin:/usr/bin:/usr/xpg4/bin:/usr/ucb" . |
211b0ba3 | 4 | exists $ENV{PATH} ? ":$ENV{PATH}" : "" unless $^O eq 'VMS'; |
61ae2fbf | 5 | $ENV{LC_ALL} = "C"; # so that external utilities speak English |
b598356e | 6 | $ENV{LANGUAGE} = 'C'; # GNU locale extension |
b9416812 | 7 | |
9380b46b | 8 | BEGIN { |
e0889c13 MS |
9 | chdir 't'; |
10 | @INC = '../lib'; | |
11 | ||
9380b46b JH |
12 | require Config; |
13 | if ($@) { | |
14 | print "1..0 # Skip: no Config\n"; | |
15 | } else { | |
16 | Config->import; | |
17 | } | |
18 | } | |
19 | ||
13d7cbc1 | 20 | sub quit { |
45c0de28 | 21 | print "1..0 # Skip: no `id` or `groups`\n"; |
13d7cbc1 GS |
22 | exit 0; |
23 | } | |
24 | ||
8e3eacad MS |
25 | unless (eval { getgrgid(0); 1 }) { |
26 | print "1..0 # Skip: getgrgid() not implemented\n"; | |
27 | exit 0; | |
28 | } | |
29 | ||
211b0ba3 JM |
30 | quit() if (($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') |
31 | or $^O =~ /lynxos/i); | |
13d7cbc1 | 32 | |
d0f88fcc JH |
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. | |
98cfb1fc JH |
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. | |
f62c0cf2 | 41 | # Beware 4: groups can have spaces ('id -a' being the only defense against this) |
702a0e5a | 42 | # Beware 5: id -a might not contain the groups= part. |
98cfb1fc JH |
43 | # |
44 | # That is, we might meet the following: | |
45 | # | |
f62c0cf2 GS |
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 | |
98cfb1fc JH |
51 | # |
52 | # and the groups= might be after, before, or between uid=... and gid=... | |
d0f88fcc JH |
53 | |
54 | GROUPS: { | |
f62c0cf2 GS |
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) | |
7b75a55b AB |
60 | # FreeBSD since 6.2 has a fake id -a: |
61 | # uid=1001(tobez) gid=20(staff) groups=20(staff), 0(wheel), 68(dialer) | |
702a0e5a | 62 | last GROUPS if $groups =~ /groups=/; |
f62c0cf2 GS |
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)+$/; | |
d0f88fcc | 68 | } |
f62c0cf2 GS |
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 | |
9380b46b | 79 | # user may belong to, using the 'perlbug' program. |
f62c0cf2 GS |
80 | EOM |
81 | } | |
98cfb1fc | 82 | last GROUPS; |
d0f88fcc JH |
83 | } |
84 | # Okay, not today. | |
13d7cbc1 | 85 | quit(); |
fe14fcc3 LW |
86 | } |
87 | ||
dd570ea6 JH |
88 | chomp($groups); |
89 | ||
90 | print "# groups = $groups\n"; | |
91 | ||
98cfb1fc JH |
92 | # Remember that group names can contain whitespace, '-', et cetera. |
93 | # That is: do not \w, do not \S. | |
f62c0cf2 | 94 | if ($groups =~ /groups=(.+)( [ug]id=|$)/) { |
98cfb1fc | 95 | my $gr = $1; |
7b75a55b | 96 | my @g0 = split /, ?/, $gr; |
f62c0cf2 GS |
97 | my @g1; |
98 | # prefer names over numbers | |
99 | for (@g0) { | |
da4b9520 | 100 | # 42(zot me) |
9461e3d0 | 101 | if (/^(\d+)(?:\(([^)]+)\))?/) { |
f62c0cf2 GS |
102 | push @g1, ($2 || $1); |
103 | } | |
da4b9520 | 104 | # zot me(42) |
9461e3d0 | 105 | elsif (/^([^(]*)\((\d+)\)/) { |
f62c0cf2 GS |
106 | push @g1, ($1 || $2); |
107 | } | |
108 | else { | |
109 | print "# ignoring group entry [$_]\n"; | |
110 | } | |
111 | } | |
112 | print "# groups=$gr\n"; | |
98cfb1fc JH |
113 | print "# g0 = @g0\n"; |
114 | print "# g1 = @g1\n"; | |
f62c0cf2 | 115 | $groups = "@g1"; |
98cfb1fc JH |
116 | } |
117 | ||
988174c1 LW |
118 | print "1..2\n"; |
119 | ||
120 | $pwgid = $( + 0; | |
121 | ($pwgnam) = getgrgid($pwgid); | |
988174c1 | 122 | $seen{$pwgid}++; |
fe14fcc3 | 123 | |
dd570ea6 JH |
124 | print "# pwgid = $pwgid, pwgnam = $pwgnam\n"; |
125 | ||
fe14fcc3 | 126 | for (split(' ', $()) { |
6e21c824 | 127 | ($group) = getgrgid($_); |
04333ffa | 128 | next if (! defined $group or ! grep { $_ eq $group } @gr) and $seen{$_}++; |
6e21c824 LW |
129 | if (defined $group) { |
130 | push(@gr, $group); | |
131 | } | |
132 | else { | |
133 | push(@gr, $_); | |
134 | } | |
da4b9520 | 135 | } |
988174c1 | 136 | |
dd570ea6 JH |
137 | print "# gr = @gr\n"; |
138 | ||
da4b9520 | 139 | my %did; |
d4e5d774 | 140 | if ($^O =~ /^(?:uwin|cygwin|interix|solaris|linux)$/) { |
27b4d0f8 | 141 | # Or anybody else who can have spaces in group names. |
72720e3c GS |
142 | $gr1 = join(' ', grep(!$did{$_}++, sort split(' ', join(' ', @gr)))); |
143 | } else { | |
da4b9520 SP |
144 | # Don't assume that there aren't duplicate groups |
145 | $gr1 = join(' ', sort grep defined $_ && !$did{$_}++, @gr); | |
72720e3c | 146 | } |
988174c1 | 147 | |
732266dc MB |
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 | } | |
b9416812 | 153 | $gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups))); |
988174c1 | 154 | |
732266dc | 155 | my $ok1 = 0; |
dd570ea6 | 156 | if ($gr1 eq $gr2 || ($gr1 eq '' && $gr2 eq $pwgid)) { |
988174c1 | 157 | print "ok 1\n"; |
732266dc | 158 | $ok1++; |
988174c1 | 159 | } |
732266dc MB |
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) { | |
988174c1 LW |
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 | } |