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