1#!./perl 2BEGIN { 3 if ( $^O eq 'VMS' ) { 4 my $p = "/bin:/usr/bin:/usr/xpg4/bin:/usr/ucb"; 5 if ( $ENV{PATH} ) { 6 $p .= ":$ENV{PATH}"; 7 } 8 $ENV{PATH} = $p; 9 } 10 $ENV{LC_ALL} = "C"; # so that external utilities speak English 11 $ENV{LANGUAGE} = 'C'; # GNU locale extension 12 13 chdir 't' if -d 't'; 14 require './test.pl'; 15 set_up_inc( '../lib' ); 16 skip_all_if_miniperl("no dynamic loading on miniperl, no POSIX"); 17} 18 19use 5.010; 20use strict; 21use Config (); 22use POSIX (); 23 24skip_all('getgrgid() not implemented') 25 unless eval { my($foo) = getgrgid(0); 1 }; 26 27skip_all("No 'id' or 'groups'") if 28 $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS' || $^O =~ /lynxos/i; 29 30Test(); 31exit; 32 33 34 35sub Test { 36 37 # Get our supplementary groups from the system by running commands 38 # like `id -a'. 39 my ( $groups_command, $groups_string ) = system_groups() 40 or skip_all("No 'id' or 'groups'"); 41 my @extracted_groups = extract_system_groups( $groups_string ) 42 or skip_all("Can't parse '${groups_command}'"); 43 44 my $pwgid = $( + 0; 45 my ($pwgnam) = getgrgid($pwgid); 46 $pwgnam //= ''; 47 note "pwgid=$pwgid pwgnam=$pwgnam \$(=$("; 48 49 # Get perl's supplementary groups by looking at $( 50 my ( $gid_count, $all_perl_groups ) = perl_groups(); 51 my %basegroup = basegroups( $pwgid, $pwgnam ); 52 my @extracted_supplementary_groups = remove_basegroup( \ %basegroup, \ @extracted_groups ); 53 54 plan 3; 55 56 57 # Test: The supplementary groups in $( should match the 58 # getgroups(2) kernal API call. 59 # 60 SKIP: { 61 my $ngroups_max = posix_ngroups_max(); 62 if ( defined $ngroups_max && $ngroups_max < @extracted_groups ) { 63 # Some OSes (like darwin)but conceivably others might return 64 # more groups from `id -a' than can be handled by the 65 # kernel. On darwin, NGROUPS_MAX is 16 and 12 are taken up for 66 # the system already. 67 # 68 # There is more fall-out from this than just Perl's unit 69 # tests. You may be a member of a group according to Active 70 # Directory (or whatever) but the OS won't respect it because 71 # it's the 17th (or higher) group and there's no space to 72 # store your membership. 73 skip "Your platform's `$groups_command' is broken"; 74 } 75 76 if ( darwin() ) { 77 # darwin uses getgrouplist(3) or an Open Directory API within 78 # /usr/bin/id and /usr/bin/groups which while "nice" isn't 79 # accurate for this test. The hard, real, list of groups we're 80 # running in derives from getgroups(2) and is not dynamic but 81 # the Libc API getgrouplist(3) is. 82 # 83 # In practical terms, this meant that while `id -a' can be 84 # relied on in other OSes to purely use getgroups(2) and show 85 # us what's real, darwin will use getgrouplist(3) to show us 86 # what might be real if only we'd open a new console. 87 # 88 skip "darwin's `${groups_command}' can't be trusted"; 89 } 90 91 # Read $( but ignore any groups in $( that we failed to parse 92 # successfully out of the `id -a` mess. 93 # 94 my @perl_groups = remove_unparsed_entries( \ @extracted_groups, 95 \ @$all_perl_groups ); 96 my @supplementary_groups = remove_basegroup( \ %basegroup, 97 \ @perl_groups ); 98 99 my $ok1 = 0; 100 if ( match_groups( \ @supplementary_groups, 101 \ @extracted_supplementary_groups, 102 $pwgid ) ) { 103 $ok1 = 1; 104 } 105 elsif ( cygwin_nt() ) { 106 %basegroup = unixy_cygwin_basegroups(); 107 @extracted_supplementary_groups = remove_basegroup( \ %basegroup, \ @extracted_groups ); 108 109 if ( match_groups( \ @supplementary_groups, 110 \ @extracted_supplementary_groups, 111 $pwgid ) ) { 112 note "This Cygwin behaves like Unix (Win2k?)"; 113 $ok1 = 1; 114 } 115 } 116 117 ok $ok1, "perl's `\$(' agrees with `${groups_command}'"; 118 } 119 120 # multiple 0's indicate GROUPSTYPE is currently long but should be short 121 $gid_count->{0} //= 0; 122 ok 0 == $pwgid || $gid_count->{0} < 2, "groupstype should be type short, not long"; 123 124 SKIP: { 125 # try to add a group as supplementary group 126 my $root_uid = 0; 127 skip "uid!=0", 1 if $< != $root_uid and $> != $root_uid; 128 my @groups = split ' ', $); 129 my @sup_group; 130 setgrent; 131 while(my @ent = getgrent) { 132 next if grep { $_ == $ent[2] } @groups; 133 @sup_group = @ent; 134 last; 135 } 136 endgrent; 137 skip "No group found we could add as a supplementary group", 1 138 if (!@sup_group); 139 $) = "$) @sup_group[2]"; 140 my $ok = grep { $_ == $sup_group[2] } split ' ', $); 141 ok $ok, "Group `$sup_group[0]' added as supplementary group"; 142 } 143 144 return; 145} 146 147# Get the system groups and the command used to fetch them. 148# 149sub system_groups { 150 my ( $cmd, $groups_string ) = _system_groups(); 151 152 if ( $groups_string ) { 153 chomp $groups_string; 154 diag_variable( groups => $groups_string ); 155 } 156 157 return ( $cmd, $groups_string ); 158} 159 160# We have to find a command that prints all (effective 161# and real) group names (not ids). The known commands are: 162# groups 163# id -Gn 164# id -a 165# Beware 1: some systems do just 'id -G' even when 'id -Gn' is used. 166# Beware 2: id -Gn or id -a format might be id(name) or name(id). 167# Beware 3: the groups= might be anywhere in the id output. 168# Beware 4: groups can have spaces ('id -a' being the only defense against this) 169# Beware 5: id -a might not contain the groups= part. 170# 171# That is, we might meet the following: 172# 173# foo bar zot # accept 174# foo 22 42 bar zot # accept 175# 1 22 42 2 3 # reject 176# groups=(42),foo(1),bar(2),zot me(3) # parsed by $GROUP_RX1 177# groups=22,42,1(foo),2(bar),3(zot(me)) # parsed by $GROUP_RX2 178# 179# and the groups= might be after, before, or between uid=... and gid=... 180use constant GROUP_RX1 => qr/ 181 ^ 182 (?<gr_name>.+) 183 \( 184 (?<gid>\d+) 185 \) 186 $ 187/x; 188use constant GROUP_RX2 => qr/ 189 ^ 190 (?<gid>\d+) 191 \( 192 (?<gr_name>.+) 193 \) 194 $ 195/x; 196sub _system_groups { 197 my $cmd; 198 my $str; 199 200 # prefer 'id' over 'groups' (is this ever wrong anywhere?) 201 # and 'id -a' over 'id -Gn' (the former is good about spaces in group names) 202 203 $cmd = 'id -a 2>/dev/null || id 2>/dev/null'; 204 $str = `$cmd`; 205 if ( $str && $str =~ /groups=/ ) { 206 # $str is of the form: 207 # uid=39957(gsar) gid=22(users) groups=33536,39181,22(users),0(root),1067(dev) 208 # FreeBSD since 6.2 has a fake id -a: 209 # uid=1001(tobez) gid=20(staff) groups=20(staff), 0(wheel), 68(dialer) 210 # On AIX it's id 211 # 212 # Linux may also have a context= field 213 214 return ( $cmd, $str ); 215 } 216 217 $cmd = 'id -Gn 2>/dev/null'; 218 $str = `$cmd`; 219 if ( $str && $str !~ /^[\d\s]$/ ) { 220 # $str could be of the form: 221 # users 33536 39181 root dev 222 return ( $cmd, $str ); 223 } 224 225 $cmd = 'groups 2>/dev/null'; 226 $str = `$cmd`; 227 if ( $str ) { 228 # may not reflect all groups in some places, so do a sanity check 229 if (-d '/afs') { 230 print <<EOM; 231# These test results *may* be bogus, as you appear to have AFS, 232# and I can't find a working 'id' in your PATH (which I have set 233# to '$ENV{PATH}'). 234# 235# If these tests fail, report the particular incantation you use 236# on this platform to find *all* the groups that an arbitrary 237# user may belong to, using the issue tracker. 238EOM 239 } 240 return ( $cmd, $str ); 241 } 242 243 return (); 244} 245 246# Convert the strings produced by parsing `id -a' into a list of group 247# names 248sub extract_system_groups { 249 my ( $groups_string ) = @_; 250 251 # Remember that group names can contain whitespace, '-', '(parens)', 252 # et cetera. That is: do not \w, do not \S. 253 my @extracted; 254 255 my @fields = split /\b(\w+=)/, $groups_string; 256 my $gr; 257 for my $i (0..@fields-2) { 258 if ($fields[$i] eq 'groups=') { 259 $gr = $fields[$i+1]; 260 $gr =~ s/ $//; 261 last; 262 } 263 } 264 if (defined $gr) { 265 my @g = split m{, ?}, $gr; 266 # prefer names over numbers 267 for (@g) { 268 if ( $_ =~ GROUP_RX1() || $_ =~ GROUP_RX2() ) { 269 push @extracted, $+{gr_name} || $+{gid}; 270 } 271 else { 272 note "ignoring group entry [$_]"; 273 } 274 } 275 276 diag_variable( gr => $gr ); 277 diag_variable( g => join ',', @g ); 278 diag_variable( ex_gr => join ',', @extracted ); 279 } 280 281 return @extracted; 282} 283 284# Get the POSIX value NGROUPS_MAX. 285sub posix_ngroups_max { 286 return eval { 287 POSIX::NGROUPS_MAX(); 288 }; 289} 290 291# Test if this is Apple's darwin 292sub darwin { 293 # Observed 'darwin-2level' 294 return $Config::Config{myuname} =~ /^darwin/; 295} 296 297# Test if this is Cygwin 298sub cygwin_nt { 299 return $Config::Config{myuname} =~ /^cygwin_nt/i; 300} 301 302# Get perl's supplementary groups and the number of times each gid 303# appeared. 304sub perl_groups { 305 # Lookup perl's own groups from $( 306 my @gids = split ' ', $(; 307 my %gid_count; 308 my @gr_name; 309 for my $gid ( @gids ) { 310 ++ $gid_count{$gid}; 311 312 my ($group) = getgrgid $gid; 313 314 # Why does this test prefer to not test groups which we don't have 315 # a name for? One possible answer is that my primary group comes 316 # from from my entry in the user database but isn't mentioned in 317 # the group database. Are there more reasons? 318 next if ! defined $group; 319 320 321 push @gr_name, $group; 322 } 323 324 diag_variable( gr_name => join ',', @gr_name ); 325 326 return ( \ %gid_count, \ @gr_name ); 327} 328 329# Remove entries from our parsing of $( that don't appear in our 330# parsing of `id -a`. 331sub remove_unparsed_entries { 332 my ( $extracted_groups, $perl_groups ) = @_; 333 334 my %was_extracted = 335 map { $_ => 1 } 336 @$extracted_groups; 337 338 return 339 grep { $was_extracted{$_} } 340 @$perl_groups; 341} 342 343# Get a list of base groups. I'm not sure why cygwin by default is 344# skipped here. 345sub basegroups { 346 my ( $pwgid, $pwgnam ) = @_; 347 348 if ( cygwin_nt() ) { 349 return; 350 } 351 else { 352 return ( 353 $pwgid => 1, 354 $pwgnam => 1, 355 ); 356 } 357} 358 359# Cygwin might have another form of basegroup which we should actually use 360sub unixy_cygwin_basegroups { 361 my ( $pwgid, $pwgnam ) = @_; 362 return ( 363 $pwgid => 1, 364 $pwgnam => 1, 365 ); 366} 367 368# Filter a full list of groups and return only the supplementary 369# gorups. 370sub remove_basegroup { 371 my ( $basegroups, $groups ) = @_; 372 373 return 374 grep { ! $basegroups->{$_} } 375 @$groups; 376} 377 378# Test supplementary groups to see if they're a close enough match or 379# if there aren't any supplementary groups then validate the current 380# group against $(. 381sub match_groups { 382 my ( $supplementary_groups, $extracted_supplementary_groups, $pwgid ) = @_; 383 384 # Compare perl vs system groups 385 my %g; 386 $g{$_}[0] = 1 for @$supplementary_groups; 387 $g{$_}[1] = 1 for @$extracted_supplementary_groups; 388 389 # Find any mismatches 390 my @misses = 391 grep { ! ( $g{$_}[0] && $g{$_}[1] ) } 392 sort keys %g; 393 394 return 395 ! @misses 396 || ( ! @$supplementary_groups 397 && 1 == @$extracted_supplementary_groups 398 && $pwgid == $extracted_supplementary_groups->[0] ); 399} 400 401# Print a nice little diagnostic. 402sub diag_variable { 403 my ( $label, $content ) = @_; 404 405 printf "# %-11s=%s\n", $label, $content; 406 return; 407} 408 409# Removes duplicates from a list 410sub uniq { 411 my %seen; 412 return 413 grep { ! $seen{$_}++ } 414 @_; 415} 416 417# ex: set ts=8 sts=4 sw=4 et: 418