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