diff options
Diffstat (limited to 't')
| -rwxr-xr-x | t/op/groups.t | 72 | ||||
| -rwxr-xr-x | t/op/sort.t | 29 | ||||
| -rwxr-xr-x | t/pragma/overload.t | 4 | ||||
| -rw-r--r-- | t/pragma/warn/pp_ctl | 18 | ||||
| -rw-r--r-- | t/pragma/warn/toke | 12 |
5 files changed, 102 insertions, 33 deletions
diff --git a/t/op/groups.t b/t/op/groups.t index 6f7f8c478c..78a748fddd 100755 --- a/t/op/groups.t +++ b/t/op/groups.t @@ -1,6 +1,6 @@ #!./perl -$ENV{PATH} = '/usr/xpg4/bin:/bin:/usr/bin:/usr/ucb'; +$ENV{PATH} = '/bin:/usr/bin:/usr/xpg4/bin:/usr/ucb'; # We have to find a command that prints all (effective # and real) group names (not ids). The known commands are: @@ -10,23 +10,44 @@ $ENV{PATH} = '/usr/xpg4/bin:/bin:/usr/bin:/usr/ucb'; # 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) # # That is, we might meet the following: # -# foo bar zot # accept -# 1 2 3 # reject -# groups=foo(1),bar(2),zot(3) # parse -# groups=1(foo),2(bar),3(zot) # parse +# 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: { - last GROUPS if ($groups = `groups 2>/dev/null`) ne ''; - if ($groups = `id -Gn 2>/dev/null` ne '') { - last GROUPS unless $groups =~ /^(\d+)(\s+\d)*$/; + # 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 = `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 = `id -a 2>/dev/null` ne '') { - # Grok format soon. + if (($groups = `groups 2>/dev/null`) ne '') { + # 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 +# luser may belong to, using the 'perlbug' program. +EOM + } last GROUPS; } # Okay, not today. @@ -36,21 +57,28 @@ GROUPS: { # Remember that group names can contain whitespace, '-', et cetera. # That is: do not \w, do not \S. -if ($groups =~ /groups=((.+?\(.+?\))(,.+?\(.+?\))*)( [ug]id=|$)/) { +if ($groups =~ /groups=(.+)( [ug]id=|$)/) { my $gr = $1; - my @g0 = $gr =~ /(.+?)\((.+?)\),?/g; - my @g1 = @g0[ map { $_ * 2 } 0..$#g0/2 ]; - my @g2 = @g0[ map { $_ * 2 + 1 } 0..$#g0/2 ]; + my @g0 = split /,/, $gr; + my @g1; + # prefer names over numbers + for (@g0) { + # 42(zot me) + if (/^(\d+)(?:\(([^)]+)\))?$/) { + push @g1, ($2 || $1); + } + # zot me(42) + elsif (/^([^(]*)\((\d+)\)$/) { + push @g1, ($1 || $2); + } + else { + print "# ignoring group entry [$_]\n"; + } + } + print "# groups=$gr\n"; print "# g0 = @g0\n"; print "# g1 = @g1\n"; - print "# g2 = @g2\n"; - if (grep /\D/, @g1) { - $groups = join(" ", @g1); - } elsif (grep /\D/, @g2) { - $groups = join(" ", @g2); - } else { - # Let's fail. We want to parse the output. Really. - } + $groups = "@g1"; } print "1..2\n"; diff --git a/t/op/sort.t b/t/op/sort.t index 70341b9106..aca99a629d 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: sort.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:24 $ - -print "1..21\n"; +print "1..27\n"; sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } @@ -125,3 +123,28 @@ eval <<'CODE'; my @result = sort 'one', 'two'; CODE print $@ ? "not ok 21\n# $@" : "ok 21\n"; + +{ + my $sortsub = \&backwards; + my $sortglob = *backwards; + my $sortname = 'backwards'; + @b = sort $sortsub 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 22\n" : "not ok 22 |@b|\n"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 23\n" : "not ok 23 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n"); +} + +{ + local $sortsub = \&backwards; + local $sortglob = *backwards; + local $sortname = 'backwards'; + @b = sort $sortsub 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 22 |@b|\n"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 23 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 24 |@b|\n"); +} + diff --git a/t/pragma/overload.t b/t/pragma/overload.t index da857715b3..c013a7cb36 100755 --- a/t/pragma/overload.t +++ b/t/pragma/overload.t @@ -778,8 +778,8 @@ test($c, "bareword"); # 135 test "@sorted", '22 11 5 2 1'; # 189 # Scalar test $$deref, 123; # 190 - # Glob - @sorted = sort $deref 11, 2, 5, 1, 22; + # Code + @sorted = sort $srt 11, 2, 5, 1, 22; test "@sorted", '22 11 5 2 1'; # 191 # Array test "@$deref", '11 12 13'; # 192 diff --git a/t/pragma/warn/pp_ctl b/t/pragma/warn/pp_ctl index e017d8a0a8..70c67fa598 100644 --- a/t/pragma/warn/pp_ctl +++ b/t/pragma/warn/pp_ctl @@ -53,6 +53,10 @@ goto &fred() + (in cleanup) foo bar + package Foo; + DESTROY { die "foo bar" } + { bless [], 'Foo' for 1..10 } __END__ # pp_ctl.c @@ -86,7 +90,7 @@ Exiting subroutine via last at - line 3. ######## # pp_ctl.c use warning 'unsafe' ; -{ eval "last" } +{ eval "last;" } print STDERR $@ ; EXPECT Exiting eval via last at (eval 1) line 1. @@ -119,10 +123,10 @@ Exiting subroutine via last at - line 3. ######## # pp_ctl.c use warning 'unsafe' ; -joe: { eval "last joe" } +joe: { eval "last joe;" } print STDERR $@ ; EXPECT -Exiting eval via last at (eval 1) line 2. +Exiting eval via last at (eval 1) line 1. ######## # pp_ctl.c use warning 'unsafe' ; @@ -143,3 +147,11 @@ sub fred goto &fred() EXPECT Deep recursion on subroutine "main::fred" at - line 6. +######## +# pp_ctl.c +use warning 'unsafe' ; +package Foo; +DESTROY { die "@{$_[0]} foo bar" } +{ bless ['A'], 'Foo' for 1..10 } +EXPECT + (in cleanup) A foo bar at - line 4. diff --git a/t/pragma/warn/toke b/t/pragma/warn/toke index 6cc4a500a4..da6c0dc9ae 100644 --- a/t/pragma/warn/toke +++ b/t/pragma/warn/toke @@ -290,9 +290,10 @@ Misplaced _ in number at - line 4. ######## # toke.c use warning 'unsafe' ; +#line 25 "bar" $a = FRED:: ; EXPECT -Bareword "FRED::" refers to nonexistent package at - line 3. +Bareword "FRED::" refers to nonexistent package at bar line 25. ######## # toke.c use warning 'ambiguous' ; @@ -303,9 +304,14 @@ Ambiguous call resolved as CORE::time(), qualify as such or use & at - line 4. ######## # toke.c use warning 'utf8' ; -$_ = " \x{123} " ; +eval <<'EOE'; +{ +#line 30 "foo" + $_ = " \x{123} " ; +} +EOE EXPECT -Use of \x{} without utf8 declaration at - line 3. +Use of \x{} without utf8 declaration at foo line 30. ######## # toke.c use warning 'utf8' ; |