This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
4b655c8e9c3eb0276c07f8cfa88859541be8784e
[perl5.git] / t / op / groups.t
1 #!./perl
2
3 $ENV{PATH} ="/bin:/usr/bin:/usr/xpg4/bin:/usr/ucb" .
4     exists $ENV{PATH} ? ":$ENV{PATH}" : "";
5 $ENV{LC_ALL} = "C"; # so that external utilities speak English
6 $ENV{LANGUAGE} = 'C'; # GNU locale extension
7
8 sub quit {
9     print "1..0 # Skip: no `id` or `groups`\n";
10     exit 0;
11 }
12
13 quit() if $^O eq 'MSWin32' or $^O =~ /lynxos/i;
14
15 # We have to find a command that prints all (effective
16 # and real) group names (not ids).  The known commands are:
17 # groups
18 # id -Gn
19 # id -a
20 # Beware 1: some systems do just 'id -G' even when 'id -Gn' is used.
21 # Beware 2: id -Gn or id -a format might be id(name) or name(id).
22 # Beware 3: the groups= might be anywhere in the id output.
23 # Beware 4: groups can have spaces ('id -a' being the only defense against this)
24 # Beware 5: id -a might not contain the groups= part.
25 #
26 # That is, we might meet the following:
27 #
28 # foo bar zot                           # accept
29 # foo 22 42 bar zot                     # accept
30 # 1 22 42 2 3                           # reject
31 # groups=(42),foo(1),bar(2),zot me(3)   # parse
32 # groups=22,42,1(foo),2(bar),3(zot me)  # parse
33 #
34 # and the groups= might be after, before, or between uid=... and gid=...
35
36 GROUPS: {
37     # prefer 'id' over 'groups' (is this ever wrong anywhere?)
38     # and 'id -a' over 'id -Gn' (the former is good about spaces in group names)
39     if (($groups = `id -a 2>/dev/null`) ne '') {
40         # $groups is of the form:
41         # uid=39957(gsar) gid=22(users) groups=33536,39181,22(users),0(root),1067(dev)
42         last GROUPS if $groups =~ /groups=/;
43     }
44     if (($groups = `id -Gn 2>/dev/null`) ne '') {
45         # $groups could be of the form:
46         # users 33536 39181 root dev
47         last GROUPS if $groups !~ /^(\d|\s)+$/;
48     }
49     if (($groups = `groups 2>/dev/null`) ne '') {
50         # may not reflect all groups in some places, so do a sanity check
51         if (-d '/afs') {
52             print <<EOM;
53 # These test results *may* be bogus, as you appear to have AFS,
54 # and I can't find a working 'id' in your PATH (which I have set
55 # to '$ENV{PATH}').
56 #
57 # If these tests fail, report the particular incantation you use
58 # on this platform to find *all* the groups that an arbitrary
59 # luser may belong to, using the 'perlbug' program.
60 EOM
61         }
62         last GROUPS;
63     }
64     # Okay, not today.
65     quit();
66 }
67
68 unless (eval { getgrgid(0); 1 }) {
69     print "1..0 # Skip: getgrgid() not implemented\n";
70     exit 0;
71 }
72
73 # Remember that group names can contain whitespace, '-', et cetera.
74 # That is: do not \w, do not \S.
75 if ($groups =~ /groups=(.+)( [ug]id=|$)/) {
76     my $gr = $1;
77     my @g0 = split /,/, $gr;
78     my @g1;
79     # prefer names over numbers
80     for (@g0) {
81         # 42(zot me)
82         if (/^(\d+)(?:\(([^)]+)\))?/) {
83             push @g1, ($2 || $1);
84         }
85         # zot me(42)
86         elsif (/^([^(]*)\((\d+)\)/) {
87             push @g1, ($1 || $2);
88         }
89         else {
90             print "# ignoring group entry [$_]\n";
91         }
92     }
93     print "# groups=$gr\n";
94     print "# g0 = @g0\n";
95     print "# g1 = @g1\n";
96     $groups = "@g1";
97 }
98
99 print "1..2\n";
100
101 $pwgid = $( + 0;
102 ($pwgnam) = getgrgid($pwgid);
103 @basegroup{$pwgid,$pwgnam} = (1,1);
104
105 $seen{$pwgid}++;
106
107 for (split(' ', $()) {
108     next if $seen{$_}++;
109     ($group) = getgrgid($_);
110     if (defined $group) {
111         push(@gr, $group);
112     }
113     else {
114         push(@gr, $_);
115     }
116
117
118 if ($^O eq "uwin") { # Or anybody else who can have spaces in group names.
119         $gr1 = join(' ', grep(!$did{$_}++, sort split(' ', join(' ', @gr))));
120 } else {
121         $gr1 = join(' ', sort @gr);
122 }
123
124 $gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups)));
125
126 if ($gr1 eq $gr2) {
127     print "ok 1\n";
128 }
129 else {
130     print "#gr1 is <$gr1>\n";
131     print "#gr2 is <$gr2>\n";
132     print "not ok 1\n";
133 }
134
135 # multiple 0's indicate GROUPSTYPE is currently long but should be short
136
137 if ($pwgid == 0 || $seen{0} < 2) {
138     print "ok 2\n";
139 }
140 else {
141     print "not ok 2 (groupstype should be type short, not long)\n";
142 }