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