devdaily home | apple | java | perl | unix | directory | blog

What this is

This file is included in the DevDaily.com "Perl Source Code Warehouse" project. The intent of this project is to help you "Learn Perl by Example" TM.

Other links

The source code

#!./perl

$ENV{PATH} ="/bin:/usr/bin:/usr/xpg4/bin:/usr/ucb" .
    exists $ENV{PATH} ? ":$ENV{PATH}" : "";
$ENV{LC_ALL} = "C"; # so that external utilities speak English
$ENV{LANGUAGE} = 'C'; # GNU locale extension

BEGIN {
    chdir 't';
    @INC = '../lib';

    require Config;
    if ($@) {
	print "1..0 # Skip: no Config\n";
    } else {
	Config->import;
    }
}

sub quit {
    print "1..0 # Skip: no `id` or `groups`\n";
    exit 0;
}

unless (eval { getgrgid(0); 1 }) {
    print "1..0 # Skip: getgrgid() not implemented\n";
    exit 0;
}

quit() if (($^O eq 'MSWin32' || $^O eq 'NetWare') or $^O =~ /lynxos/i);

# We have to find a command that prints all (effective
# and real) group names (not ids).  The known commands are:
# groups
# id -Gn
# id -a
# Beware 1: some systems do just 'id -G' even when 'id -Gn' is used.
# Beware 2: id -Gn or id -a format might be id(name) or name(id).
# Beware 3: the groups= might be anywhere in the id output.
# Beware 4: groups can have spaces ('id -a' being the only defense against this)
# Beware 5: id -a might not contain the groups= part.
#
# That is, we might meet the following:
#
# foo bar zot				# accept
# foo 22 42 bar zot			# accept
# 1 22 42 2 3				# reject
# groups=(42),foo(1),bar(2),zot me(3)	# parse
# groups=22,42,1(foo),2(bar),3(zot me)	# parse
#
# and the groups= might be after, before, or between uid=... and gid=...

GROUPS: {
    # prefer 'id' over 'groups' (is this ever wrong anywhere?)
    # and 'id -a' over 'id -Gn' (the former is good about spaces in group names)
    if (($groups = `id -a 2>/dev/null`) ne '') {
	# $groups is of the form:
	# uid=39957(gsar) gid=22(users) groups=33536,39181,22(users),0(root),1067(dev)
	last GROUPS if $groups =~ /groups=/;
    }
    if (($groups = `id -Gn 2>/dev/null`) ne '') {
	# $groups could be of the form:
	# users 33536 39181 root dev
	last GROUPS if $groups !~ /^(\d|\s)+$/;
    }
    if (($groups = `groups 2>/dev/null`) ne '') {
	# may not reflect all groups in some places, so do a sanity check
	if (-d '/afs') {
	    print < 1, $pwgnam => 1 );
    $gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups)));
    if ($gr1 eq $gr2 || ($gr1 eq '' && $gr2 eq $pwgid)) {
	print "ok 1 # This Cygwin behaves like Unix (Win2k?)\n";
	$ok1++;
    }
}
unless ($ok1) {
    print "#gr1 is <$gr1>\n";
    print "#gr2 is <$gr2>\n";
    print "not ok 1\n";
}

# multiple 0's indicate GROUPSTYPE is currently long but should be short

if ($pwgid == 0 || $seen{0} < 2) {
    print "ok 2\n";
}
else {
    print "not ok 2 (groupstype should be type short, not long)\n";
}




Copyright 1998-2008 Alvin Alexander
All Rights Reserved.
 
devdaily.com is based in louisville, kentucky, and this web site is hosted by godaddy.com