Small optimisations, by Brandon Black
[p5sagit/p5-mst-13.2.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 BEGIN {
9     chdir 't';
10     @INC = '../lib';
11
12     require Config;
13     if ($@) {
14         print "1..0 # Skip: no Config\n";
15     } else {
16         Config->import;
17     }
18 }
19
20 sub quit {
21     print "1..0 # Skip: no `id` or `groups`\n";
22     exit 0;
23 }
24
25 unless (eval { getgrgid(0); 1 }) {
26     print "1..0 # Skip: getgrgid() not implemented\n";
27     exit 0;
28 }
29
30 quit() if (($^O eq 'MSWin32' || $^O eq 'NetWare') or $^O =~ /lynxos/i);
31
32 # We have to find a command that prints all (effective
33 # and real) group names (not ids).  The known commands are:
34 # groups
35 # id -Gn
36 # id -a
37 # Beware 1: some systems do just 'id -G' even when 'id -Gn' is used.
38 # Beware 2: id -Gn or id -a format might be id(name) or name(id).
39 # Beware 3: the groups= might be anywhere in the id output.
40 # Beware 4: groups can have spaces ('id -a' being the only defense against this)
41 # Beware 5: id -a might not contain the groups= part.
42 #
43 # That is, we might meet the following:
44 #
45 # foo bar zot                           # accept
46 # foo 22 42 bar zot                     # accept
47 # 1 22 42 2 3                           # reject
48 # groups=(42),foo(1),bar(2),zot me(3)   # parse
49 # groups=22,42,1(foo),2(bar),3(zot me)  # parse
50 #
51 # and the groups= might be after, before, or between uid=... and gid=...
52
53 GROUPS: {
54     # prefer 'id' over 'groups' (is this ever wrong anywhere?)
55     # and 'id -a' over 'id -Gn' (the former is good about spaces in group names)
56     if (($groups = `id -a 2>/dev/null`) ne '') {
57         # $groups is of the form:
58         # uid=39957(gsar) gid=22(users) groups=33536,39181,22(users),0(root),1067(dev)
59         # FreeBSD since 6.2 has a fake id -a:
60         # uid=1001(tobez) gid=20(staff) groups=20(staff), 0(wheel), 68(dialer)
61         last GROUPS if $groups =~ /groups=/;
62     }
63     if (($groups = `id -Gn 2>/dev/null`) ne '') {
64         # $groups could be of the form:
65         # users 33536 39181 root dev
66         last GROUPS if $groups !~ /^(\d|\s)+$/;
67     }
68     if (($groups = `groups 2>/dev/null`) ne '') {
69         # may not reflect all groups in some places, so do a sanity check
70         if (-d '/afs') {
71             print <<EOM;
72 # These test results *may* be bogus, as you appear to have AFS,
73 # and I can't find a working 'id' in your PATH (which I have set
74 # to '$ENV{PATH}').
75 #
76 # If these tests fail, report the particular incantation you use
77 # on this platform to find *all* the groups that an arbitrary
78 # user may belong to, using the 'perlbug' program.
79 EOM
80         }
81         last GROUPS;
82     }
83     # Okay, not today.
84     quit();
85 }
86
87 chomp($groups);
88
89 print "# groups = $groups\n";
90
91 # Remember that group names can contain whitespace, '-', et cetera.
92 # That is: do not \w, do not \S.
93 if ($groups =~ /groups=(.+)( [ug]id=|$)/) {
94     my $gr = $1;
95     my @g0 = split /, ?/, $gr;
96     my @g1;
97     # prefer names over numbers
98     for (@g0) {
99         # 42(zot me)
100         if (/^(\d+)(?:\(([^)]+)\))?/) {
101             push @g1, ($2 || $1);
102         }
103         # zot me(42)
104         elsif (/^([^(]*)\((\d+)\)/) {
105             push @g1, ($1 || $2);
106         }
107         else {
108             print "# ignoring group entry [$_]\n";
109         }
110     }
111     print "# groups=$gr\n";
112     print "# g0 = @g0\n";
113     print "# g1 = @g1\n";
114     $groups = "@g1";
115 }
116
117 print "1..2\n";
118
119 $pwgid = $( + 0;
120 ($pwgnam) = getgrgid($pwgid);
121 $seen{$pwgid}++;
122
123 print "# pwgid = $pwgid, pwgnam = $pwgnam\n";
124
125 for (split(' ', $()) {
126     ($group) = getgrgid($_);
127     next if (! defined $group or ! grep { $_ eq $group } @gr) and $seen{$_}++;
128     if (defined $group) {
129         push(@gr, $group);
130     }
131     else {
132         push(@gr, $_);
133     }
134 }
135
136 print "# gr = @gr\n";
137
138 my %did;
139 if ($^O =~ /^(?:uwin|cygwin|interix|solaris)$/) {
140         # Or anybody else who can have spaces in group names.
141         $gr1 = join(' ', grep(!$did{$_}++, sort split(' ', join(' ', @gr))));
142 } else {
143         # Don't assume that there aren't duplicate groups
144         $gr1 = join(' ', sort grep defined $_ && !$did{$_}++, @gr);
145 }
146
147 if ($Config{myuname} =~ /^cygwin_nt/i) { # basegroup on CYGWIN_NT has id = 0.
148     @basegroup{$pwgid,$pwgnam} = (0,0);
149 } else {
150     @basegroup{$pwgid,$pwgnam} = (1,1);
151 }
152 $gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups)));
153
154 my $ok1 = 0;
155 if ($gr1 eq $gr2 || ($gr1 eq '' && $gr2 eq $pwgid)) {
156     print "ok 1\n";
157     $ok1++;
158 }
159 elsif ($Config{myuname} =~ /^cygwin_nt/i) { # basegroup on CYGWIN_NT has id = 0.
160     # Retry in default unix mode
161     %basegroup = ( $pwgid => 1, $pwgnam => 1 );
162     $gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups)));
163     if ($gr1 eq $gr2 || ($gr1 eq '' && $gr2 eq $pwgid)) {
164         print "ok 1 # This Cygwin behaves like Unix (Win2k?)\n";
165         $ok1++;
166     }
167 }
168 unless ($ok1) {
169     print "#gr1 is <$gr1>\n";
170     print "#gr2 is <$gr2>\n";
171     print "not ok 1\n";
172 }
173
174 # multiple 0's indicate GROUPSTYPE is currently long but should be short
175
176 if ($pwgid == 0 || $seen{0} < 2) {
177     print "ok 2\n";
178 }
179 else {
180     print "not ok 2 (groupstype should be type short, not long)\n";
181 }