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