1#!./perl 2 3$ENV{PATH} ="/bin:/usr/bin:/usr/xpg4/bin:/usr/ucb" . 4 exists $ENV{PATH} ? ":$ENV{PATH}" : "" unless $^O eq 'VMS'; 5$ENV{LC_ALL} = "C"; # so that external utilities speak English 6$ENV{LANGUAGE} = 'C'; # GNU locale extension 7 8BEGIN { 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 20sub quit { 21 print "1..0 # Skip: no `id` or `groups`\n"; 22 exit 0; 23} 24 25unless (eval { getgrgid(0); 1 }) { 26 print "1..0 # Skip: getgrgid() not implemented\n"; 27 exit 0; 28} 29 30quit() if (($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') 31 or $^O =~ /lynxos/i); 32 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. 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. 41# Beware 4: groups can have spaces ('id -a' being the only defense against this) 42# Beware 5: id -a might not contain the groups= part. 43# 44# That is, we might meet the following: 45# 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 51# 52# and the groups= might be after, before, or between uid=... and gid=... 53 54GROUPS: { 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) 60 # FreeBSD since 6.2 has a fake id -a: 61 # uid=1001(tobez) gid=20(staff) groups=20(staff), 0(wheel), 68(dialer) 62 last GROUPS if $groups =~ /groups=/; 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)+$/; 68 } 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 79# user may belong to, using the 'perlbug' program. 80EOM 81 } 82 last GROUPS; 83 } 84 # Okay, not today. 85 quit(); 86} 87 88chomp($groups); 89 90print "# groups = $groups\n"; 91 92# Remember that group names can contain whitespace, '-', et cetera. 93# That is: do not \w, do not \S. 94if ($groups =~ /groups=(.+)( [ug]id=|$)/) { 95 my $gr = $1; 96 my @g0 = split /, ?/, $gr; 97 my @g1; 98 # prefer names over numbers 99 for (@g0) { 100 # 42(zot me) 101 if (/^(\d+)(?:\(([^)]+)\))?/) { 102 push @g1, ($2 || $1); 103 } 104 # zot me(42) 105 elsif (/^([^(]*)\((\d+)\)/) { 106 push @g1, ($1 || $2); 107 } 108 else { 109 print "# ignoring group entry [$_]\n"; 110 } 111 } 112 print "# groups=$gr\n"; 113 print "# g0 = @g0\n"; 114 print "# g1 = @g1\n"; 115 $groups = "@g1"; 116} 117 118print "1..2\n"; 119 120$pwgid = $( + 0; 121($pwgnam) = getgrgid($pwgid); 122$seen{$pwgid}++; 123 124print "# pwgid = $pwgid, pwgnam = $pwgnam\n"; 125 126for (split(' ', $()) { 127 ($group) = getgrgid($_); 128 next if (! defined $group or ! grep { $_ eq $group } @gr) and $seen{$_}++; 129 if (defined $group) { 130 push(@gr, $group); 131 } 132 else { 133 push(@gr, $_); 134 } 135} 136 137print "# gr = @gr\n"; 138 139my %did; 140if ($^O =~ /^(?:uwin|cygwin|interix|solaris|linux)$/) { 141 # Or anybody else who can have spaces in group names. 142 $gr1 = join(' ', grep(!$did{$_}++, sort split(' ', join(' ', @gr)))); 143} else { 144 # Don't assume that there aren't duplicate groups 145 $gr1 = join(' ', sort grep defined $_ && !$did{$_}++, @gr); 146} 147 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} 153$gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups))); 154 155my $ok1 = 0; 156if ($gr1 eq $gr2 || ($gr1 eq '' && $gr2 eq $pwgid)) { 157 print "ok 1\n"; 158 $ok1++; 159} 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) { 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} 183