This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
tolerate spaces in group names in test on solaris (from David Boyce
[perl5.git] / t / op / groups.t
CommitLineData
fe14fcc3
LW
1#!./perl
2
61ae2fbf
JH
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
b598356e 6$ENV{LANGUAGE} = 'C'; # GNU locale extension
b9416812 7
13d7cbc1 8sub quit {
45c0de28 9 print "1..0 # Skip: no `id` or `groups`\n";
13d7cbc1
GS
10 exit 0;
11}
12
883d36a6 13quit() if $^O eq 'MSWin32' or $^O =~ /lynxos/i;
13d7cbc1 14
d0f88fcc
JH
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.
98cfb1fc
JH
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.
f62c0cf2 23# Beware 4: groups can have spaces ('id -a' being the only defense against this)
702a0e5a 24# Beware 5: id -a might not contain the groups= part.
98cfb1fc
JH
25#
26# That is, we might meet the following:
27#
f62c0cf2
GS
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
98cfb1fc
JH
33#
34# and the groups= might be after, before, or between uid=... and gid=...
d0f88fcc
JH
35
36GROUPS: {
f62c0cf2
GS
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)
702a0e5a 42 last GROUPS if $groups =~ /groups=/;
f62c0cf2
GS
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)+$/;
d0f88fcc 48 }
f62c0cf2
GS
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.
60EOM
61 }
98cfb1fc 62 last GROUPS;
d0f88fcc
JH
63 }
64 # Okay, not today.
13d7cbc1 65 quit();
fe14fcc3
LW
66}
67
4435c477
IZ
68unless (eval { getgrgid(0); 1 }) {
69 print "1..0 # Skip: getgrgid() not implemented\n";
70 exit 0;
71}
72
98cfb1fc
JH
73# Remember that group names can contain whitespace, '-', et cetera.
74# That is: do not \w, do not \S.
f62c0cf2 75if ($groups =~ /groups=(.+)( [ug]id=|$)/) {
98cfb1fc 76 my $gr = $1;
f62c0cf2
GS
77 my @g0 = split /,/, $gr;
78 my @g1;
79 # prefer names over numbers
80 for (@g0) {
81 # 42(zot me)
9461e3d0 82 if (/^(\d+)(?:\(([^)]+)\))?/) {
f62c0cf2
GS
83 push @g1, ($2 || $1);
84 }
85 # zot me(42)
9461e3d0 86 elsif (/^([^(]*)\((\d+)\)/) {
f62c0cf2
GS
87 push @g1, ($1 || $2);
88 }
89 else {
90 print "# ignoring group entry [$_]\n";
91 }
92 }
93 print "# groups=$gr\n";
98cfb1fc
JH
94 print "# g0 = @g0\n";
95 print "# g1 = @g1\n";
f62c0cf2 96 $groups = "@g1";
98cfb1fc
JH
97}
98
988174c1
LW
99print "1..2\n";
100
101$pwgid = $( + 0;
102($pwgnam) = getgrgid($pwgid);
103@basegroup{$pwgid,$pwgnam} = (1,1);
104
105$seen{$pwgid}++;
fe14fcc3
LW
106
107for (split(' ', $()) {
108 next if $seen{$_}++;
6e21c824
LW
109 ($group) = getgrgid($_);
110 if (defined $group) {
111 push(@gr, $group);
112 }
113 else {
114 push(@gr, $_);
115 }
fe14fcc3 116}
988174c1 117
27b4d0f8
GS
118if ($^O =~ /^(?:uwin|solaris)$/) {
119 # Or anybody else who can have spaces in group names.
72720e3c
GS
120 $gr1 = join(' ', grep(!$did{$_}++, sort split(' ', join(' ', @gr))));
121} else {
122 $gr1 = join(' ', sort @gr);
123}
988174c1 124
b9416812 125$gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups)));
988174c1
LW
126
127if ($gr1 eq $gr2) {
128 print "ok 1\n";
129}
130else {
131 print "#gr1 is <$gr1>\n";
132 print "#gr2 is <$gr2>\n";
133 print "not ok 1\n";
134}
135
136# multiple 0's indicate GROUPSTYPE is currently long but should be short
137
138if ($pwgid == 0 || $seen{0} < 2) {
139 print "ok 2\n";
140}
141else {
142 print "not ok 2 (groupstype should be type short, not long)\n";
143}