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