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
11 print "1..0 # Skip: no Config\n";
18 print "1..0 # Skip: no `id` or `groups`\n";
22 unless (eval { getgrgid(0); 1 }) {
23 print "1..0 # Skip: getgrgid() not implemented\n";
27 quit() if (($^O eq 'MSWin32' || $^O eq 'NetWare') or $^O =~ /lynxos/i);
29 # We have to find a command that prints all (effective
30 # and real) group names (not ids). The known commands are:
34 # Beware 1: some systems do just 'id -G' even when 'id -Gn' is used.
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.
37 # Beware 4: groups can have spaces ('id -a' being the only defense against this)
38 # Beware 5: id -a might not contain the groups= part.
40 # That is, we might meet the following:
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
48 # and the groups= might be after, before, or between uid=... and gid=...
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)
56 last GROUPS if $groups =~ /groups=/;
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)+$/;
63 if (($groups = `groups 2>/dev/null`) ne '') {
64 # may not reflect all groups in some places, so do a sanity check
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
71 # If these tests fail, report the particular incantation you use
72 # on this platform to find *all* the groups that an arbitrary
73 # user may belong to, using the 'perlbug' program.
84 print "# groups = $groups\n";
86 # Remember that group names can contain whitespace, '-', et cetera.
87 # That is: do not \w, do not \S.
88 if ($groups =~ /groups=(.+)( [ug]id=|$)/) {
90 my @g0 = split /,/, $gr;
92 # prefer names over numbers
95 if (/^(\d+)(?:\(([^)]+)\))?/) {
99 elsif (/^([^(]*)\((\d+)\)/) {
100 push @g1, ($1 || $2);
103 print "# ignoring group entry [$_]\n";
106 print "# groups=$gr\n";
107 print "# g0 = @g0\n";
108 print "# g1 = @g1\n";
115 ($pwgnam) = getgrgid($pwgid);
116 if ($Config{myuname} =~ /^cygwin_nt/i) { # basegroup on CYGWIN_NT has id = 0.
117 @basegroup{$pwgid,$pwgnam} = (0,0);
119 @basegroup{$pwgid,$pwgnam} = (1,1);
123 print "# pwgid = $pwgid, pwgnam = $pwgnam\n";
125 for (split(' ', $()) {
127 ($group) = getgrgid($_);
128 if (defined $group) {
136 print "# gr = @gr\n";
138 if ($^O =~ /^(?:uwin|solaris)$/) {
139 # Or anybody else who can have spaces in group names.
140 $gr1 = join(' ', grep(!$did{$_}++, sort split(' ', join(' ', @gr))));
142 $gr1 = join(' ', sort @gr);
145 $gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups)));
147 if ($gr1 eq $gr2 || ($gr1 eq '' && $gr2 eq $pwgid)) {
151 print "#gr1 is <$gr1>\n";
152 print "#gr2 is <$gr2>\n";
156 # multiple 0's indicate GROUPSTYPE is currently long but should be short
158 if ($pwgid == 0 || $seen{0} < 2) {
162 print "not ok 2 (groupstype should be type short, not long)\n";