This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Test preamble: unify chdir 't' if -d 't';
[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' if -d 't';
14     @INC = '../lib';
15     require './test.pl';
16     skip_all_if_miniperl("no dynamic loading on miniperl, no POSIX");
17 }
18 use 5.010;
19 use strict;
20 use Config ();
21 use POSIX ();
22
23 skip_all('getgrgid() not implemented')
24     unless eval { my($foo) = getgrgid(0); 1 };
25
26 skip_all("No 'id' or 'groups'") if
27     $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS' || $^O =~ /lynxos/i;
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()
39         or skip_all("No 'id' or 'groups'");
40     my @extracted_groups = extract_system_groups( $groups_string )
41         or skip_all("Can't parse '${groups_command}'");
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     }
73
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";
87     }
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;
133 }
134
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     }
144
145     return ( $cmd, $groups_string );
146 }
147
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.
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.
156 # Beware 4: groups can have spaces ('id -a' being the only defense against this)
157 # Beware 5: id -a might not contain the groups= part.
158 #
159 # That is, we might meet the following:
160 #
161 # foo bar zot                           # accept
162 # foo 22 42 bar zot                     # accept
163 # 1 22 42 2 3                           # reject
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
166 #
167 # and the groups= might be after, before, or between uid=... and gid=...
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;
187
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)
190
191     $cmd = 'id -a 2>/dev/null || id 2>/dev/null';
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)
198         # On AIX it's id
199         #
200         # Linux may also have a context= field
201
202         return ( $cmd, $str );
203     }
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 );
211     }
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;
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
225 # user may belong to, using the 'perlbug' program.
226 EOM
227         }
228         return ( $cmd, $str );
229     }
230
231     return ();
232 }
233
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 ) = @_;
238
239     # Remember that group names can contain whitespace, '-', '(parens)',
240     # et cetera. That is: do not \w, do not \S.
241     my @extracted;
242
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) {
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         }
263
264         diag_variable( gr => $gr );
265         diag_variable( g => join ',', @g );
266         diag_variable( ex_gr => join ',', @extracted );
267     }
268
269     return @extracted;
270 }
271
272 # Get the POSIX value NGROUPS_MAX.
273 sub posix_ngroups_max {
274     return eval {
275         POSIX::NGROUPS_MAX();
276     };
277 }
278
279 # Test if this is Apple's darwin
280 sub darwin {
281     # Observed 'darwin-2level'
282     return $Config::Config{myuname} =~ /^darwin/;
283 }
284
285 # Test if this is Cygwin
286 sub cygwin_nt {
287     return $Config::Config{myuname} =~ /^cygwin_nt/i;
288 }
289
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 );
315 }
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;
338     }
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;
364 }
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] );
387 }
388
389 # Print a nice little diagnostic.
390 sub diag_variable {
391     my ( $label, $content ) = @_;
392
393     printf "# %-11s=%s\n", $label, $content;
394     return;
395 }
396
397 # Removes duplicates from a list
398 sub uniq {
399     my %seen;
400     return
401         grep { ! $seen{$_}++ }
402         @_;
403 }
404
405 # Local variables:
406 # indent-tabs-mode: nil
407 # End:
408 #
409 # ex: set ts=8 sts=4 sw=4 et: