Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
64bitint.t	8.14 KB	-r--r--r--	2014-12-27 11:49
alarm.t	1.5 KB	-r--r--r--	2014-12-27 11:49
anonsub.t	1.7 KB	-r--r--r--	2014-12-27 11:49
append.t	1.58 KB	-r--r--r--	2014-12-27 11:49
args.t	2.12 KB	-r--r--r--	2014-12-27 11:49
array.t	12.32 KB	-r--r--r--	2014-12-27 11:49
array_base.t	720 B	-r--r--r--	2014-12-27 11:49
assignwarn.t	1.52 KB	-r--r--r--	2014-12-27 11:49
attrhand.t	1.01 KB	-r--r--r--	2014-12-27 11:49
attrproto.t	6.55 KB	-r--r--r--	2014-12-27 11:49
attrs.t	10.73 KB	-r--r--r--	2014-12-27 11:49
auto.t	2.36 KB	-r--r--r--	2014-12-27 11:49
avhv.t	4.04 KB	-r--r--r--	2014-12-27 11:49
bless.t	4.12 KB	-r--r--r--	2014-12-27 11:49
blocks.t	2.95 KB	-r--r--r--	2014-12-27 11:49
bop.t	12.82 KB	-r--r--r--	2014-12-27 11:49
caller.pl	3.75 KB	-r--r--r--	2014-12-27 11:49
caller.t	8.14 KB	-r--r--r--	2014-12-27 11:49
chars.t	1.73 KB	-r--r--r--	2014-12-27 11:49
chdir.t	6.68 KB	-r--r--r--	2014-12-27 11:49
chop.t	7.67 KB	-r--r--r--	2014-12-27 11:49
chr.t	2.48 KB	-r--r--r--	2014-12-27 11:49
closure.t	19.6 KB	-r--r--r--	2014-12-27 11:49
closure_test.pl	327 B	-r--r--r--	2014-12-27 11:49
concat2.t	1.41 KB	-r--r--r--	2014-12-27 11:49
cond.t	282 B	-r--r--r--	2014-12-27 11:49
context.t	404 B	-r--r--r--	2014-12-27 11:49
coreamp.t	29.17 KB	-r--r--r--	2014-12-27 11:49
coresubs.t	4.87 KB	-r--r--r--	2014-12-27 11:49
cproto.t	3.6 KB	-r--r--r--	2014-12-27 11:49
crypt.t	1.17 KB	-r--r--r--	2014-12-27 11:49
current_sub.t	1.71 KB	-r--r--r--	2014-12-27 11:49
dbm.t	1.54 KB	-r--r--r--	2014-12-27 11:49
defined.t	551 B	-r--r--r--	2014-12-27 11:49
defins.t	4.84 KB	-r--r--r--	2014-12-27 11:49
delete.t	2.93 KB	-r--r--r--	2014-12-27 11:49
die.t	1.99 KB	-r--r--r--	2014-12-27 11:49
die_except.t	1.57 KB	-r--r--r--	2014-12-27 11:49
die_exit.t	1.9 KB	-r--r--r--	2014-12-27 11:49
die_keeperr.t	1.57 KB	-r--r--r--	2014-12-27 11:49
die_unwind.t	1.69 KB	-r--r--r--	2014-12-27 11:49
do.t	8.35 KB	-r--r--r--	2014-12-27 11:49
dor.t	2.64 KB	-r--r--r--	2014-12-27 11:49
each.t	7.09 KB	-r--r--r--	2014-12-27 11:49
each_array.t	5.48 KB	-r--r--r--	2014-12-27 11:49
eval.t	13.92 KB	-r--r--r--	2014-12-27 11:49
evalbytes.t	989 B	-r--r--r--	2014-12-27 11:49
exec.t	4.36 KB	-r--r--r--	2014-12-27 11:49
exists_sub.t	2.09 KB	-r--r--r--	2014-12-27 11:49
exp.t	1.47 KB	-r--r--r--	2014-12-27 11:49
fh.t	790 B	-r--r--r--	2014-12-27 11:49
filehandle.t	564 B	-r--r--r--	2014-12-27 11:49
filetest.t	11.97 KB	-r--r--r--	2014-12-27 11:49
filetest_stack_ok.t	1.12 KB	-r--r--r--	2014-12-27 11:49
filetest_t.t	1.18 KB	-r--r--r--	2014-12-27 11:49
flip.t	868 B	-r--r--r--	2014-12-27 11:49
for.t	12.77 KB	-r--r--r--	2014-12-27 11:49
fork.t	8.8 KB	-r--r--r--	2014-12-27 11:49
fresh_perl_utf8.t	411 B	-r--r--r--	2014-12-27 11:49
getpid.t	1.61 KB	-r--r--r--	2014-12-27 11:49
getppid.t	3.13 KB	-r--r--r--	2014-12-27 11:49
glob.t	4.22 KB	-r--r--r--	2014-12-27 11:49
gmagic.t	5.97 KB	-r--r--r--	2014-12-27 11:49
goto.t	14.85 KB	-r--r--r--	2014-12-27 11:49
goto_xs.t	2.98 KB	-r--r--r--	2014-12-27 11:49
grent.t	4.46 KB	-r--r--r--	2014-12-27 11:49
grep.t	6.66 KB	-r--r--r--	2014-12-27 11:49
groups.t	11.15 KB	-r--r--r--	2014-12-27 11:49
gv.t	30.15 KB	-r--r--r--	2014-12-27 11:49
hash-rt85026.t	1.57 KB	-r--r--r--	2014-12-27 11:49
hash.t	6.02 KB	-r--r--r--	2014-12-27 11:49
hashassign.t	18.85 KB	-r--r--r--	2014-12-27 11:49
hashwarn.t	2.05 KB	-r--r--r--	2014-12-27 11:49
heredoc.t	2.29 KB	-r--r--r--	2014-12-27 11:49
inc.t	6.72 KB	-r--r--r--	2014-12-27 11:49
inccode-tie.t	338 B	-r--r--r--	2014-12-27 11:49
inccode.t	11.19 KB	-r--r--r--	2014-12-27 11:49
incfilter.t	7.33 KB	-r--r--r--	2014-12-27 11:49
index.t	6.81 KB	-r--r--r--	2014-12-27 11:49
index_thr.t	56 B	-r--r--r--	2014-12-27 11:49
int.t	1.72 KB	-r--r--r--	2014-12-27 11:49
join.t	3.2 KB	-r--r--r--	2014-12-27 11:49
kill0.t	3.18 KB	-r--r--r--	2014-12-27 11:49
kill0_child	596 B	-r--r--r--	2014-12-27 11:49
kvaslice.t	4.66 KB	-r--r--r--	2014-12-27 11:49
kvhslice.t	5.44 KB	-r--r--r--	2014-12-27 11:49
lc.t	11.8 KB	-r--r--r--	2014-12-27 11:49
leaky-magic.t	3.43 KB	-r--r--r--	2014-12-27 11:49
length.t	5.03 KB	-r--r--r--	2014-12-27 11:49
lex.t	2.33 KB	-r--r--r--	2014-12-27 11:49
lex_assign.t	7.17 KB	-r--r--r--	2014-12-27 11:49
lexsub.t	19.62 KB	-r--r--r--	2014-12-27 12:24
lfs.t	6.2 KB	-r--r--r--	2014-12-27 11:49
list.t	5.31 KB	-r--r--r--	2014-12-27 11:52
local.t	17.11 KB	-r--r--r--	2014-12-27 11:49
localref.t	2.73 KB	-r--r--r--	2014-12-27 11:49
lock.t	465 B	-r--r--r--	2014-12-27 11:49
loopctl.t	17.88 KB	-r--r--r--	2014-12-27 11:49
lop.t	1.2 KB	-r--r--r--	2014-12-27 11:49
magic-27839.t	622 B	-r--r--r--	2014-12-27 11:49
magic.t	21.81 KB	-r--r--r--	2014-12-27 11:49
method.t	18.91 KB	-r--r--r--	2014-12-27 11:49
mkdir.t	1.25 KB	-r--r--r--	2014-12-27 11:49
my.t	4.29 KB	-r--r--r--	2014-12-27 11:49
my_stash.t	769 B	-r--r--r--	2014-12-27 11:49
mydef.t	5.51 KB	-r--r--r--	2014-12-27 11:49
negate.t	4.3 KB	-r--r--r--	2014-12-27 11:49
not.t	3.15 KB	-r--r--r--	2014-12-27 11:49
numconvert.t	8.33 KB	-r--r--r--	2014-12-27 11:49
oct.t	3.58 KB	-r--r--r--	2014-12-27 11:49
or.t	1.79 KB	-r--r--r--	2014-12-27 11:49
ord.t	2.48 KB	-r--r--r--	2014-12-27 11:49
overload_integer.t	506 B	-r--r--r--	2014-12-27 11:49
override.t	4.33 KB	-r--r--r--	2014-12-27 11:49
pack.t	65.34 KB	-r--r--r--	2014-12-27 11:49
packagev.t	5.97 KB	-r--r--r--	2014-12-27 11:49
pos.t	3.59 KB	-r--r--r--	2014-12-27 11:49
postfixderef.t	11.97 KB	-r--r--r--	2014-12-27 11:49
pow.t	2.34 KB	-r--r--r--	2014-12-27 11:49
print.t	692 B	-r--r--r--	2014-12-27 11:49
protowarn.t	1.35 KB	-r--r--r--	2014-12-27 11:49
push.t	3.03 KB	-r--r--r--	2014-12-27 11:49
pwent.t	6.63 KB	-r--r--r--	2014-12-27 11:49
qr.t	2.32 KB	-r--r--r--	2014-12-27 11:49
quotemeta.t	5.61 KB	-r--r--r--	2014-12-27 11:49
rand.t	8.31 KB	-r--r--r--	2014-12-27 11:49
range.t	9.25 KB	-r--r--r--	2014-12-27 11:49
read.t	2.28 KB	-r--r--r--	2014-12-27 11:49
readdir.t	2.09 KB	-r--r--r--	2014-12-27 11:49
readline.t	7.19 KB	-r--r--r--	2014-12-27 11:49
recurse.t	2.73 KB	-r--r--r--	2014-12-27 11:49
ref.t	22.74 KB	-r--r--r--	2014-12-27 11:49
repeat.t	4.8 KB	-r--r--r--	2014-12-27 11:49
require_37033.t	1.18 KB	-r--r--r--	2014-12-27 11:49
require_errors.t	3.68 KB	-r--r--r--	2014-12-27 11:49
reset.t	5.41 KB	-r--r--r--	2014-12-27 11:49
reverse.t	3.01 KB	-r--r--r--	2014-12-27 11:49
rt119311.t	5.58 KB	-r--r--r--	2014-12-27 11:49
runlevel.t	5.28 KB	-r--r--r--	2014-12-27 11:49
select.t	1.03 KB	-r--r--r--	2014-12-27 11:49
setpgrpstack.t	378 B	-r--r--r--	2014-12-27 11:49
sigdispatch.t	4.33 KB	-r--r--r--	2014-12-27 11:49
signatures.t	41.02 KB	-r--r--r--	2014-12-27 11:49
sigsystem.t	1.36 KB	-r--r--r--	2014-12-27 11:49
sleep.t	468 B	-r--r--r--	2014-12-27 11:49
smartkve.t	18.26 KB	-r--r--r--	2014-12-27 11:49
smartmatch.t	10.34 KB	-r--r--r--	2014-12-27 11:49
sort.t	28.4 KB	-r--r--r--	2015-01-10 13:17
splice.t	3.38 KB	-r--r--r--	2014-12-27 11:49
split.t	13.1 KB	-r--r--r--	2014-12-27 11:49
split_unicode.t	2.4 KB	-r--r--r--	2014-12-27 11:49
sprintf.t	28.5 KB	-r--r--r--	2014-12-27 11:49
sprintf2.t	5.49 KB	-r--r--r--	2014-12-27 11:49
srand.t	1.87 KB	-r--r--r--	2014-12-27 11:49
sselect.t	2.67 KB	-r--r--r--	2014-12-27 11:49
stash.t	9.01 KB	-r--r--r--	2014-12-27 11:49
stat.t	17.51 KB	-r--r--r--	2014-12-27 11:49
state.t	9.72 KB	-r--r--r--	2014-12-27 12:15
study.t	2.99 KB	-r--r--r--	2014-12-27 11:49
studytied.t	1.29 KB	-r--r--r--	2014-12-27 11:49
sub.t	6.54 KB	-r--r--r--	2014-12-27 11:49
sub_lval.t	24.2 KB	-r--r--r--	2014-12-27 11:49
substr.t	20.53 KB	-r--r--r--	2014-12-27 11:49
substr_thr.t	56 B	-r--r--r--	2014-12-27 11:49
svleak.pl	6 B	-r--r--r--	2014-12-27 11:49
svleak.t	15.93 KB	-r--r--r--	2015-01-10 12:06
switch.t	28.06 KB	-r--r--r--	2014-12-27 11:49
symbolcache.t	1.06 KB	-r--r--r--	2014-12-27 11:49
sysio.t	5 KB	-r--r--r--	2014-12-27 11:49
taint.t	66.84 KB	-r--r--r--	2014-12-27 12:32
threads-dirh.t	3.47 KB	-r--r--r--	2014-12-27 11:49
threads.t	9.3 KB	-r--r--r--	2014-12-27 11:49
threads_create.pl	42 B	-r--r--r--	2014-12-27 11:49
tie.t	28.34 KB	-r--r--r--	2014-12-27 11:49
tie_fetch_count.t	11.49 KB	-r--r--r--	2014-12-27 11:49
tiearray.t	4.53 KB	-r--r--r--	2014-12-27 11:49
tiehandle.t	5.27 KB	-r--r--r--	2014-12-27 11:49
time.t	7.86 KB	-r--r--r--	2015-01-17 11:51
time_loop.t	378 B	-r--r--r--	2014-12-27 11:49
tr.t	12.99 KB	-r--r--r--	2014-12-27 11:49
undef.t	3.15 KB	-r--r--r--	2014-12-27 11:49
universal.t	8.32 KB	-r--r--r--	2014-12-27 11:49
unlink.t	1.02 KB	-r--r--r--	2014-12-27 11:49
unshift.t	3.17 KB	-r--r--r--	2014-12-27 11:49
upgrade.t	1.15 KB	-r--r--r--	2014-12-27 11:49
utf8cache.t	3.83 KB	-r--r--r--	2014-12-27 11:49
utf8decode.t	7.59 KB	-r--r--r--	2014-12-27 11:49
utf8magic.t	808 B	-r--r--r--	2014-12-27 11:49
utfhash.t	5.33 KB	-r--r--r--	2014-12-27 11:49
utftaint.t	4.46 KB	-r--r--r--	2014-12-27 11:49
vec.t	2.87 KB	-r--r--r--	2014-12-27 11:49
ver.t	8.39 KB	-r--r--r--	2014-12-27 11:49
waitpid.t	973 B	-r--r--r--	2014-12-27 11:49
wantarray.t	874 B	-r--r--r--	2014-12-27 11:49
warn.t	4.15 KB	-r--r--r--	2014-12-27 11:49
while.t	3.81 KB	-r--r--r--	2014-12-27 11:49
write.t	39.99 KB	-r--r--r--	2015-01-24 15:03
yadayada.t	1.67 KB	-r--r--r--	2015-01-15 22:12

Rename

#!./perl
BEGIN {
    if ( $^O eq 'VMS' ) {
        my $p = "/bin:/usr/bin:/usr/xpg4/bin:/usr/ucb";
        if ( $ENV{PATH} ) {
            $p .= ":$ENV{PATH}";
        }
        $ENV{PATH} = $p;
    }
    $ENV{LC_ALL} = "C"; # so that external utilities speak English
    $ENV{LANGUAGE} = 'C'; # GNU locale extension

chdir 't';
    @INC = '../lib';
    require './test.pl';
    skip_all_if_miniperl("no dynamic loading on miniperl, no POSIX");
}
use 5.010;
use strict;
use Config ();
use POSIX ();

skip_all('getgrgid() not implemented')
    unless eval { my($foo) = getgrgid(0); 1 };

skip_all("No 'id' or 'groups'") if
    $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS' || $^O =~ /lynxos/i;

Test();
exit;

sub Test {

# Get our supplementary groups from the system by running commands
    # like `id -a'.
    my ( $groups_command, $groups_string ) = system_groups()
        or skip_all("No 'id' or 'groups'");
    my @extracted_groups = extract_system_groups( $groups_string )
        or skip_all("Can't parse '${groups_command}'");

my $pwgid = $( + 0;
    my ($pwgnam) = getgrgid($pwgid);
    $pwgnam //= '';
    print "# pwgid=$pwgid pwgnam=$pwgnam \$(=$(\n";

# Get perl's supplementary groups by looking at $(
    my ( $gid_count, $all_perl_groups ) = perl_groups();
    my %basegroup = basegroups( $pwgid, $pwgnam );
    my @extracted_supplementary_groups = remove_basegroup( \ %basegroup, \ @extracted_groups );

print "1..2\n";

# Test: The supplementary groups in $( should match the
    # getgroups(2) kernal API call.
    #
    my $ngroups_max = posix_ngroups_max();
    if ( defined $ngroups_max && $ngroups_max < @extracted_groups ) {
        # Some OSes (like darwin)but conceivably others might return
        # more groups from `id -a' than can be handled by the
        # kernel. On darwin, NGROUPS_MAX is 16 and 12 are taken up for
        # the system already.
        #
        # There is more fall-out from this than just Perl's unit
        # tests. You may be a member of a group according to Active
        # Directory (or whatever) but the OS won't respect it because
        # it's the 17th (or higher) group and there's no space to
        # store your membership.
        print "ok 1 # SKIP Your platform's `$groups_command' is broken\n";
    }

elsif ( darwin() ) {
        # darwin uses getgrouplist(3) or an Open Directory API within
        # /usr/bin/id and /usr/bin/groups which while "nice" isn't
        # accurate for this test. The hard, real, list of groups we're
        # running in derives from getgroups(2) and is not dynamic but
        # the Libc API getgrouplist(3) is.
        #
        # In practical terms, this meant that while `id -a' can be
        # relied on in other OSes to purely use getgroups(2) and show
        # us what's real, darwin will use getgrouplist(3) to show us
        # what might be real if only we'd open a new console.
        #
        print "ok 1 # SKIP darwin's `${groups_command}' can't be trusted\n";
    }

else {

# Read $( but ignore any groups in $( that we failed to parse
        # successfully out of the `id -a` mess.
        #
        my @perl_groups = remove_unparsed_entries( \ @extracted_groups,
                                                   \ @$all_perl_groups );
        my @supplementary_groups = remove_basegroup( \ %basegroup,
                                                     \ @perl_groups );

my $ok1 = 0;
        if ( match_groups( \ @supplementary_groups,
                           \ @extracted_supplementary_groups,
                           $pwgid ) ) {
            print "ok 1\n";
            $ok1 = 1;
        }
        elsif ( cygwin_nt() ) {
            %basegroup = unixy_cygwin_basegroups();
            @extracted_supplementary_groups = remove_basegroup( \ %basegroup, \ @extracted_groups );

if ( match_groups( \ @supplementary_groups,
                               \ @extracted_supplementary_groups,
                               $pwgid ) ) {
                print "ok 1 # This Cygwin behaves like Unix (Win2k?)\n";
                $ok1 = 1;
            }
        }

unless ( $ok1 ) {

}
    }

# multiple 0's indicate GROUPSTYPE is currently long but should be short
    $gid_count->{0} //= 0;
    if ( 0 == $pwgid || $gid_count->{0} < 2 ) {
        print "ok 2\n";
    }
    else {
        print "not ok 2 (groupstype should be type short, not long)\n";
    }

return;
}

# Get the system groups and the command used to fetch them.
#
sub system_groups {
    my ( $cmd, $groups_string ) = _system_groups();

if ( $groups_string ) {
        chomp $groups_string;
        diag_variable( groups => $groups_string );
    }

return ( $cmd, $groups_string );
}

# 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)	# parsed by $GROUP_RX1
# groups=22,42,1(foo),2(bar),3(zot(me))	# parsed by $GROUP_RX2
#
# and the groups= might be after, before, or between uid=... and gid=...
use constant GROUP_RX1 => qr/
    ^
    (?<gr_name>.+)
    $
        (?<gid>\d+)
    $
    $
/x;
use constant GROUP_RX2 => qr/
    ^
    (?<gid>\d+)
    $
        (?<gr_name>.+)
    $
    $
/x;
sub _system_groups {
    my $cmd;
    my $str;

# prefer 'id' over 'groups' (is this ever wrong anywhere?)
    # and 'id -a' over 'id -Gn' (the former is good about spaces in group names)

$cmd = 'id -a 2>/dev/null || id 2>/dev/null';
    $str = `$cmd`;
    if ( $str && $str =~ /groups=/ ) {
        # $str is of the form:
        # uid=39957(gsar) gid=22(users) groups=33536,39181,22(users),0(root),1067(dev)
        # FreeBSD since 6.2 has a fake id -a:
        # uid=1001(tobez) gid=20(staff) groups=20(staff), 0(wheel), 68(dialer)
        # On AIX it's id
        #
        # Linux may also have a context= field

return ( $cmd, $str );
    }

$cmd = 'id -Gn 2>/dev/null';
    $str = `$cmd`;
    if ( $str && $str !~ /^[\d\s]$/ ) {
        # $str could be of the form:
        # users 33536 39181 root dev
        return ( $cmd, $str );
    }

$cmd = 'groups 2>/dev/null';
    $str = `$cmd`;
    if ( $str ) {
        # may not reflect all groups in some places, so do a sanity check
        if (-d '/afs') {
            print <<EOM;
# These test results *may* be bogus, as you appear to have AFS,
# and I can't find a working 'id' in your PATH (which I have set
# to '$ENV{PATH}').
#
# If these tests fail, report the particular incantation you use
# on this platform to find *all* the groups that an arbitrary
# user may belong to, using the 'perlbug' program.
EOM
        }
        return ( $cmd, $str );
    }

return ();
}

# Convert the strings produced by parsing `id -a' into a list of group
# names
sub extract_system_groups {
    my ( $groups_string ) = @_;

# Remember that group names can contain whitespace, '-', '(parens)',
    # et cetera. That is: do not \w, do not \S.
    my @extracted;

my @fields = split /\b(\w+=)/, $groups_string;
    my $gr;
    for my $i (0..@fields-2) {
        if ($fields[$i] eq 'groups=') {
            $gr = $fields[$i+1];
            $gr =~ s/ $//;
            last;
        }
    }
    if (defined $gr) {
        my @g = split m{, ?}, $gr;
        # prefer names over numbers
        for (@g) {
            if ( $_ =~ GROUP_RX1() || $_ =~ GROUP_RX2() ) {
                push @extracted, $+{gr_name} || $+{gid};
            }
            else {
                print "# ignoring group entry [$_]\n";
            }
        }

diag_variable( gr => $gr );
        diag_variable( g => join ',', @g );
        diag_variable( ex_gr => join ',', @extracted );
    }

return @extracted;
}

# Get the POSIX value NGROUPS_MAX.
sub posix_ngroups_max {
    return eval {
        POSIX::NGROUPS_MAX();
    };
}

# Test if this is Apple's darwin
sub darwin {
    # Observed 'darwin-2level'
    return $Config::Config{myuname} =~ /^darwin/;
}

# Test if this is Cygwin
sub cygwin_nt {
    return $Config::Config{myuname} =~ /^cygwin_nt/i;
}

# Get perl's supplementary groups and the number of times each gid
# appeared.
sub perl_groups {
    # Lookup perl's own groups from $(
    my @gids = split ' ', $(;
    my %gid_count;
    my @gr_name;
    for my $gid ( @gids ) {
        ++ $gid_count{$gid};

my ($group) = getgrgid $gid;

# Why does this test prefer to not test groups which we don't have
        # a name for? One possible answer is that my primary group comes
        # from from my entry in the user database but isn't mentioned in
        # the group database.  Are there more reasons?
        next if ! defined $group;

push @gr_name, $group;
    }

diag_variable( gr_name => join ',', @gr_name );

return ( \ %gid_count, \ @gr_name );
}

# Remove entries from our parsing of $( that don't appear in our
# parsing of `id -a`.
sub remove_unparsed_entries {
    my ( $extracted_groups, $perl_groups ) = @_;

my %was_extracted =
        map { $_ => 1 }
        @$extracted_groups;

return
        grep { $was_extracted{$_} }
        @$perl_groups;
}

# Get a list of base groups. I'm not sure why cygwin by default is
# skipped here.
sub basegroups {
    my ( $pwgid, $pwgnam ) = @_;

if ( cygwin_nt() ) {
        return;
    }
    else {
        return (
            $pwgid  => 1,
            $pwgnam => 1,
        );
    }
}

# Cygwin might have another form of basegroup which we should actually use
sub unixy_cygwin_basegroups {
    my ( $pwgid, $pwgnam ) = @_;
    return (
        $pwgid  => 1,
        $pwgnam => 1,
    );
}

# Filter a full list of groups and return only the supplementary
# gorups.
sub remove_basegroup {
    my ( $basegroups, $groups ) = @_;

return
        grep { ! $basegroups->{$_} }
        @$groups;
}

# Test supplementary groups to see if they're a close enough match or
# if there aren't any supplementary groups then validate the current
# group against $(.
sub match_groups {
    my ( $supplementary_groups, $extracted_supplementary_groups, $pwgid ) = @_;

# Compare perl vs system groups
    my %g;
    $g{$_}[0] = 1 for @$supplementary_groups;
    $g{$_}[1] = 1 for @$extracted_supplementary_groups;

# Find any mismatches
    my @misses =
        grep { ! ( $g{$_}[0] && $g{$_}[1] ) }
        sort keys %g;

return
        ! @misses
        || ( ! @$supplementary_groups
             && 1 == @$extracted_supplementary_groups
             && $pwgid == $extracted_supplementary_groups->[0] );
}

# Print a nice little diagnostic.
sub diag_variable {
    my ( $label, $content ) = @_;

printf "# %-11s=%s\n", $label, $content;
    return;
}

# Removes duplicates from a list
sub uniq {
    my %seen;
    return
        grep { ! $seen{$_}++ }
        @_;
}

# Local variables:
# indent-tabs-mode: nil
# End:
#
# ex: set ts=8 sts=4 sw=4 et: