This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
stop op/groups.t skipping on Linux
[perl5.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';
14     @INC = '../lib';
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     }
75
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";
89     }
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;
135 }
136
137 # Cleanly abort this entire test file
138 sub quit {
139     print "1..0 # SKIP: @_\n";
140     exit 0;
141 }
142
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     }
152
153     return ( $cmd, $groups_string );
154 }
155
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.
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.
164 # Beware 4: groups can have spaces ('id -a' being the only defense against this)
165 # Beware 5: id -a might not contain the groups= part.
166 #
167 # That is, we might meet the following:
168 #
169 # foo bar zot                           # accept
170 # foo 22 42 bar zot                     # accept
171 # 1 22 42 2 3                           # reject
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
174 #
175 # and the groups= might be after, before, or between uid=... and gid=...
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;
195
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)
198
199     $cmd = 'id -a 2>/dev/null';
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)
206         #
207         # Linux may also have a context= field
208
209         return ( $cmd, $str );
210     }
211
212     $cmd = 'id -Gn 2>/dev/null';
213     $str = `$cmd`;
214     if ( $str && $str !~ /^[\d\s]$/ ) {
215         # $str could be of the form:
216         # users 33536 39181 root dev
217         return ( $cmd, $str );
218     }
219
220     $cmd = 'groups 2>/dev/null';
221     $str = `$cmd`;
222     if ( $str ) {
223         # may not reflect all groups in some places, so do a sanity check
224         if (-d '/afs') {
225             print <<EOM;
226 # These test results *may* be bogus, as you appear to have AFS,
227 # and I can't find a working 'id' in your PATH (which I have set
228 # to '$ENV{PATH}').
229 #
230 # If these tests fail, report the particular incantation you use
231 # on this platform to find *all* the groups that an arbitrary
232 # user may belong to, using the 'perlbug' program.
233 EOM
234         }
235         return ( $cmd, $str );
236     }
237
238     return ();
239 }
240
241 # Convert the strings produced by parsing `id -a' into a list of group
242 # names
243 sub extract_system_groups {
244     my ( $groups_string ) = @_;
245
246     # Remember that group names can contain whitespace, '-', '(parens)',
247     # et cetera. That is: do not \w, do not \S.
248     my @extracted;
249
250     my @fields = split /\b(\w+=)/, $groups_string;
251     my $gr;
252     for my $i (0..@fields-2) {
253         if ($fields[$i] eq 'groups=') {
254             $gr = $fields[$i+1];
255             $gr =~ s/ $//;
256             last;
257         }
258     }
259     if (defined $gr) {
260         my @g = split m{, ?}, $gr;
261         # prefer names over numbers
262         for (@g) {
263             if ( $_ =~ GROUP_RX1() || $_ =~ GROUP_RX2() ) {
264                 push @extracted, $+{gr_name} || $+{gid};
265             }
266             else {
267                 print "# ignoring group entry [$_]\n";
268             }
269         }
270
271         diag_variable( gr => $gr );
272         diag_variable( g => join ',', @g );
273         diag_variable( ex_gr => join ',', @extracted );
274     }
275
276     return @extracted;
277 }
278
279 # Get the POSIX value NGROUPS_MAX.
280 sub posix_ngroups_max {
281     return eval {
282         POSIX::NGROUPS_MAX();
283     };
284 }
285
286 # Test if this is Apple's darwin
287 sub darwin {
288     # Observed 'darwin-2level'
289     return $Config::Config{myuname} =~ /^darwin/;
290 }
291
292 # Test if this is Cygwin
293 sub cygwin_nt {
294     return $Config::Config{myuname} =~ /^cygwin_nt/i;
295 }
296
297 # Get perl's supplementary groups and the number of times each gid
298 # appeared.
299 sub perl_groups {
300     # Lookup perl's own groups from $(
301     my @gids = split ' ', $(;
302     my %gid_count;
303     my @gr_name;
304     for my $gid ( @gids ) {
305         ++ $gid_count{$gid};
306
307         my ($group) = getgrgid $gid;
308
309         # Why does this test prefer to not test groups which we don't have
310         # a name for? One possible answer is that my primary group comes
311         # from from my entry in the user database but isn't mentioned in
312         # the group database.  Are there more reasons?
313         next if ! defined $group;
314
315
316         push @gr_name, $group;
317     }
318
319     diag_variable( gr_name => join ',', @gr_name );
320
321     return ( \ %gid_count, \ @gr_name );
322 }
323
324 # Remove entries from our parsing of $( that don't appear in our
325 # parsing of `id -a`.
326 sub remove_unparsed_entries {
327     my ( $extracted_groups, $perl_groups ) = @_;
328
329     my %was_extracted =
330         map { $_ => 1 }
331         @$extracted_groups;
332
333     return
334         grep { $was_extracted{$_} }
335         @$perl_groups;
336 }
337
338 # Get a list of base groups. I'm not sure why cygwin by default is
339 # skipped here.
340 sub basegroups {
341     my ( $pwgid, $pwgnam ) = @_;
342
343     if ( cygwin_nt() ) {
344         return;
345     }
346     else {
347         return (
348             $pwgid  => 1,
349             $pwgnam => 1,
350         );
351     }
352 }
353
354 # Cygwin might have another form of basegroup which we should actually use
355 sub unixy_cygwin_basegroups {
356     my ( $pwgid, $pwgnam ) = @_;
357     return (
358         $pwgid  => 1,
359         $pwgnam => 1,
360     );
361 }
362
363 # Filter a full list of groups and return only the supplementary
364 # gorups.
365 sub remove_basegroup {
366     my ( $basegroups, $groups ) = @_;
367
368     return
369         grep { ! $basegroups->{$_} }
370         @$groups;
371 }
372
373 # Test supplementary groups to see if they're a close enough match or
374 # if there aren't any supplementary groups then validate the current
375 # group against $(.
376 sub match_groups {
377     my ( $supplementary_groups, $extracted_supplementary_groups, $pwgid ) = @_;
378
379     # Compare perl vs system groups
380     my %g;
381     $g{$_}[0] = 1 for @$supplementary_groups;
382     $g{$_}[1] = 1 for @$extracted_supplementary_groups;
383
384     # Find any mismatches
385     my @misses =
386         grep { ! ( $g{$_}[0] && $g{$_}[1] ) }
387         sort keys %g;
388
389     return
390         ! @misses
391         || ( ! @$supplementary_groups
392              && 1 == @$extracted_supplementary_groups
393              && $pwgid == $extracted_supplementary_groups->[0] );
394 }
395
396 # Print a nice little diagnostic.
397 sub diag_variable {
398     my ( $label, $content ) = @_;
399
400     printf "# %-11s=%s\n", $label, $content;
401     return;
402 }
403
404 # Removes duplicates from a list
405 sub uniq {
406     my %seen;
407     return
408         grep { ! $seen{$_}++ }
409         @_;
410 }
411
412 # Local variables:
413 # indent-tabs-mode: nil
414 # End:
415 #
416 # ex: set ts=8 sts=4 sw=4 noet: