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