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