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