dslinux/user/perl/t/op 64bitint.t alarm.t anonsub.t append.t args.t arith.t array.t assignwarn.t attrs.t auto.t avhv.t bless.t bop.t caller.t chars.t chdir.t chop.t chr.t closure.t cmp.t concat.t cond.t context.t cproto.t crypt.t defins.t delete.t die.t die_exit.t do.t each.t eval.t exec.t exists_sub.t exp.t fh.t filetest.t flip.t fork.t getpid.t getppid.t glob.t gmagic.t goto.t goto_xs.t grent.t grep.t groups.t gv.t hash.t hashassign.t hashwarn.t inc.t inccode.t index.t int.t join.t lc.t lc_user.t length.t lex_assign.t lfs.t list.t local.t localref.t loopctl.t lop.t magic.t method.t mkdir.t my.t my_stash.t negate.t not.t nothr5005.t numconvert.t oct.t or.t ord.t override.t pack.t pat.t pos.t pow.t push.t pwent.t qq.t quotemeta.t rand.t range.t re_tests read.t readdir.t readline.t recurse.t ref.t regexp.t regexp_noamp.t regmesg.t repeat.t reverse.t runlevel.t sleep.t sort.t splice.t split.t sprintf.t sprintf2.t srand.t sselect.t stash.t stat.t study.t sub.t sub_lval! .t subst.t subst_amp.t subst_wamp.t substr.t sysio.t taint.t threads.t tie.t tiearray.t tiehandle.t time.t tr.t undef.t universal.t unshift.t utf8decode.t utfhash.t utftaint.t vec.t ver.t wantarray.t write.t
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:02:10 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/t/op
In directory antilope:/tmp/cvs-serv17422/t/op
Added Files:
64bitint.t alarm.t anonsub.t append.t args.t arith.t array.t
assignwarn.t attrs.t auto.t avhv.t bless.t bop.t caller.t
chars.t chdir.t chop.t chr.t closure.t cmp.t concat.t cond.t
context.t cproto.t crypt.t defins.t delete.t die.t die_exit.t
do.t each.t eval.t exec.t exists_sub.t exp.t fh.t filetest.t
flip.t fork.t getpid.t getppid.t glob.t gmagic.t goto.t
goto_xs.t grent.t grep.t groups.t gv.t hash.t hashassign.t
hashwarn.t inc.t inccode.t index.t int.t join.t lc.t lc_user.t
length.t lex_assign.t lfs.t list.t local.t localref.t
loopctl.t lop.t magic.t method.t mkdir.t my.t my_stash.t
negate.t not.t nothr5005.t numconvert.t oct.t or.t ord.t
override.t pack.t pat.t pos.t pow.t push.t pwent.t qq.t
quotemeta.t rand.t range.t re_tests read.t readdir.t
readline.t recurse.t ref.t regexp.t regexp_noamp.t regmesg.t
repeat.t reverse.t runlevel.t sleep.t sort.t splice.t split.t
sprintf.t sprintf2.t srand.t sselect.t stash.t stat.t study.t
sub.t sub_lval.t subst.t subst_amp.t subst_wamp.t substr.t
sysio.t taint.t threads.t tie.t tiearray.t tiehandle.t time.t
tr.t undef.t universal.t unshift.t utf8decode.t utfhash.t
utftaint.t vec.t ver.t wantarray.t write.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: gv.t ---
#!./perl
#
# various typeglob tests
#
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use warnings;
require './test.pl';
plan( tests => 61 );
# type coersion on assignment
$foo = 'foo';
$bar = *main::foo;
$bar = $foo;
is(ref(\$bar), 'SCALAR');
$foo = *main::bar;
# type coersion (not) on misc ops
ok($foo);
is(ref(\$foo), 'GLOB');
unlike ($foo, qr/abcd/);
is(ref(\$foo), 'GLOB');
is($foo, '*main::bar');
is(ref(\$foo), 'GLOB');
# type coersion on substitutions that match
$a = *main::foo;
$b = $a;
$a =~ s/^X//;
is(ref(\$a), 'GLOB');
$a =~ s/^\*//;
is($a, 'main::foo');
is(ref(\$b), 'GLOB');
# typeglobs as lvalues
substr($foo, 0, 1) = "XXX";
is(ref(\$foo), 'SCALAR');
is($foo, 'XXXmain::bar');
# returning glob values
sub foo {
local($bar) = *main::foo;
$foo = *main::bar;
return ($foo, $bar);
}
($fuu, $baa) = foo();
ok(defined $fuu);
is(ref(\$fuu), 'GLOB');
ok(defined $baa);
is(ref(\$baa), 'GLOB');
# nested package globs
# NOTE: It's probably OK if these semantics change, because the
# fact that %X::Y:: is stored in %X:: isn't documented.
# (I hope.)
{ package Foo::Bar; no warnings 'once'; $test=1; }
ok(exists $Foo::{'Bar::'});
is($Foo::{'Bar::'}, '*Foo::Bar::');
# test undef operator clearing out entire glob
$foo = 'stuff';
@foo = qw(more stuff);
%foo = qw(even more random stuff);
undef *foo;
is ($foo, undef);
is (scalar @foo, 0);
is (scalar %foo, 0);
{
# test warnings from assignment of undef to glob
my $msg = '';
local $SIG{__WARN__} = sub { $msg = $_[0] };
use warnings;
*foo = 'bar';
is($msg, '');
*foo = undef;
like($msg, qr/Undefined value assigned to typeglob/);
}
my $test = curr_test();
# test *glob{THING} syntax
$x = "ok $test\n";
++$test;
@x = ("ok $test\n");
++$test;
%x = ("ok $test" => "\n");
++$test;
sub x { "ok $test\n" }
print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}};
# This needs to go here, after the print, as sub x will return the current
# value of test
++$test;
format x =
XXX This text isn't used. Should it be?
.
curr_test($test);
is (ref *x{FORMAT}, "FORMAT");
*x = *STDOUT;
is (*{*x{GLOB}}, "*main::STDOUT");
{
my $test = curr_test();
print {*x{IO}} "ok $test\n";
++$test;
my $warn;
local $SIG{__WARN__} = sub {
$warn .= $_[0];
};
my $val = *x{FILEHANDLE};
print {*x{IO}} ($warn =~ /is deprecated/
? "ok $test\n" : "not ok $test\n");
curr_test(++$test);
}
{
# test if defined() doesn't create any new symbols
my $a = "SYM000";
ok(!defined *{$a});
ok(!defined @{$a});
ok(!defined *{$a});
ok(!defined %{$a});
ok(!defined *{$a});
ok(!defined ${$a});
ok(!defined *{$a});
ok(!defined &{$a});
ok(!defined *{$a});
my $state = "not";
*{$a} = sub { $state = "ok" };
ok(defined &{$a});
ok(defined *{$a});
&{$a};
is ($state, 'ok');
}
{
# although it *should* if you're talking about magicals
my $a = "]";
ok(defined ${$a});
ok(defined *{$a});
$a = "1";
"o" =~ /(o)/;
ok(${$a});
ok(defined *{$a});
$a = "2";
ok(!${$a});
ok(defined *{$a});
$a = "1x";
ok(!defined ${$a});
ok(!defined *{$a});
$a = "11";
"o" =~ /(((((((((((o)))))))))))/;
ok(${$a});
ok(defined *{$a});
}
# [ID 20010526.001] localized glob loses value when assigned to
$j=1; %j=(a=>1); @j=(1); local *j=*j; *j = sub{};
is($j, 1);
is($j{a}, 1);
is($j[0], 1);
{
# does pp_readline() handle glob-ness correctly?
my $g = *foo;
$g = <DATA>;
is ($g, "Perl\n");
}
{
my $w = '';
$SIG{__WARN__} = sub { $w = $_[0] };
sub abc1 ();
local *abc1 = sub { };
is ($w, '');
sub abc2 ();
local *abc2;
*abc2 = sub { };
is ($w, '');
sub abc3 ();
*abc3 = sub { };
like ($w, qr/Prototype mismatch/);
}
{
# [17375] rcatline to formerly-defined undef was broken. Fixed in
# do_readline by checking SvOK. AMS, 20020918
my $x = "not ";
$x = undef;
$x .= <DATA>;
is ($x, "Rules\n");
}
__END__
Perl
Rules
--- NEW FILE: or.t ---
#!./perl
# Test || in weird situations.
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
package Countdown;
sub TIESCALAR {
my $class = shift;
my $instance = shift || undef;
return bless \$instance => $class;
}
sub FETCH {
print "# FETCH! ${$_[0]}\n";
return ${$_[0]}--;
}
package main;
require './test.pl';
plan( tests => 8 );
my ($a, $b, $c);
$! = 1;
$a = $!;
my $a_str = sprintf "%s", $a;
my $a_num = sprintf "%d", $a;
$c = $a || $b;
is($c, $a_str);
is($c+0, $a_num); # force numeric context.
$a =~ /./g or die "Match failed for some reason"; # Make $a magic
$c = $a || $b;
is($c, $a_str);
is($c+0, $a_num); # force numeric context.
my $val = 3;
$c = $val || $b;
is($c, 3);
tie $a, 'Countdown', $val;
$c = $a;
is($c, 3, 'Single FETCH on tied scalar');
$c = $a;
is($c, 2, ' $tied = $var');
$c = $a || $b;
{
local $TODO = 'Double FETCH';
is($c, 1, ' $tied || $var');
}
--- NEW FILE: my.t ---
#!./perl
# $RCSfile: my.t,v $
print "1..36\n";
sub foo {
my($a, $b) = @_;
my $c;
my $d;
$c = "ok 3\n";
$d = "ok 4\n";
{ my($a, undef, $c) = ("ok 9\n", "not ok 10\n", "ok 10\n");
($x, $y) = ($a, $c); }
print $a, $b;
$c . $d;
}
$a = "ok 5\n";
$b = "ok 6\n";
$c = "ok 7\n";
$d = "ok 8\n";
print &foo("ok 1\n","ok 2\n");
print $a,$b,$c,$d,$x,$y;
# same thing, only with arrays and associative arrays
sub foo2 {
my($a, @b) = @_;
my(@c, %d);
@c = "ok 13\n";
$d{''} = "ok 14\n";
{ my($a, at c) = ("ok 19\n", "ok 20\n"); ($x, $y) = ($a, @c); }
print $a, @b;
$c[0] . $d{''};
}
$a = "ok 15\n";
@b = "ok 16\n";
@c = "ok 17\n";
$d{''} = "ok 18\n";
print &foo2("ok 11\n","ok 12\n");
print $a, at b, at c,%d,$x,$y;
my $i = "outer";
if (my $i = "inner") {
print "not " if $i ne "inner";
}
print "ok 21\n";
if ((my $i = 1) == 0) {
print "not ";
}
else {
print "not" if $i != 1;
}
print "ok 22\n";
my $j = 5;
while (my $i = --$j) {
print("not "), last unless $i > 0;
}
continue {
print("not "), last unless $i > 0;
}
print "ok 23\n";
$j = 5;
for (my $i = 0; (my $k = $i) < $j; ++$i) {
print("not "), last unless $i >= 0 && $i < $j && $i == $k;
}
print "ok 24\n";
print "not " if defined $k;
print "ok 25\n";
foreach my $i (26, 27) {
print "ok $i\n";
}
print "not " if $i ne "outer";
print "ok 28\n";
# Ensure that C<my @y> (without parens) doesn't force scalar context.
my @x;
{ @x = my @y }
print +(@x ? "not " : ""), "ok 29\n";
{ @x = my %y }
print +(@x ? "not " : ""), "ok 30\n";
# Found in HTML::FormatPS
my %fonts = qw(nok 31);
for my $full (keys %fonts) {
$full =~ s/^n//;
# Supposed to be copy-on-write via force_normal after a THINKFIRST check.
print "$full $fonts{nok}\n";
}
# [perl #29340] optimising away the = () left the padav returning the
# array rather than the contents, leading to 'Bizarre copy of array' error
sub opta { my @a=() }
sub opth { my %h=() }
eval { my $x = opta };
print "not " if $@;
print "ok 32\n";
eval { my $x = opth };
print "not " if $@;
print "ok 33\n";
# my $foo = undef should always assign [perl #37776]
{
my $count = 34;
loop:
my $test = undef;
print "not " if defined $test;
print "ok $count\n";
$test = 42;
goto loop if ++$count < 37;
}
--- NEW FILE: concat.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
# This ok() function is specially written to avoid any concatenation.
my $test = 1;
sub ok {
my($ok, $name) = @_;
printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name;
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
$test++;
return $ok;
}
print "1..29\n";
($a, $b, $c) = qw(foo bar);
ok("$a" eq "foo", "verifying assign");
ok("$a$b" eq "foobar", "basic concatenation");
ok("$c$a$c" eq "foo", "concatenate undef, fore and aft");
# Okay, so that wasn't very challenging. Let's go Unicode.
{
# bug id 20000819.004
$_ = $dx = "\x{10f2}";
s/($dx)/$dx$1/;
{
ok($_ eq "$dx$dx","bug id 20000819.004, back");
}
$_ = $dx = "\x{10f2}";
s/($dx)/$1$dx/;
{
ok($_ eq "$dx$dx","bug id 20000819.004, front");
}
$dx = "\x{10f2}";
$_ = "\x{10f2}\x{10f2}";
s/($dx)($dx)/$1$2/;
{
ok($_ eq "$dx$dx","bug id 20000819.004, front and back");
}
}
{
# bug id 20000901.092
# test that undef left and right of utf8 results in a valid string
my $a;
$a .= "\x{1ff}";
ok($a eq "\x{1ff}", "bug id 20000901.092, undef left");
$a .= undef;
ok($a eq "\x{1ff}", "bug id 20000901.092, undef right");
}
{
# ID 20001020.006
"x" =~ /(.)/; # unset $2
# Without the fix this 5.7.0 would croak:
# Modification of a read-only value attempted at ...
eval {"$2\x{1234}"};
ok(!$@, "bug id 20001020.006, left");
# For symmetry with the above.
eval {"\x{1234}$2"};
ok(!$@, "bug id 20001020.006, right");
*pi = \undef;
# This bug existed earlier than the $2 bug, but is fixed with the same
# patch. Without the fix this 5.7.0 would also croak:
# Modification of a read-only value attempted at ...
eval{"$pi\x{1234}"};
ok(!$@, "bug id 20001020.006, constant left");
# For symmetry with the above.
eval{"\x{1234}$pi"};
ok(!$@, "bug id 20001020.006, constant right");
}
sub beq { use bytes; $_[0] eq $_[1]; }
{
# concat should not upgrade its arguments.
my($l, $r, $c);
($l, $r, $c) = ("\x{101}", "\x{fe}", "\x{101}\x{fe}");
ok(beq($l.$r, $c), "concat utf8 and byte");
ok(beq($l, "\x{101}"), "right not changed after concat u+b");
ok(beq($r, "\x{fe}"), "left not changed after concat u+b");
($l, $r, $c) = ("\x{fe}", "\x{101}", "\x{fe}\x{101}");
ok(beq($l.$r, $c), "concat byte and utf8");
ok(beq($l, "\x{fe}"), "right not changed after concat b+u");
ok(beq($r, "\x{101}"), "left not changed after concat b+u");
}
{
my $a; ($a .= 5) . 6;
ok($a == 5, '($a .= 5) . 6 - present since 5.000');
}
{
# [perl #24508] optree construction bug
sub strfoo { "x" }
my ($x, $y);
$y = ($x = '' . strfoo()) . "y";
ok( "$x,$y" eq "x,xy", 'figures out correct target' );
}
{
# [perl #26905] "use bytes" doesn't apply byte semantics to concatenation
my $p = "\xB6"; # PILCROW SIGN (ASCII/EBCDIC), 2bytes in UTF-X
my $u = "\x{100}";
my $b = pack 'a*', "\x{100}";
my $pu = "\xB6\x{100}";
my $up = "\x{100}\xB6";
my $x1 = $p;
my $y1 = $u;
use bytes;
ok(beq($p.$u, $p.$b), "perl #26905, left eq bytes");
ok(beq($u.$p, $b.$p), "perl #26905, right eq bytes");
ok(!beq($p.$u, $pu), "perl #26905, left ne unicode");
ok(!beq($u.$p, $up), "perl #26905, right ne unicode");
$x1 .= $u;
$x2 = $p . $u;
$y1 .= $p;
$y2 = $u . $p;
no bytes;
ok(beq($x1, $x2), "perl #26905, left, .= vs = . in bytes");
ok(beq($y1, $y2), "perl #26905, right, .= vs = . in bytes");
ok(($x1 eq $x2), "perl #26905, left, .= vs = . in chars");
ok(($y1 eq $y2), "perl #26905, right, .= vs = . in chars");
}
{
# Concatenation needs to preserve UTF8ness of left oper.
my $x = eval"qr/\x{fff}/";
ok( ord chop($x .= "\303\277") == 191, "UTF8ness preserved" );
}
--- NEW FILE: getppid.t ---
#!./perl
# Test that getppid() follows UNIX semantics: when the parent process
# dies, the child is reparented to the init process (pid 1).
BEGIN {
chdir 't' if -d 't';
@INC = qw(../lib);
}
use strict;
use Config;
BEGIN {
for my $syscall (qw(pipe fork waitpid getppid)) {
if (!$Config{"d_$syscall"}) {
print "1..0 # Skip: no $syscall\n";
exit;
}
}
print "1..3\n";
}
pipe my ($r, $w) or die "pipe: $!\n";
my $pid = fork; defined $pid or die "fork: $!\n";
if ($pid) {
# parent
close $w;
waitpid($pid, 0) == $pid or die "waitpid: $!\n";
print <$r>;
}
else {
# child
close $r;
my $pid2 = fork; defined $pid2 or die "fork: $!\n";
if ($pid2) {
close $w;
sleep 1;
}
else {
# grandchild
my $ppid1 = getppid();
print $w "not " if $ppid1 <= 1;
print $w "ok 1 # ppid1=$ppid1\n";
sleep 2;
my $ppid2 = getppid();
print $w "not " if $ppid1 == $ppid2;
print $w "ok 2 # ppid2=$ppid2, ppid1!=ppid2\n";
print $w "not " if $ppid2 != 1;
print $w "ok 3 # ppid2=1\n";
}
exit 0;
}
--- NEW FILE: assignwarn.t ---
#!./perl
#
# Verify which OP= operators warn if their targets are undefined.
# Based on redef.t, contributed by Graham Barr <Graham.Barr at tiuk.ti.com>
# -- Robin Barker <rmb at cise.npl.co.uk>
#
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
use strict;
use warnings;
my $warn = "";
$SIG{q(__WARN__)} = sub { print $warn; $warn .= join("", at _) };
sub uninitialized { $warn =~ s/Use of uninitialized value[^\n]+\n//s; }
sub tiex { tie $_[0], 'main' }
sub TIESCALAR { my $x; bless \$x }
sub FETCH { ${$_[0]} }
sub STORE { ${$_[0]} = $_[1] }
our $TODO;
print "1..63\n";
# go through all tests once normally and once with tied $x
for my $tie ("", ", tied") {
{ my $x; tiex $x if $tie; $x ++; ok ! uninitialized, "postinc$tie"; }
{ my $x; tiex $x if $tie; $x --; ok ! uninitialized, "postdec$tie"; }
{ my $x; tiex $x if $tie; ++ $x; ok ! uninitialized, "preinc$tie"; }
{ my $x; tiex $x if $tie; -- $x; ok ! uninitialized, "predec$tie"; }
{ my $x; tiex $x if $tie; $x **= 1; ok uninitialized, "**=$tie"; }
{ local $TODO = $tie && '[perl #17809] pp_add & pp_subtract';
{ my $x; tiex $x if $tie; $x += 1; ok ! uninitialized, "+=$tie"; }
{ my $x; tiex $x if $tie; $x -= 1; ok ! uninitialized, "-=$tie"; }
}
{ my $x; tiex $x if $tie; $x .= 1; ok ! uninitialized, ".=$tie"; }
{ my $x; tiex $x if $tie; $x *= 1; ok uninitialized, "*=$tie"; }
{ my $x; tiex $x if $tie; $x /= 1; ok uninitialized, "/=$tie"; }
{ my $x; tiex $x if $tie; $x %= 1; ok uninitialized, "\%=$tie"; }
{ my $x; tiex $x if $tie; $x x= 1; ok uninitialized, "x=$tie"; }
{ my $x; tiex $x if $tie; $x &= 1; ok uninitialized, "&=$tie"; }
{ local $TODO = $tie && '[perl #17809] pp_bit_or & pp_bit_xor';
{ my $x; tiex $x if $tie; $x |= 1; ok ! uninitialized, "|=$tie"; }
{ my $x; tiex $x if $tie; $x ^= 1; ok ! uninitialized, "^=$tie"; }
}
{ my $x; tiex $x if $tie; $x &&= 1; ok ! uninitialized, "&&=$tie"; }
{ my $x; tiex $x if $tie; $x ||= 1; ok ! uninitialized, "||=$tie"; }
{ my $x; tiex $x if $tie; $x <<= 1; ok uninitialized, "<<=$tie"; }
{ my $x; tiex $x if $tie; $x >>= 1; ok uninitialized, ">>=$tie"; }
{ my $x; tiex $x if $tie; $x &= "x"; ok uninitialized, "&=$tie, string"; }
{ local $TODO = $tie && '[perl #17809] pp_bit_or & pp_bit_xor';
{ my $x; tiex $x if $tie; $x |= "x"; ok ! uninitialized, "|=$tie, string"; }
{ my $x; tiex $x if $tie; $x ^= "x"; ok ! uninitialized, "^=$tie, string"; }
}
{ use integer;
{ local $TODO = $tie && '[perl #17809] pp_i_add & pp_i_subtract';
{ my $x; tiex $x if $tie; $x += 1; ok ! uninitialized, "+=$tie, int"; }
{ my $x; tiex $x if $tie; $x -= 1; ok ! uninitialized, "-=$tie, int"; }
}
{ my $x; tiex $x if $tie; $x *= 1; ok uninitialized, "*=$tie, int"; }
{ my $x; tiex $x if $tie; $x /= 1; ok uninitialized, "/=$tie, int"; }
{ my $x; tiex $x if $tie; $x %= 1; ok uninitialized, "\%=$tie, int"; }
{ my $x; tiex $x if $tie; $x ++; ok ! uninitialized, "postinc$tie, int"; }
{ my $x; tiex $x if $tie; $x --; ok ! uninitialized, "postdec$tie, int"; }
{ my $x; tiex $x if $tie; ++ $x; ok ! uninitialized, "preinc$tie, int"; }
{ my $x; tiex $x if $tie; -- $x; ok ! uninitialized, "predec$tie, int"; }
} # end of use integer;
} # end of for $tie
is $warn, '', "no spurious warnings";
--- NEW FILE: range.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use Config;
print "1..45\n";
print join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n";
@foo = (1,2,3,4,5,6,7,8,9);
@foo[2..4] = ('c','d','e');
print join(':', at foo[$foo[0]..5]) eq '2:c:d:e:6' ? "ok 2\n" : "not ok 2\n";
@bar[2..4] = ('c','d','e');
print join(':', at bar[1..5]) eq ':c:d:e:' ? "ok 3\n" : "not ok 3\n";
($a, at bcd[0..2],$e) = ('a','b','c','d','e');
print join(':',$a, at bcd[0..2],$e) eq 'a:b:c:d:e' ? "ok 4\n" : "not ok 4\n";
$x = 0;
for (1..100) {
$x += $_;
}
print $x == 5050 ? "ok 5\n" : "not ok 5 $x\n";
$x = 0;
for ((100,2..99,1)) {
$x += $_;
}
print $x == 5050 ? "ok 6\n" : "not ok 6 $x\n";
$x = join('','a'..'z');
print $x eq 'abcdefghijklmnopqrstuvwxyz' ? "ok 7\n" : "not ok 7 $x\n";
@x = 'A'..'ZZ';
print @x == 27 * 26 ? "ok 8\n" : "not ok 8\n";
@x = '09' .. '08'; # should produce '09', '10',... '99' (strange but true)
print "not " unless join(",", @x) eq
join(",", map {sprintf "%02d",$_} 9..99);
print "ok 9\n";
# same test with foreach (which is a separate implementation)
@y = ();
foreach ('09'..'08') {
push(@y, $_);
}
print "not " unless join(",", @y) eq join(",", @x);
print "ok 10\n";
# check bounds
if ($Config{ivsize} == 8) {
@a = eval "0x7ffffffffffffffe..0x7fffffffffffffff";
$a = "9223372036854775806 9223372036854775807";
@b = eval "-0x7fffffffffffffff..-0x7ffffffffffffffe";
$b = "-9223372036854775807 -9223372036854775806";
}
else {
@a = eval "0x7ffffffe..0x7fffffff";
$a = "2147483646 2147483647";
@b = eval "-0x7fffffff..-0x7ffffffe";
$b = "-2147483647 -2147483646";
}
print "not " unless "@a" eq $a;
print "ok 11\n";
print "not " unless "@b" eq $b;
print "ok 12\n";
# check magic
{
my $bad = 0;
local $SIG{'__WARN__'} = sub { $bad = 1 };
my $x = 'a-e';
$x =~ s/(\w)-(\w)/join ':', $1 .. $2/e;
$bad = 1 unless $x eq 'a:b:c:d:e';
print $bad ? "not ok 13\n" : "ok 13\n";
}
# Should use magical autoinc only when both are strings
print "not " unless 0 == (() = "0"..-1);
print "ok 14\n";
for my $x ("0"..-1) {
print "not ";
}
print "ok 15\n";
# [#18165] Should allow "-4".."0", broken by #4730. (AMS 20021031)
print join(":","-4".."0") eq "-4:-3:-2:-1:0" ? "ok 16\n" : "not ok 16\n";
print join(":","-4".."-0") eq "-4:-3:-2:-1:0" ? "ok 17\n" : "not ok 17\n";
print join(":","-4\n".."0\n") eq "-4:-3:-2:-1:0" ? "ok 18\n" : "not ok 18\n";
print join(":","-4\n".."-0\n") eq "-4:-3:-2:-1:0" ? "ok 19\n" : "not ok 19\n";
# undef should be treated as 0 for numerical range
print join(":",undef..2) eq '0:1:2' ? "ok 20\n" : "not ok 20\n";
print join(":",-2..undef) eq '-2:-1:0' ? "ok 21\n" : "not ok 21\n";
print join(":",undef..'2') eq '0:1:2' ? "ok 22\n" : "not ok 22\n";
print join(":",'-2'..undef) eq '-2:-1:0' ? "ok 23\n" : "not ok 23\n";
# undef should be treated as "" for magical range
print join(":", map "[$_]", "".."B") eq '[]' ? "ok 24\n" : "not ok 24\n";
print join(":", map "[$_]", undef.."B") eq '[]' ? "ok 25\n" : "not ok 25\n";
print join(":", map "[$_]", "B".."") eq '' ? "ok 26\n" : "not ok 26\n";
print join(":", map "[$_]", "B"..undef) eq '' ? "ok 27\n" : "not ok 27\n";
# undef..undef used to segfault
print join(":", map "[$_]", undef..undef) eq '[]' ? "ok 28\n" : "not ok 28\n";
# also test undef in foreach loops
@foo=(); push @foo, $_ for undef..2;
print join(":", @foo) eq '0:1:2' ? "ok 29\n" : "not ok 29\n";
@foo=(); push @foo, $_ for -2..undef;
print join(":", @foo) eq '-2:-1:0' ? "ok 30\n" : "not ok 30\n";
@foo=(); push @foo, $_ for undef..'2';
print join(":", @foo) eq '0:1:2' ? "ok 31\n" : "not ok 31\n";
@foo=(); push @foo, $_ for '-2'..undef;
print join(":", @foo) eq '-2:-1:0' ? "ok 32\n" : "not ok 32\n";
@foo=(); push @foo, $_ for undef.."B";
print join(":", map "[$_]", @foo) eq '[]' ? "ok 33\n" : "not ok 33\n";
@foo=(); push @foo, $_ for "".."B";
print join(":", map "[$_]", @foo) eq '[]' ? "ok 34\n" : "not ok 34\n";
@foo=(); push @foo, $_ for "B"..undef;
print join(":", map "[$_]", @foo) eq '' ? "ok 35\n" : "not ok 35\n";
@foo=(); push @foo, $_ for "B".."";
print join(":", map "[$_]", @foo) eq '' ? "ok 36\n" : "not ok 36\n";
@foo=(); push @foo, $_ for undef..undef;
print join(":", map "[$_]", @foo) eq '[]' ? "ok 37\n" : "not ok 37\n";
# again with magic
{
my @a = (1..3);
@foo=(); push @foo, $_ for undef..$#a;
print join(":", @foo) eq '0:1:2' ? "ok 38\n" : "not ok 38\n";
}
{
my @a = ();
@foo=(); push @foo, $_ for $#a..undef;
print join(":", @foo) eq '-1:0' ? "ok 39\n" : "not ok 39\n";
}
{
local $1;
"2" =~ /(.+)/;
@foo=(); push @foo, $_ for undef..$1;
print join(":", @foo) eq '0:1:2' ? "ok 40\n" : "not ok 40\n";
}
{
local $1;
"-2" =~ /(.+)/;
@foo=(); push @foo, $_ for $1..undef;
print join(":", @foo) eq '-2:-1:0' ? "ok 41\n" : "not ok 41\n";
}
{
local $1;
"B" =~ /(.+)/;
@foo=(); push @foo, $_ for undef..$1;
print join(":", map "[$_]", @foo) eq '[]' ? "ok 42\n" : "not ok 42\n";
}
{
local $1;
"B" =~ /(.+)/;
@foo=(); push @foo, $_ for ""..$1;
print join(":", map "[$_]", @foo) eq '[]' ? "ok 43\n" : "not ok 43\n";
}
{
local $1;
"B" =~ /(.+)/;
@foo=(); push @foo, $_ for $1..undef;
print join(":", map "[$_]", @foo) eq '' ? "ok 44\n" : "not ok 44\n";
}
{
local $1;
"B" =~ /(.+)/;
@foo=(); push @foo, $_ for $1.."";
print join(":", map "[$_]", @foo) eq '' ? "ok 45\n" : "not ok 45\n";
}
--- NEW FILE: each.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
plan tests => 39;
$h{'abc'} = 'ABC';
$h{'def'} = 'DEF';
$h{'jkl','mno'} = "JKL\034MNO";
$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
$h{'a'} = 'A';
$h{'b'} = 'B';
$h{'c'} = 'C';
$h{'d'} = 'D';
$h{'e'} = 'E';
$h{'f'} = 'F';
$h{'g'} = 'G';
$h{'h'} = 'H';
$h{'i'} = 'I';
$h{'j'} = 'J';
$h{'k'} = 'K';
$h{'l'} = 'L';
$h{'m'} = 'M';
$h{'n'} = 'N';
$h{'o'} = 'O';
$h{'p'} = 'P';
$h{'q'} = 'Q';
$h{'r'} = 'R';
$h{'s'} = 'S';
$h{'t'} = 'T';
$h{'u'} = 'U';
$h{'v'} = 'V';
$h{'w'} = 'W';
$h{'x'} = 'X';
$h{'y'} = 'Y';
$h{'z'} = 'Z';
@keys = keys %h;
@values = values %h;
is ($#keys, 29, "keys");
is ($#values, 29, "values");
$i = 0; # stop -w complaints
while (($key,$value) = each(%h)) {
if ($key eq $keys[$i] && $value eq $values[$i]
&& (('a' lt 'A' && $key lt $value) || $key gt $value)) {
$key =~ y/a-z/A-Z/;
$i++ if $key eq $value;
}
}
is ($i, 30, "each count");
@keys = ('blurfl', keys(%h), 'dyick');
is ($#keys, 31, "added a key");
$size = ((split('/',scalar %h))[1]);
keys %h = $size * 5;
$newsize = ((split('/',scalar %h))[1]);
is ($newsize, $size * 8, "resize");
keys %h = 1;
$size = ((split('/',scalar %h))[1]);
is ($size, $newsize, "same size");
%h = (1,1);
$size = ((split('/',scalar %h))[1]);
is ($size, $newsize, "still same size");
undef %h;
%h = (1,1);
$size = ((split('/',scalar %h))[1]);
is ($size, 8, "size 8");
# test scalar each
%hash = 1..20;
$total = 0;
$total += $key while $key = each %hash;
is ($total, 100, "test scalar each");
for (1..3) { @foo = each %hash }
keys %hash;
$total = 0;
$total += $key while $key = each %hash;
is ($total, 100, "test scalar keys resets iterator");
for (1..3) { @foo = each %hash }
$total = 0;
$total += $key while $key = each %hash;
isnt ($total, 100, "test iterator of each is being maintained");
for (1..3) { @foo = each %hash }
values %hash;
$total = 0;
$total += $key while $key = each %hash;
is ($total, 100, "test values keys resets iterator");
$size = (split('/', scalar %hash))[1];
keys(%hash) = $size / 2;
is ($size, (split('/', scalar %hash))[1]);
keys(%hash) = $size + 100;
isnt ($size, (split('/', scalar %hash))[1]);
is (keys(%hash), 10, "keys (%hash)");
is (keys(hash), 10, "keys (hash)");
$i = 0;
%h = (a => A, b => B, c=> C, d => D, abc => ABC);
@keys = keys(h);
@values = values(h);
while (($key, $value) = each(h)) {
if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
$i++;
}
}
is ($i, 5);
@tests = (&next_test, &next_test, &next_test);
{
package Obj;
sub DESTROY { print "ok $::tests[1] # DESTROY called\n"; }
{
my $h = { A => bless [], __PACKAGE__ };
while (my($k,$v) = each %$h) {
print "ok $::tests[0]\n" if $k eq 'A' and ref($v) eq 'Obj';
}
}
print "ok $::tests[2]\n";
}
# Check for Unicode hash keys.
%u = ("\x{12}", "f", "\x{123}", "fo", "\x{1234}", "foo");
$u{"\x{12345}"} = "bar";
@u{"\x{10FFFD}"} = "zap";
my %u2;
foreach (keys %u) {
is (length(), 1, "Check length of " . _qq $_);
$u2{$_} = $u{$_};
}
ok (eq_hash(\%u, \%u2), "copied unicode hash keys correctly?");
$a = "\xe3\x81\x82"; $A = "\x{3042}";
%b = ( $a => "non-utf8");
%u = ( $A => "utf8");
is (exists $b{$A}, '', "utf8 key in bytes hash");
is (exists $u{$a}, '', "bytes key in utf8 hash");
print "# $b{$_}\n" for keys %b; # Used to core dump before change #8056.
pass ("if we got here change 8056 worked");
print "# $u{$_}\n" for keys %u; # Used to core dump before change #8056.
pass ("change 8056 is thanks to Inaba Hiroto");
# on EBCDIC chars are mapped differently so pick something that needs encoding
# there too.
$d = pack("U*", 0xe3, 0x81, 0xAF);
{ use bytes; $ol = bytes::length($d) }
cmp_ok ($ol, '>', 3, "check encoding on EBCDIC");
%u = ($d => "downgrade");
for (keys %u) {
is (length, 3, "check length");
is ($_, pack("U*", 0xe3, 0x81, 0xAF), "check value");
}
{
{ use bytes; is (bytes::length($d), $ol) }
}
{
my %u;
my $u0 = pack("U0U", 0x00FF);
my $b0 = "\xC3\xBF"; # 0xCB 0xBF is U+00FF in UTF-8
my $u1 = pack("U0U", 0x0100);
my $b1 = "\xC4\x80"; # 0xC4 0x80 is U+0100 in UTF-8
$u{$u0} = 1;
$u{$b0} = 2;
$u{$u1} = 3;
$u{$b1} = 4;
is(scalar keys %u, 4, "four different Unicode keys");
is($u{$u0}, 1, "U+00FF -> 1");
is($u{$b0}, 2, "U+00C3 U+00BF -> 2");
is($u{$u1}, 3, "U+0100 -> 3 ");
is($u{$b1}, 4, "U+00C4 U+0080 -> 4");
}
--- NEW FILE: inc.t ---
#!./perl -w
# use strict;
print "1..34\n";
my $test = 1;
sub ok {
my ($pass, $wrong, $err) = @_;
if ($pass) {
print "ok $test\n";
$test = $test + 1; # Would be doubleplusbad to use ++ in the ++ test.
return 1;
} else {
if ($err) {
chomp $err;
print "not ok $test # $err\n";
} else {
if (defined $wrong) {
$wrong = ", got $wrong";
} else {
$wrong = '';
}
printf "not ok $test # line %d$wrong\n", (caller)[2];
}
}
$test = $test + 1;
return;
}
# Verify that addition/subtraction properly upgrade to doubles.
# These tests are only significant on machines with 32 bit longs,
# and two's complement negation, but shouldn't fail anywhere.
my $a = 2147483647;
my $c=$a++;
ok ($a == 2147483648, $a);
$a = 2147483647;
$c=++$a;
ok ($a == 2147483648, $a);
$a = 2147483647;
$a=$a+1;
ok ($a == 2147483648, $a);
$a = -2147483648;
$c=$a--;
ok ($a == -2147483649, $a);
$a = -2147483648;
$c=--$a;
ok ($a == -2147483649, $a);
$a = -2147483648;
$a=$a-1;
ok ($a == -2147483649, $a);
$a = 2147483648;
$a = -$a;
$c=$a--;
ok ($a == -2147483649, $a);
$a = 2147483648;
$a = -$a;
$c=--$a;
ok ($a == -2147483649, $a);
$a = 2147483648;
$a = -$a;
$a=$a-1;
ok ($a == -2147483649, $a);
$a = 2147483648;
$b = -$a;
$c=$b--;
ok ($b == -$a-1, $a);
$a = 2147483648;
$b = -$a;
$c=--$b;
ok ($b == -$a-1, $a);
$a = 2147483648;
$b = -$a;
$b=$b-1;
ok ($b == -(++$a), $a);
$a = undef;
ok ($a++ eq '0', do { $a=undef; $a++ }, "postinc undef returns '0'");
$a = undef;
ok (!defined($a--), do { $a=undef; $a-- }, "postdec undef returns undef");
# Verify that shared hash keys become unshared.
sub check_same {
my ($orig, $suspect) = @_;
my $fail;
while (my ($key, $value) = each %$suspect) {
if (exists $orig->{$key}) {
if ($orig->{$key} ne $value) {
print "# key '$key' was '$orig->{$key}' now '$value'\n";
$fail = 1;
}
} else {
print "# key '$key' is '$orig->{$key}', unexpect.\n";
$fail = 1;
}
}
foreach (keys %$orig) {
next if (exists $suspect->{$_});
print "# key '$_' was '$orig->{$_}' now missing\n";
$fail = 1;
}
ok (!$fail);
}
my (%orig) = my (%inc) = my (%dec) = my (%postinc) = my (%postdec)
= (1 => 1, ab => "ab");
my %up = (1=>2, ab => 'ac');
my %down = (1=>0, ab => -1);
foreach (keys %inc) {
my $ans = $up{$_};
my $up;
eval {$up = ++$_};
ok ((defined $up and $up eq $ans), $up, $@);
}
check_same (\%orig, \%inc);
foreach (keys %dec) {
my $ans = $down{$_};
my $down;
eval {$down = --$_};
ok ((defined $down and $down eq $ans), $down, $@);
}
check_same (\%orig, \%dec);
foreach (keys %postinc) {
my $ans = $postinc{$_};
my $up;
eval {$up = $_++};
ok ((defined $up and $up eq $ans), $up, $@);
}
check_same (\%orig, \%postinc);
foreach (keys %postdec) {
my $ans = $postdec{$_};
my $down;
eval {$down = $_--};
ok ((defined $down and $down eq $ans), $down, $@);
}
check_same (\%orig, \%postdec);
{
no warnings 'uninitialized';
my ($x, $y);
eval {
$y ="$x\n";
++$x;
};
ok($x == 1, $x);
ok($@ eq '', $@);
my ($p, $q);
eval {
$q ="$p\n";
--$p;
};
ok($p == -1, $p);
ok($@ eq '', $@);
}
$a = 2147483648;
$c=--$a;
ok ($a == 2147483647, $a);
$a = 2147483648;
$c=$a--;
ok ($a == 2147483647, $a);
{
use integer;
my $x = 0;
$x++;
ok ($x == 1, "(void) i_postinc");
$x--;
ok ($x == 0, "(void) i_postdec");
}
--- NEW FILE: bless.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
plan (106);
sub expected {
my($object, $package, $type) = @_;
print "# $object $package $type\n";
is(ref($object), $package);
my $r = qr/^\Q$package\E=(\w+)\(0x([0-9a-f]+)\)$/;
like("$object", $r);
"$object" =~ $r;
is($1, $type);
# in 64-bit platforms hex warns for 32+ -bit values
cmp_ok(do {no warnings 'portable'; hex($2)}, '==', $object);
}
# test blessing simple types
$a1 = bless {}, "A";
expected($a1, "A", "HASH");
$b1 = bless [], "B";
expected($b1, "B", "ARRAY");
$c1 = bless \(map "$_", "test"), "C";
expected($c1, "C", "SCALAR");
our $test = "foo"; $d1 = bless \*test, "D";
expected($d1, "D", "GLOB");
$e1 = bless sub { 1 }, "E";
expected($e1, "E", "CODE");
$f1 = bless \[], "F";
expected($f1, "F", "REF");
$g1 = bless \substr("test", 1, 2), "G";
expected($g1, "G", "LVALUE");
# blessing ref to object doesn't modify object
expected(bless(\$a1, "F"), "F", "REF");
expected($a1, "A", "HASH");
# reblessing does modify object
bless $a1, "A2";
expected($a1, "A2", "HASH");
# local and my
{
local $a1 = bless $a1, "A3"; # should rebless outer $a1
local $b1 = bless [], "B3";
my $c1 = bless $c1, "C3"; # should rebless outer $c1
our $test2 = ""; my $d1 = bless \*test2, "D3";
expected($a1, "A3", "HASH");
expected($b1, "B3", "ARRAY");
expected($c1, "C3", "SCALAR");
expected($d1, "D3", "GLOB");
}
expected($a1, "A3", "HASH");
expected($b1, "B", "ARRAY");
expected($c1, "C3", "SCALAR");
expected($d1, "D", "GLOB");
# class is magic
"E" =~ /(.)/;
expected(bless({}, $1), "E", "HASH");
{
local $! = 1;
my $string = "$!";
$! = 2; # attempt to avoid cached string
$! = 1;
expected(bless({}, $!), $string, "HASH");
# ref is ref to magic
{
{
package F;
sub test { main::is(${$_[0]}, $string) }
}
$! = 2;
$f1 = bless \$!, "F";
$! = 1;
$f1->test;
}
}
# ref is magic
### example of magic variable that is a reference??
# no class, or empty string (with a warning), or undef (with two)
expected(bless([]), 'main', "ARRAY");
{
local $SIG{__WARN__} = sub { push @w, join '', @_ };
use warnings;
$m = bless [];
expected($m, 'main', "ARRAY");
is (scalar @w, 0);
@w = ();
$m = bless [], '';
expected($m, 'main', "ARRAY");
is (scalar @w, 1);
@w = ();
$m = bless [], undef;
expected($m, 'main', "ARRAY");
is (scalar @w, 2);
}
# class is a ref
$a1 = bless {}, "A4";
$b1 = eval { bless {}, $a1 };
isnt ($@, '', "class is a ref");
# class is an overloaded ref
{
package H4;
use overload '""' => sub { "C4" };
}
$h1 = bless {}, "H4";
$c4 = eval { bless \$test, $h1 };
is ($@, '', "class is an overloaded ref");
expected($c4, 'C4', "SCALAR");
--- NEW FILE: regmesg.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
my $debug = 1;
##
## If the markers used are changed (search for "MARKER1" in regcomp.c),
## update only these two variables, and leave the {#} in the @death/@warning
## arrays below. The {#} is a meta-marker -- it marks where the marker should
## go.
my $marker1 = "<-- HERE";
my $marker2 = " <-- HERE ";
##
## Key-value pairs of code/error of code that should have fatal errors.
##
eval 'use Config'; # assume defaults if fail
our %Config;
my $inf_m1 = ($Config{reg_infty} || 32767) - 1;
my $inf_p1 = $inf_m1 + 2;
my @death =
(
'/[[=foo=]]/' => 'POSIX syntax [= =] is reserved for future extensions in regex; marked by {#} in m/[[=foo=]{#}]/',
'/(?<= .*)/' => 'Variable length lookbehind not implemented in regex; marked by {#} in m/(?<= .*){#}/',
'/(?<= x{1000})/' => 'Lookbehind longer than 255 not implemented in regex; marked by {#} in m/(?<= x{1000}){#}/',
'/(?@)/' => 'Sequence (?@...) not implemented in regex; marked by {#} in m/(?@{#})/',
'/(?{ 1/' => 'Sequence (?{...}) not terminated or not {}-balanced in regex; marked by {#} in m/(?{{#} 1/',
'/(?(1x))/' => 'Switch condition not recognized in regex; marked by {#} in m/(?(1x{#}))/',
'/(?(1)x|y|z)/' => 'Switch (?(condition)... contains too many branches in regex; marked by {#} in m/(?(1)x|y|{#}z)/',
'/(?(x)y|x)/' => 'Unknown switch condition (?(x) in regex; marked by {#} in m/(?({#}x)y|x)/',
'/(?/' => 'Sequence (? incomplete in regex; marked by {#} in m/(?{#}/',
'/(?;x/' => 'Sequence (?;...) not recognized in regex; marked by {#} in m/(?;{#}x/',
'/(?<;x/' => 'Sequence (?<;...) not recognized in regex; marked by {#} in m/(?<;{#}x/',
'/((x)/' => 'Unmatched ( in regex; marked by {#} in m/({#}(x)/',
"/x{$inf_p1}/" => "Quantifier in {,} bigger than $inf_m1 in regex; marked by {#} in m/x{{#}$inf_p1}/",
'/x{3,1}/' => 'Can\'t do {n,m} with n > m in regex; marked by {#} in m/x{3,1}{#}/',
'/x**/' => 'Nested quantifiers in regex; marked by {#} in m/x**{#}/',
'/x[/' => 'Unmatched [ in regex; marked by {#} in m/x[{#}/',
'/*/', => 'Quantifier follows nothing in regex; marked by {#} in m/*{#}/',
'/\p{x/' => 'Missing right brace on \p{} in regex; marked by {#} in m/\p{{#}x/',
'/[\p{x]/' => 'Missing right brace on \p{} in regex; marked by {#} in m/[\p{{#}x]/',
'/(x)\2/' => 'Reference to nonexistent group in regex; marked by {#} in m/(x)\2{#}/',
'my $m = "\\\"; $m =~ $m', => 'Trailing \ in regex m/\/',
'/\x{1/' => 'Missing right brace on \x{} in regex; marked by {#} in m/\x{{#}1/',
'/[\x{X]/' => 'Missing right brace on \x{} in regex; marked by {#} in m/[\x{{#}X]/',
'/[[:barf:]]/' => 'POSIX class [:barf:] unknown in regex; marked by {#} in m/[[:barf:]{#}]/',
'/[[=barf=]]/' => 'POSIX syntax [= =] is reserved for future extensions in regex; marked by {#} in m/[[=barf=]{#}]/',
'/[[.barf.]]/' => 'POSIX syntax [. .] is reserved for future extensions in regex; marked by {#} in m/[[.barf.]{#}]/',
'/[z-a]/' => 'Invalid [] range "z-a" in regex; marked by {#} in m/[z-a{#}]/',
'/\p/' => 'Empty \p{} in regex; marked by {#} in m/\p{#}/',
'/\P{}/' => 'Empty \P{} in regex; marked by {#} in m/\P{{#}}/',
);
##
## Key-value pairs of code/error of code that should have non-fatal warnings.
##
@warning = (
"m/(?p{ 'a' })/" => "(?p{}) is deprecated - use (??{}) in regex; marked by {#} in m/(?p{#}{ 'a' })/",
'm/\b*/' => '\b* matches null string many times in regex; marked by {#} in m/\b*{#}/',
'm/[:blank:]/' => 'POSIX syntax [: :] belongs inside character classes in regex; marked by {#} in m/[:blank:]{#}/',
"m'[\\y]'" => 'Unrecognized escape \y in character class passed through in regex; marked by {#} in m/[\y{#}]/',
'm/[a-\d]/' => 'False [] range "a-\d" in regex; marked by {#} in m/[a-\d{#}]/',
'm/[\w-x]/' => 'False [] range "\w-" in regex; marked by {#} in m/[\w-{#}x]/',
'm/[a-\pM]/' => 'False [] range "a-\pM" in regex; marked by {#} in m/[a-\pM{#}]/',
'm/[\pM-x]/' => 'False [] range "\pM-" in regex; marked by {#} in m/[\pM-{#}x]/',
"m'\\y'" => 'Unrecognized escape \y passed through in regex; marked by {#} in m/\y{#}/',
);
my $total = (@death + @warning)/2;
# utf8 is a noop on EBCDIC platforms, it is not fatal
my $Is_EBCDIC = (ord('A') == 193);
if ($Is_EBCDIC) {
my @utf8_death = grep(/utf8/, @death);
$total = $total - @utf8_death;
}
print "1..$total\n";
my $count = 0;
while (@death)
{
my $regex = shift @death;
my $result = shift @death;
# skip the utf8 test on EBCDIC since they do not die
next if ($Is_EBCDIC && $regex =~ /utf8/);
$count++;
$_ = "x";
eval $regex;
if (not $@) {
print "# oops, $regex didn't die\nnot ok $count\n";
next;
}
chomp $@;
$result =~ s/{\#}/$marker1/;
$result =~ s/{\#}/$marker2/;
$result .= " at ";
if ($@ !~ /^\Q$result/) {
print "# For $regex, expected:\n# $result\n# Got:\n# $@\n#\nnot ";
}
print "ok $count - $regex\n";
}
our $warning;
$SIG{__WARN__} = sub { $warning = shift };
while (@warning)
{
$count++;
my $regex = shift @warning;
my $result = shift @warning;
undef $warning;
$_ = "x";
eval $regex;
if ($@)
{
print "# oops, $regex died with:\n#\t$@#\nnot ok $count\n";
next;
}
if (not $warning)
{
print "# oops, $regex didn't generate a warning\nnot ok $count\n";
next;
}
$result =~ s/{\#}/$marker1/;
$result =~ s/{\#}/$marker2/;
$result .= " at ";
if ($warning !~ /^\Q$result/)
{
print <<"EOM";
# For $regex, expected:
# $result
# Got:
# $warning
#
not ok $count
EOM
next;
}
print "ok $count - $regex\n";
}
--- NEW FILE: sleep.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
}
require "test.pl";
plan( tests => 4 );
use strict;
use warnings;
my $start = time;
my $sleep_says = sleep 3;
my $diff = time - $start;
cmp_ok( $sleep_says, '>=', 2, 'Sleep says it slept at least 2 seconds' );
cmp_ok( $sleep_says, '<=', 10, '... and no more than 10' );
cmp_ok( $diff, '>=', 2, 'Actual time diff is at least 2 seconds' );
cmp_ok( $diff, '<=', 10, '... and no more than 10' );
--- NEW FILE: fork.t ---
#!./perl
# tests for both real and emulated fork()
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
unless ($Config{'d_fork'}
or (($^O eq 'MSWin32' || $^O eq 'NetWare') and $Config{useithreads}
and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
# and !defined $Config{'useperlio'}
))
{
print "1..0 # Skip: no fork\n";
exit 0;
}
$ENV{PERL5LIB} = "../lib";
}
if ($^O eq 'mpeix') {
print "1..0 # Skip: fork/status problems on MPE/iX\n";
exit 0;
}
$|=1;
undef $/;
@prgs = split "\n########\n", <DATA>;
print "1..", scalar @prgs, "\n";
$tmpfile = "forktmp000";
1 while -f ++$tmpfile;
END { close TEST; unlink $tmpfile if $tmpfile; }
$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : (($^O eq 'NetWare') ? 'perl -e "print <>"' : 'cat'));
for (@prgs){
my $switch;
if (s/^\s*(-\w.*)//){
$switch = $1;
}
my($prog,$expected) = split(/\nEXPECT\n/, $_);
$expected =~ s/\n+$//;
# results can be in any order, so sort 'em
my @expected = sort split /\n/, $expected;
open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
print TEST $prog, "\n";
close TEST or die "Cannot close $tmpfile: $!";
my $results;
if ($^O eq 'MSWin32') {
$results = `.\\perl -I../lib $switch $tmpfile 2>&1`;
}
elsif ($^O eq 'NetWare') {
$results = `perl -I../lib $switch $tmpfile 2>&1`;
}
else {
$results = `./perl $switch $tmpfile 2>&1`;
}
$status = $?;
$results =~ s/\n+$//;
$results =~ s/at\s+forktmp\d+\s+line/at - line/g;
$results =~ s/of\s+forktmp\d+\s+aborted/of - aborted/g;
# bison says 'parse error' instead of 'syntax error',
# various yaccs may or may not capitalize 'syntax'.
$results =~ s/^(syntax|parse) error/syntax error/mig;
$results =~ s/^\n*Process terminated by SIG\w+\n?//mg
if $^O eq 'os2';
my @results = sort split /\n/, $results;
if ( "@results" ne "@expected" ) {
print STDERR "PROG: $switch\n$prog\n";
print STDERR "EXPECTED:\n$expected\n";
print STDERR "GOT:\n$results\n";
print "not ";
}
print "ok ", ++$i, "\n";
}
__END__
$| = 1;
if ($cid = fork) {
sleep 1;
if ($result = (kill 9, $cid)) {
print "ok 2\n";
}
else {
print "not ok 2 $result\n";
}
sleep 1 if $^O eq 'MSWin32'; # avoid WinNT race bug
}
else {
print "ok 1\n";
sleep 10;
}
EXPECT
ok 1
ok 2
########
$| = 1;
sub forkit {
print "iteration $i start\n";
my $x = fork;
if (defined $x) {
if ($x) {
print "iteration $i parent\n";
}
else {
print "iteration $i child\n";
}
}
else {
print "pid $$ failed to fork\n";
}
}
while ($i++ < 3) { do { forkit(); }; }
EXPECT
iteration 1 start
iteration 1 parent
iteration 1 child
iteration 2 start
iteration 2 parent
iteration 2 child
iteration 2 start
iteration 2 parent
iteration 2 child
iteration 3 start
iteration 3 parent
iteration 3 child
iteration 3 start
iteration 3 parent
iteration 3 child
iteration 3 start
iteration 3 parent
iteration 3 child
iteration 3 start
iteration 3 parent
iteration 3 child
########
$| = 1;
fork()
? (print("parent\n"),sleep(1))
: (print("child\n"),exit) ;
EXPECT
parent
child
########
$| = 1;
fork()
? (print("parent\n"),exit)
: (print("child\n"),sleep(1)) ;
EXPECT
parent
child
########
$| = 1;
@a = (1..3);
for (@a) {
if (fork) {
print "parent $_\n";
$_ = "[$_]";
}
else {
print "child $_\n";
$_ = "-$_-";
}
}
print "@a\n";
EXPECT
parent 1
child 1
parent 2
child 2
parent 2
child 2
parent 3
child 3
parent 3
child 3
parent 3
child 3
parent 3
child 3
[1] [2] [3]
-1- [2] [3]
[1] -2- [3]
[1] [2] -3-
-1- -2- [3]
-1- [2] -3-
[1] -2- -3-
-1- -2- -3-
########
$| = 1;
foreach my $c (1,2,3) {
if (fork) {
print "parent $c\n";
}
else {
print "child $c\n";
exit;
}
}
while (wait() != -1) { print "waited\n" }
EXPECT
child 1
child 2
child 3
parent 1
parent 2
parent 3
waited
waited
waited
########
use Config;
$| = 1;
$\ = "\n";
fork()
? print($Config{osname} eq $^O)
: print($Config{osname} eq $^O) ;
EXPECT
1
1
########
$| = 1;
$\ = "\n";
fork()
? do { require Config; print($Config::Config{osname} eq $^O); }
: do { require Config; print($Config::Config{osname} eq $^O); }
EXPECT
1
1
########
$| = 1;
use Cwd;
$\ = "\n";
my $dir;
if (fork) {
$dir = "f$$.tst";
mkdir $dir, 0755;
chdir $dir;
print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent";
chdir "..";
rmdir $dir;
}
else {
sleep 2;
$dir = "f$$.tst";
mkdir $dir, 0755;
chdir $dir;
print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child";
chdir "..";
rmdir $dir;
}
EXPECT
ok 1 parent
ok 1 child
########
$| = 1;
$\ = "\n";
my $getenv;
if ($^O eq 'MSWin32' || $^O eq 'NetWare') {
$getenv = qq[$^X -e "print \$ENV{TST}"];
}
else {
$getenv = qq[$^X -e 'print \$ENV{TST}'];
}
$ENV{TST} = 'foo';
if (fork) {
sleep 1;
print "parent before: " . `$getenv`;
$ENV{TST} = 'bar';
print "parent after: " . `$getenv`;
}
else {
print "child before: " . `$getenv`;
$ENV{TST} = 'baz';
print "child after: " . `$getenv`;
}
EXPECT
child before: foo
child after: baz
parent before: foo
parent after: bar
########
$| = 1;
$\ = "\n";
if ($pid = fork) {
waitpid($pid,0);
print "parent got $?"
}
else {
exit(42);
}
EXPECT
parent got 10752
########
$| = 1;
$\ = "\n";
my $echo = 'echo';
if ($pid = fork) {
waitpid($pid,0);
print "parent got $?"
}
else {
exec("$echo foo");
}
EXPECT
foo
parent got 0
########
if (fork) {
die "parent died";
}
else {
die "child died";
}
EXPECT
parent died at - line 2.
child died at - line 5.
########
if ($pid = fork) {
eval { die "parent died" };
print $@;
}
else {
eval { die "child died" };
print $@;
}
EXPECT
parent died at - line 2.
child died at - line 6.
########
if (eval q{$pid = fork}) {
eval q{ die "parent died" };
print $@;
}
else {
eval q{ die "child died" };
print $@;
}
EXPECT
parent died at (eval 2) line 1.
child died at (eval 2) line 1.
########
BEGIN {
$| = 1;
fork and exit;
print "inner\n";
}
# XXX In emulated fork(), the child will not execute anything after
# the BEGIN block, due to difficulties in recreating the parse stacks
# and restarting yyparse() midstream in the child. This can potentially
# be overcome by treating what's after the BEGIN{} as a brand new parse.
#print "outer\n"
EXPECT
inner
########
sub pipe_to_fork ($$) {
my $parent = shift;
my $child = shift;
pipe($child, $parent) or die;
my $pid = fork();
die "fork() failed: $!" unless defined $pid;
close($pid ? $child : $parent);
$pid;
}
if (pipe_to_fork('PARENT','CHILD')) {
# parent
print PARENT "pipe_to_fork\n";
close PARENT;
}
else {
# child
while (<CHILD>) { print; }
close CHILD;
exit;
}
sub pipe_from_fork ($$) {
my $parent = shift;
my $child = shift;
pipe($parent, $child) or die;
my $pid = fork();
die "fork() failed: $!" unless defined $pid;
close($pid ? $child : $parent);
$pid;
}
if (pipe_from_fork('PARENT','CHILD')) {
# parent
while (<PARENT>) { print; }
close PARENT;
}
else {
# child
print CHILD "pipe_from_fork\n";
close CHILD;
exit;
}
EXPECT
pipe_from_fork
pipe_to_fork
########
$|=1;
if ($pid = fork()) {
print "forked first kid\n";
print "waitpid() returned ok\n" if waitpid($pid,0) == $pid;
}
else {
print "first child\n";
exit(0);
}
if ($pid = fork()) {
print "forked second kid\n";
print "wait() returned ok\n" if wait() == $pid;
}
else {
print "second child\n";
exit(0);
}
EXPECT
forked first kid
first child
waitpid() returned ok
forked second kid
second child
wait() returned ok
########
pipe(RDR,WTR) or die $!;
my $pid = fork;
die "fork: $!" if !defined $pid;
if ($pid == 0) {
my $rand_child = rand;
close RDR;
print WTR $rand_child, "\n";
close WTR;
} else {
my $rand_parent = rand;
close WTR;
chomp(my $rand_child = <RDR>);
close RDR;
print $rand_child ne $rand_parent, "\n";
}
EXPECT
1
--- NEW FILE: auto.t ---
#!./perl
# $RCSfile: auto.t,v $$Revision: 1.2 $$Date: 2006-12-04 17:01:59 $
print "1..37\n";
$x = 10000;
if (0 + ++$x - 1 == 10000) { print "ok 1\n";} else {print "not ok 1\n";}
if (0 + $x-- - 1 == 10000) { print "ok 2\n";} else {print "not ok 2\n";}
if (1 * $x == 10000) { print "ok 3\n";} else {print "not ok 3\n";}
if (0 + $x-- - 0 == 10000) { print "ok 4\n";} else {print "not ok 4\n";}
if (1 + $x == 10000) { print "ok 5\n";} else {print "not ok 5\n";}
if (1 + $x++ == 10000) { print "ok 6\n";} else {print "not ok 6\n";}
if (0 + $x == 10000) { print "ok 7\n";} else {print "not ok 7\n";}
if (0 + --$x + 1 == 10000) { print "ok 8\n";} else {print "not ok 8\n";}
if (0 + ++$x + 0 == 10000) { print "ok 9\n";} else {print "not ok 9\n";}
if ($x == 10000) { print "ok 10\n";} else {print "not ok 10\n";}
$x[0] = 10000;
if (0 + ++$x[0] - 1 == 10000) { print "ok 11\n";} else {print "not ok 11\n";}
if (0 + $x[0]-- - 1 == 10000) { print "ok 12\n";} else {print "not ok 12\n";}
if (1 * $x[0] == 10000) { print "ok 13\n";} else {print "not ok 13\n";}
if (0 + $x[0]-- - 0 == 10000) { print "ok 14\n";} else {print "not ok 14\n";}
if (1 + $x[0] == 10000) { print "ok 15\n";} else {print "not ok 15\n";}
if (1 + $x[0]++ == 10000) { print "ok 16\n";} else {print "not ok 16\n";}
if (0 + $x[0] == 10000) { print "ok 17\n";} else {print "not ok 17\n";}
if (0 + --$x[0] + 1 == 10000) { print "ok 18\n";} else {print "not ok 18\n";}
if (0 + ++$x[0] + 0 == 10000) { print "ok 19\n";} else {print "not ok 19\n";}
if ($x[0] == 10000) { print "ok 20\n";} else {print "not ok 20\n";}
$x{0} = 10000;
if (0 + ++$x{0} - 1 == 10000) { print "ok 21\n";} else {print "not ok 21\n";}
if (0 + $x{0}-- - 1 == 10000) { print "ok 22\n";} else {print "not ok 22\n";}
if (1 * $x{0} == 10000) { print "ok 23\n";} else {print "not ok 23\n";}
if (0 + $x{0}-- - 0 == 10000) { print "ok 24\n";} else {print "not ok 24\n";}
if (1 + $x{0} == 10000) { print "ok 25\n";} else {print "not ok 25\n";}
if (1 + $x{0}++ == 10000) { print "ok 26\n";} else {print "not ok 26\n";}
if (0 + $x{0} == 10000) { print "ok 27\n";} else {print "not ok 27\n";}
if (0 + --$x{0} + 1 == 10000) { print "ok 28\n";} else {print "not ok 28\n";}
if (0 + ++$x{0} + 0 == 10000) { print "ok 29\n";} else {print "not ok 29\n";}
if ($x{0} == 10000) { print "ok 30\n";} else {print "not ok 30\n";}
# test magical autoincrement
if (++($foo = '99') eq '100') {print "ok 31\n";} else {print "not ok 31\n";}
if (++($foo = 'a0') eq 'a1') {print "ok 32\n";} else {print "not ok 32\n";}
if (++($foo = 'Az') eq 'Ba') {print "ok 33\n";} else {print "not ok 33\n";}
if (++($foo = 'zz') eq 'aaa') {print "ok 34\n";} else {print "not ok 34\n";}
if (++($foo = 'A99') eq 'B00') {print "ok 35\n";} else {print "not ok 35\n";}
# EBCDIC guards: i and j, r and s, are not contiguous.
if (++($foo = 'zi') eq 'zj') {print "ok 36\n";} else {print "not ok 36\n";}
if (++($foo = 'zr') eq 'zs') {print "ok 37\n";} else {print "not ok 37\n";}
--- NEW FILE: length.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
print "1..20\n";
print "not " unless length("") == 0;
print "ok 1\n";
print "not " unless length("abc") == 3;
print "ok 2\n";
$_ = "foobar";
print "not " unless length() == 6;
print "ok 3\n";
# Okay, so that wasn't very challenging. Let's go Unicode.
{
my $a = "\x{41}";
print "not " unless length($a) == 1;
print "ok 4\n";
$test++;
use bytes;
print "not " unless $a eq "\x41" && length($a) == 1;
print "ok 5\n";
$test++;
}
{
my $a = pack("U", 0xFF);
print "not " unless length($a) == 1;
print "ok 6\n";
$test++;
use bytes;
if (ord('A') == 193)
{
printf "#%vx for 0xFF\n",$a;
print "not " unless $a eq "\x8b\x73" && length($a) == 2;
}
else
{
print "not " unless $a eq "\xc3\xbf" && length($a) == 2;
}
print "ok 7\n";
$test++;
}
{
my $a = "\x{100}";
print "not " unless length($a) == 1;
print "ok 8\n";
$test++;
use bytes;
if (ord('A') == 193)
{
printf "#%vx for 0x100\n",$a;
print "not " unless $a eq "\x8c\x41" && length($a) == 2;
}
else
{
print "not " unless $a eq "\xc4\x80" && length($a) == 2;
}
print "ok 9\n";
$test++;
}
{
my $a = "\x{100}\x{80}";
print "not " unless length($a) == 2;
print "ok 10\n";
$test++;
use bytes;
if (ord('A') == 193)
{
printf "#%vx for 0x100 0x80\n",$a;
print "not " unless $a eq "\x8c\x41\x8a\x67" && length($a) == 4;
}
else
{
print "not " unless $a eq "\xc4\x80\xc2\x80" && length($a) == 4;
}
print "ok 11\n";
$test++;
}
{
my $a = "\x{80}\x{100}";
print "not " unless length($a) == 2;
print "ok 12\n";
$test++;
use bytes;
if (ord('A') == 193)
{
printf "#%vx for 0x80 0x100\n",$a;
print "not " unless $a eq "\x8a\x67\x8c\x41" && length($a) == 4;
}
else
{
print "not " unless $a eq "\xc2\x80\xc4\x80" && length($a) == 4;
}
print "ok 13\n";
$test++;
}
# Now for Unicode with magical vtbls
{
require Tie::Scalar;
my $a;
tie $a, 'Tie::StdScalar'; # makes $a magical
$a = "\x{263A}";
print "not " unless length($a) == 1;
print "ok 14\n";
$test++;
use bytes;
print "not " unless length($a) == 3;
print "ok 15\n";
$test++;
}
{
# Play around with Unicode strings,
# give a little workout to the UTF-8 length cache.
my $a = chr(256) x 100;
print length $a == 100 ? "ok 16\n" : "not ok 16\n";
chop $a;
print length $a == 99 ? "ok 17\n" : "not ok 17\n";
$a .= $a;
print length $a == 198 ? "ok 18\n" : "not ok 18\n";
$a = chr(256) x 999;
print length $a == 999 ? "ok 19\n" : "not ok 19\n";
substr($a, 0, 1) = '';
print length $a == 998 ? "ok 20\n" : "not ok 20\n";
}
--- NEW FILE: arith.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
print "1..145\n";
sub try ($$) {
print +($_[1] ? "ok" : "not ok"), " $_[0]\n";
}
sub tryeq ($$$) {
if ($_[1] == $_[2]) {
print "ok $_[0]\n";
} else {
print "not ok $_[0] # $_[1] != $_[2]\n";
}
}
sub tryeq_sloppy ($$$) {
if ($_[1] == $_[2]) {
print "ok $_[0]\n";
} else {
my $error = abs ($_[1] - $_[2]) / $_[1];
if ($error < 1e-9) {
print "ok $_[0] # $_[1] is close to $_[2], \$^O eq $^O\n";
} else {
print "not ok $_[0] # $_[1] != $_[2]\n";
}
}
}
my $T = 1;
tryeq $T++, 13 % 4, 1;
tryeq $T++, -13 % 4, 3;
tryeq $T++, 13 % -4, -3;
tryeq $T++, -13 % -4, -1;
# Give abs() a good work-out before using it in anger
tryeq $T++, abs(0), 0;
tryeq $T++, abs(1), 1;
tryeq $T++, abs(-1), 1;
tryeq $T++, abs(2147483647), 2147483647;
tryeq $T++, abs(-2147483647), 2147483647;
tryeq $T++, abs(4294967295), 4294967295;
tryeq $T++, abs(-4294967295), 4294967295;
tryeq $T++, abs(9223372036854775807), 9223372036854775807;
tryeq $T++, abs(-9223372036854775807), 9223372036854775807;
tryeq $T++, abs(1e50), 1e50; # Assume no change whatever; no slop needed
tryeq $T++, abs(-1e50), 1e50; # Assume only sign bit flipped
my $limit = 1e6;
# Division (and modulo) of floating point numbers
# seem to be rather sloppy in Cray.
$limit = 1e8 if $^O eq 'unicos';
try $T++, abs( 13e21 % 4e21 - 1e21) < $limit;
try $T++, abs(-13e21 % 4e21 - 3e21) < $limit;
try $T++, abs( 13e21 % -4e21 - -3e21) < $limit;
try $T++, abs(-13e21 % -4e21 - -1e21) < $limit;
# UVs should behave properly
tryeq $T++, 4063328477 % 65535, 27407;
tryeq $T++, 4063328477 % 4063328476, 1;
tryeq $T++, 4063328477 % 2031664238, 1;
tryeq $T++, 2031664238 % 4063328477, 2031664238;
# These should trigger wrapping on 32 bit IVs and UVs
tryeq $T++, 2147483647 + 0, 2147483647;
# IV + IV promote to UV
tryeq $T++, 2147483647 + 1, 2147483648;
tryeq $T++, 2147483640 + 10, 2147483650;
tryeq $T++, 2147483647 + 2147483647, 4294967294;
# IV + UV promote to NV
tryeq $T++, 2147483647 + 2147483649, 4294967296;
# UV + IV promote to NV
tryeq $T++, 4294967294 + 2, 4294967296;
# UV + UV promote to NV
tryeq $T++, 4294967295 + 4294967295, 8589934590;
# UV + IV to IV
tryeq $T++, 2147483648 + -1, 2147483647;
tryeq $T++, 2147483650 + -10, 2147483640;
# IV + UV to IV
tryeq $T++, -1 + 2147483648, 2147483647;
tryeq $T++, -10 + 4294967294, 4294967284;
# IV + IV to NV
tryeq $T++, -2147483648 + -2147483648, -4294967296;
tryeq $T++, -2147483640 + -10, -2147483650;
# Hmm. Don't forget the simple stuff
tryeq $T++, 1 + 1, 2;
tryeq $T++, 4 + -2, 2;
tryeq $T++, -10 + 100, 90;
tryeq $T++, -7 + -9, -16;
tryeq $T++, -63 + +2, -61;
tryeq $T++, 4 + -1, 3;
tryeq $T++, -1 + 1, 0;
tryeq $T++, +29 + -29, 0;
tryeq $T++, -1 + 4, 3;
tryeq $T++, +4 + -17, -13;
# subtraction
tryeq $T++, 3 - 1, 2;
tryeq $T++, 3 - 15, -12;
tryeq $T++, 3 - -7, 10;
tryeq $T++, -156 - 5, -161;
tryeq $T++, -156 - -5, -151;
tryeq $T++, -5 - -12, 7;
tryeq $T++, -3 - -3, 0;
tryeq $T++, 15 - 15, 0;
tryeq $T++, 2147483647 - 0, 2147483647;
tryeq $T++, 2147483648 - 0, 2147483648;
tryeq $T++, -2147483648 - 0, -2147483648;
tryeq $T++, 0 - -2147483647, 2147483647;
tryeq $T++, -1 - -2147483648, 2147483647;
tryeq $T++, 2 - -2147483648, 2147483650;
tryeq $T++, 4294967294 - 3, 4294967291;
tryeq $T++, -2147483648 - -1, -2147483647;
# IV - IV promote to UV
tryeq $T++, 2147483647 - -1, 2147483648;
tryeq $T++, 2147483647 - -2147483648, 4294967295;
# UV - IV promote to NV
tryeq $T++, 4294967294 - -3, 4294967297;
# IV - IV promote to NV
tryeq $T++, -2147483648 - +1, -2147483649;
# UV - UV promote to IV
tryeq $T++, 2147483648 - 2147483650, -2;
# IV - UV promote to IV
tryeq $T++, 2000000000 - 4000000000, -2000000000;
# No warnings should appear;
my $a;
$a += 1;
tryeq $T++, $a, 1;
undef $a;
$a += -1;
tryeq $T++, $a, -1;
undef $a;
$a += 4294967290;
tryeq $T++, $a, 4294967290;
undef $a;
$a += -4294967290;
tryeq $T++, $a, -4294967290;
undef $a;
$a += 4294967297;
tryeq $T++, $a, 4294967297;
undef $a;
$a += -4294967297;
tryeq $T++, $a, -4294967297;
my $s;
$s -= 1;
tryeq $T++, $s, -1;
undef $s;
$s -= -1;
tryeq $T++, $s, +1;
undef $s;
$s -= -4294967290;
tryeq $T++, $s, +4294967290;
undef $s;
$s -= 4294967290;
tryeq $T++, $s, -4294967290;
undef $s;
$s -= 4294967297;
tryeq $T++, $s, -4294967297;
undef $s;
$s -= -4294967297;
tryeq $T++, $s, +4294967297;
# Multiplication
tryeq $T++, 1 * 3, 3;
tryeq $T++, -2 * 3, -6;
tryeq $T++, 3 * -3, -9;
tryeq $T++, -4 * -3, 12;
# check with 0xFFFF and 0xFFFF
tryeq $T++, 65535 * 65535, 4294836225;
tryeq $T++, 65535 * -65535, -4294836225;
tryeq $T++, -65535 * 65535, -4294836225;
tryeq $T++, -65535 * -65535, 4294836225;
# check with 0xFFFF and 0x10001
tryeq $T++, 65535 * 65537, 4294967295;
tryeq $T++, 65535 * -65537, -4294967295;
tryeq $T++, -65535 * 65537, -4294967295;
tryeq $T++, -65535 * -65537, 4294967295;
# check with 0x10001 and 0xFFFF
tryeq $T++, 65537 * 65535, 4294967295;
tryeq $T++, 65537 * -65535, -4294967295;
tryeq $T++, -65537 * 65535, -4294967295;
tryeq $T++, -65537 * -65535, 4294967295;
# These should all be dones as NVs
tryeq $T++, 65537 * 65537, 4295098369;
tryeq $T++, 65537 * -65537, -4295098369;
tryeq $T++, -65537 * 65537, -4295098369;
tryeq $T++, -65537 * -65537, 4295098369;
# will overflow an IV (in 32-bit)
tryeq $T++, 46340 * 46342, 0x80001218;
tryeq $T++, 46340 * -46342, -0x80001218;
tryeq $T++, -46340 * 46342, -0x80001218;
tryeq $T++, -46340 * -46342, 0x80001218;
tryeq $T++, 46342 * 46340, 0x80001218;
tryeq $T++, 46342 * -46340, -0x80001218;
tryeq $T++, -46342 * 46340, -0x80001218;
tryeq $T++, -46342 * -46340, 0x80001218;
# will overflow a positive IV (in 32-bit)
tryeq $T++, 65536 * 32768, 0x80000000;
tryeq $T++, 65536 * -32768, -0x80000000;
tryeq $T++, -65536 * 32768, -0x80000000;
tryeq $T++, -65536 * -32768, 0x80000000;
tryeq $T++, 32768 * 65536, 0x80000000;
tryeq $T++, 32768 * -65536, -0x80000000;
tryeq $T++, -32768 * 65536, -0x80000000;
tryeq $T++, -32768 * -65536, 0x80000000;
# 2147483647 is prime. bah.
tryeq $T++, 46339 * 46341, 0x7ffea80f;
tryeq $T++, 46339 * -46341, -0x7ffea80f;
tryeq $T++, -46339 * 46341, -0x7ffea80f;
tryeq $T++, -46339 * -46341, 0x7ffea80f;
# leading space should be ignored
tryeq $T++, 1 + " 1", 2;
tryeq $T++, 3 + " -1", 2;
tryeq $T++, 1.2, " 1.2";
tryeq $T++, -1.2, " -1.2";
# divide
tryeq $T++, 28/14, 2;
tryeq $T++, 28/-7, -4;
tryeq $T++, -28/4, -7;
tryeq $T++, -28/-2, 14;
tryeq $T++, 0x80000000/1, 0x80000000;
tryeq $T++, 0x80000000/-1, -0x80000000;
tryeq $T++, -0x80000000/1, -0x80000000;
tryeq $T++, -0x80000000/-1, 0x80000000;
# The example for sloppy divide, rigged to avoid the peephole optimiser.
tryeq_sloppy $T++, "20." / "5.", 4;
tryeq $T++, 2.5 / 2, 1.25;
tryeq $T++, 3.5 / -2, -1.75;
tryeq $T++, -4.5 / 2, -2.25;
tryeq $T++, -5.5 / -2, 2.75;
# Bluuurg if your floating point can't accurately cope with powers of 2
# [I suspect this is parsing string->float problems, not actual arith]
tryeq_sloppy $T++, 18446744073709551616/1, 18446744073709551616; # Bluuurg
tryeq_sloppy $T++, 18446744073709551616/2, 9223372036854775808;
tryeq_sloppy $T++, 18446744073709551616/4294967296, 4294967296;
tryeq_sloppy $T++, 18446744073709551616/9223372036854775808, 2;
{
# The peephole optimiser is wrong to think that it can substitute intops
# in place of regular ops, because i_multiply can overflow.
# Bug reported by "Sisyphus" <kalinabears at hdc.com.au>
my $n = 1127;
my $float = ($n % 1000) * 167772160.0;
tryeq_sloppy $T++, $float, 21307064320;
# On a 32 bit machine, if the i_multiply op is used, you will probably get
# -167772160. It's actually undefined behaviour, so anything may happen.
my $int = ($n % 1000) * 167772160;
tryeq $T++, $int, 21307064320;
my $t = time;
my $t1000 = time() * 1000;
try $T++, abs($t1000 -1000 * $t) <= 2000;
}
my $vms_no_ieee;
if ($^O eq 'VMS') {
use vars '%Config';
eval {require Config; import Config};
$vms_no_ieee = 1 unless defined($Config{useieee});
}
if ($^O eq 'vos') {
print "not ok ", $T++, " # TODO VOS raises SIGFPE instead of producing infinity.\n";
}
elsif ($vms_no_ieee) {
print $T++, " # SKIP -- the IEEE infinity model is unavailable in this configuration.\n"
}
elsif ($^O eq 'ultrix') {
print "not ok ", $T++, " # TODO Ultrix enters deep nirvana instead of producing infinity.\n";
}
else {
# The computation of $v should overflow and produce "infinity"
# on any system whose max exponent is less than 10**1506.
# The exact string used to represent infinity varies by OS,
# so we don't test for it; all we care is that we don't die.
#
# Perl considers it to be an error if SIGFPE is raised.
# Chances are the interpreter will die, since it doesn't set
# up a handler for SIGFPE. That's why this test is last; to
# minimize the number of test failures. --PG
my $n = 5000;
my $v = 2;
while (--$n)
{
$v *= 2;
}
print "ok ", $T++, "\n";
}
--- NEW FILE: taint.t ---
#!./perl -T
#
# Taint tests by Tom Phoenix <rootbeer at teleport.com>.
#
# I don't claim to know all about tainting. If anyone sees
# tests that I've missed here, please add them. But this is
# better than having no tests at all, right?
#
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use strict;
use Config;
use File::Spec::Functions;
BEGIN { require './test.pl'; }
[...1069 lines suppressed...]
{
# rt.perl.org 5900 $1 remains tainted if...
# 1) The regular expression contains a scalar variable AND
# 2) The regular expression appears in an elsif clause
my $foo = "abcdefghi" . $TAINT;
my $valid_chars = 'a-z';
if ( $foo eq '' ) {
}
elsif ( $foo =~ /([$valid_chars]+)/o ) {
test not tainted $1;
}
if ( $foo eq '' ) {
}
elsif ( my @bar = $foo =~ /([$valid_chars]+)/o ) {
test not any_tainted @bar;
}
}
--- NEW FILE: sort.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use warnings;
print "1..129\n";
# these shouldn't hang
{
no warnings;
sort { for ($_ = 0;; $_++) {} } @a;
sort { while(1) {} } @a;
sort { while(1) { last; } } @a;
sort { while(0) { last; } } @a;
# Change 26011: Re: A surprising segfault
map scalar(sort(+())), ('')x68;
}
sub Backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
sub Backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 }
my $upperfirst = 'A' lt 'a';
# Beware: in future this may become hairier because of possible
# collation complications: qw(A a B b) can be sorted at least as
# any of the following
#
# A a B b
# A B a b
# a b A B
# a A b B
#
# All the above orders make sense.
#
# That said, EBCDIC sorts all small letters first, as opposed
# to ASCII which sorts all big letters first.
@harry = ('dog','cat','x','Cain','Abel');
@george = ('gone','chased','yz','punished','Axed');
$x = join('', sort @harry);
$expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain';
print "# 1: x = '$x', expected = '$expected'\n";
print ($x eq $expected ? "ok 1\n" : "not ok 1\n");
$x = join('', sort( Backwards @harry));
$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
print "# 2: x = '$x', expected = '$expected'\n";
print ($x eq $expected ? "ok 2\n" : "not ok 2\n");
$x = join('', sort( Backwards_stacked @harry));
$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
print "# 3: x = '$x', expected = '$expected'\n";
print ($x eq $expected ? "ok 3\n" : "not ok 3\n");
$x = join('', sort @george, 'to', @harry);
$expected = $upperfirst ?
'AbelAxedCaincatchaseddoggonepunishedtoxyz' :
'catchaseddoggonepunishedtoxyzAbelAxedCain' ;
print "# 4: x = '$x', expected = '$expected'\n";
print ($x eq $expected ?"ok 4\n":"not ok 4\n");
@a = ();
@b = reverse @a;
print ("@b" eq "" ? "ok 5\n" : "not ok 5 (@b)\n");
@a = (1);
@b = reverse @a;
print ("@b" eq "1" ? "ok 6\n" : "not ok 6 (@b)\n");
@a = (1,2);
@b = reverse @a;
print ("@b" eq "2 1" ? "ok 7\n" : "not ok 7 (@b)\n");
@a = (1,2,3);
@b = reverse @a;
print ("@b" eq "3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n");
@a = (1,2,3,4);
@b = reverse @a;
print ("@b" eq "4 3 2 1" ? "ok 9\n" : "not ok 9 (@b)\n");
@a = (10,2,3,4);
@b = sort {$a <=> $b;} @a;
print ("@b" eq "2 3 4 10" ? "ok 10\n" : "not ok 10 (@b)\n");
$sub = 'Backwards';
$x = join('', sort $sub @harry);
$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
print "# 11: x = $x, expected = '$expected'\n";
print ($x eq $expected ? "ok 11\n" : "not ok 11\n");
$sub = 'Backwards_stacked';
$x = join('', sort $sub @harry);
$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
print "# 12: x = $x, expected = '$expected'\n";
print ($x eq $expected ? "ok 12\n" : "not ok 12\n");
# literals, combinations
@b = sort (4,1,3,2);
print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n");
print "# x = '@b'\n";
@b = sort grep { $_ } (4,1,3,2);
print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n");
print "# x = '@b'\n";
@b = sort map { $_ } (4,1,3,2);
print ("@b" eq '1 2 3 4' ? "ok 15\n" : "not ok 15\n");
print "# x = '@b'\n";
@b = sort reverse (4,1,3,2);
print ("@b" eq '1 2 3 4' ? "ok 16\n" : "not ok 16\n");
print "# x = '@b'\n";
# redefining sort sub inside the sort sub should fail
sub twoface { *twoface = sub { $a <=> $b }; &twoface }
eval { @b = sort twoface 4,1,3,2 };
print ($@ =~ /redefine active sort/ ? "ok 17\n" : "not ok 17\n");
# redefining sort subs outside the sort should not fail
eval { no warnings 'redefine'; *twoface = sub { &Backwards } };
print $@ ? "not ok 18\n" : "ok 18\n";
eval { @b = sort twoface 4,1,3,2 };
print ("@b" eq '4 3 2 1' ? "ok 19\n" : "not ok 19 |@b|\n");
{
no warnings 'redefine';
*twoface = sub { *twoface = *Backwards; $a <=> $b };
}
eval { @b = sort twoface 4,1 };
print ($@ =~ /redefine active sort/ ? "ok 20\n" : "not ok 20\n");
{
no warnings 'redefine';
*twoface = sub {
eval 'sub twoface { $a <=> $b }';
die($@ =~ /redefine active sort/ ? "ok 21\n" : "not ok 21\n");
$a <=> $b;
};
}
eval { @b = sort twoface 4,1 };
print $@ ? "$@" : "not ok 21\n";
eval <<'CODE';
my @result = sort main'Backwards 'one', 'two';
CODE
print $@ ? "not ok 22\n# $@" : "ok 22\n";
eval <<'CODE';
# "sort 'one', 'two'" should not try to parse "'one" as a sort sub
my @result = sort 'one', 'two';
CODE
print $@ ? "not ok 23\n# $@" : "ok 23\n";
{
my $sortsub = \&Backwards;
my $sortglob = *Backwards;
my $sortglobr = \*Backwards;
my $sortname = 'Backwards';
@b = sort $sortsub 4,1,3,2;
print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n");
@b = sort $sortglob 4,1,3,2;
print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n");
@b = sort $sortname 4,1,3,2;
print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n");
@b = sort $sortglobr 4,1,3,2;
print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n");
}
{
my $sortsub = \&Backwards_stacked;
my $sortglob = *Backwards_stacked;
my $sortglobr = \*Backwards_stacked;
my $sortname = 'Backwards_stacked';
@b = sort $sortsub 4,1,3,2;
print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n");
@b = sort $sortglob 4,1,3,2;
print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n");
@b = sort $sortname 4,1,3,2;
print ("@b" eq '4 3 2 1' ? "ok 30\n" : "not ok 30 |@b|\n");
@b = sort $sortglobr 4,1,3,2;
print ("@b" eq '4 3 2 1' ? "ok 31\n" : "not ok 31 |@b|\n");
}
{
local $sortsub = \&Backwards;
local $sortglob = *Backwards;
local $sortglobr = \*Backwards;
local $sortname = 'Backwards';
@b = sort $sortsub 4,1,3,2;
print ("@b" eq '4 3 2 1' ? "ok 32\n" : "not ok 32 |@b|\n");
@b = sort $sortglob 4,1,3,2;
print ("@b" eq '4 3 2 1' ? "ok 33\n" : "not ok 33 |@b|\n");
@b = sort $sortname 4,1,3,2;
print ("@b" eq '4 3 2 1' ? "ok 34\n" : "not ok 34 |@b|\n");
@b = sort $sortglobr 4,1,3,2;
print ("@b" eq '4 3 2 1' ? "ok 35\n" : "not ok 35 |@b|\n");
}
{
local $sortsub = \&Backwards_stacked;
local $sortglob = *Backwards_stacked;
local $sortglobr = \*Backwards_stacked;
local $sortname = 'Backwards_stacked';
@b = sort $sortsub 4,1,3,2;
print ("@b" eq '4 3 2 1' ? "ok 36\n" : "not ok 36 |@b|\n");
@b = sort $sortglob 4,1,3,2;
print ("@b" eq '4 3 2 1' ? "ok 37\n" : "not ok 37 |@b|\n");
@b = sort $sortname 4,1,3,2;
print ("@b" eq '4 3 2 1' ? "ok 38\n" : "not ok 38 |@b|\n");
@b = sort $sortglobr 4,1,3,2;
print ("@b" eq '4 3 2 1' ? "ok 39\n" : "not ok 39 |@b|\n");
}
## exercise sort builtins... ($a <=> $b already tested)
@a = ( 5, 19, 1996, 255, 90 );
@b = sort {
my $dummy; # force blockness
return $b <=> $a
} @a;
print ("@b" eq '1996 255 90 19 5' ? "ok 40\n" : "not ok 40\n");
print "# x = '@b'\n";
$x = join('', sort { $a cmp $b } @harry);
$expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain';
print ($x eq $expected ? "ok 41\n" : "not ok 41\n");
print "# x = '$x'; expected = '$expected'\n";
$x = join('', sort { $b cmp $a } @harry);
$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
print ($x eq $expected ? "ok 42\n" : "not ok 42\n");
print "# x = '$x'; expected = '$expected'\n";
{
use integer;
@b = sort { $a <=> $b } @a;
print ("@b" eq '5 19 90 255 1996' ? "ok 43\n" : "not ok 43\n");
print "# x = '@b'\n";
@b = sort { $b <=> $a } @a;
print ("@b" eq '1996 255 90 19 5' ? "ok 44\n" : "not ok 44\n");
print "# x = '@b'\n";
$x = join('', sort { $a cmp $b } @harry);
$expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain';
print ($x eq $expected ? "ok 45\n" : "not ok 45\n");
print "# x = '$x'; expected = '$expected'\n";
$x = join('', sort { $b cmp $a } @harry);
$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
print ($x eq $expected ? "ok 46\n" : "not ok 46\n");
print "# x = '$x'; expected = '$expected'\n";
}
# test that an optimized-away comparison block doesn't take any other
# arguments away with it
$x = join('', sort { $a <=> $b } 3, 1, 2);
print $x eq "123" ? "ok 47\n" : "not ok 47\n";
# test sorting in non-main package
package Foo;
@a = ( 5, 19, 1996, 255, 90 );
@b = sort { $b <=> $a } @a;
print ("@b" eq '1996 255 90 19 5' ? "ok 48\n" : "not ok 48\n");
print "# x = '@b'\n";
@b = sort main::Backwards_stacked @a;
print ("@b" eq '90 5 255 1996 19' ? "ok 49\n" : "not ok 49\n");
print "# x = '@b'\n";
# check if context for sort arguments is handled right
$test = 49;
sub test_if_list {
my $gimme = wantarray;
print "not " unless $gimme;
++$test;
print "ok $test\n";
}
my $m = sub { $a <=> $b };
sub cxt_one { sort $m test_if_list() }
cxt_one();
sub cxt_two { sort { $a <=> $b } test_if_list() }
cxt_two();
sub cxt_three { sort &test_if_list() }
cxt_three();
sub test_if_scalar {
my $gimme = wantarray;
print "not " if $gimme or !defined($gimme);
++$test;
print "ok $test\n";
}
$m = \&test_if_scalar;
sub cxt_four { sort $m 1,2 }
@x = cxt_four();
sub cxt_five { sort { test_if_scalar($a,$b); } 1,2 }
@x = cxt_five();
sub cxt_six { sort test_if_scalar 1,2 }
@x = cxt_six();
# test against a reentrancy bug
{
package Bar;
sub compare { $a cmp $b }
sub reenter { my @force = sort compare qw/a b/ }
}
{
my($def, $init) = (0, 0);
@b = sort {
$def = 1 if defined $Bar::a;
Bar::reenter() unless $init++;
$a <=> $b
} qw/4 3 1 2/;
print ("@b" eq '1 2 3 4' ? "ok 56\n" : "not ok 56\n");
print "# x = '@b'\n";
print !$def ? "ok 57\n" : "not ok 57\n";
}
# Bug 19991001.003
{
sub routine { "one", "two" };
@a = sort(routine(1));
print "@a" eq "one two" ? "ok 58\n" : "not ok 58\n";
}
my $test = 59;
sub ok {
print "not " unless $_[0] eq $_[1];
print "ok $test - $_[2]\n";
print "#[$_[0]] ne [$_[1]]\n" unless $_[0] eq $_[1];
$test++;
}
# check for in-place optimisation of @a = sort @a
{
my ($r1,$r2, at a);
our @g;
@g = (3,2,1); $r1 = \$g[2]; @g = sort @g; $r2 = \$g[0];
ok "$r1- at g", "$r2-1 2 3", "inplace sort of global";
@a = qw(b a c); $r1 = \$a[1]; @a = sort @a; $r2 = \$a[0];
ok "$r1- at a", "$r2-a b c", "inplace sort of lexical";
@g = (2,3,1); $r1 = \$g[1]; @g = sort { $b <=> $a } @g; $r2 = \$g[0];
ok "$r1- at g", "$r2-3 2 1", "inplace reversed sort of global";
@g = (2,3,1);
$r1 = \$g[1]; @g = sort { $a<$b?1:$a>$b?-1:0 } @g; $r2 = \$g[0];
ok "$r1- at g", "$r2-3 2 1", "inplace custom sort of global";
sub mysort { $b cmp $a };
@a = qw(b c a); $r1 = \$a[1]; @a = sort mysort @a; $r2 = \$a[0];
ok "$r1- at a", "$r2-c b a", "inplace sort with function of lexical";
use Tie::Array;
my @t;
tie @t, 'Tie::StdArray';
@t = qw(b c a); @t = sort @t;
ok "@t", "a b c", "inplace sort of tied array";
@t = qw(b c a); @t = sort mysort @t;
ok "@t", "c b a", "inplace sort of tied array with function";
# [perl #29790] don't optimise @a = ('a', sort @a) !
@g = (3,2,1); @g = ('0', sort @g);
ok "@g", "0 1 2 3", "un-inplace sort of global";
@g = (3,2,1); @g = (sort(@g),'4');
ok "@g", "1 2 3 4", "un-inplace sort of global 2";
@a = qw(b a c); @a = ('x', sort @a);
ok "@a", "x a b c", "un-inplace sort of lexical";
@a = qw(b a c); @a = ((sort @a), 'x');
ok "@a", "a b c x", "un-inplace sort of lexical 2";
@g = (2,3,1); @g = ('0', sort { $b <=> $a } @g);
ok "@g", "0 3 2 1", "un-inplace reversed sort of global";
@g = (2,3,1); @g = ((sort { $b <=> $a } @g),'4');
ok "@g", "3 2 1 4", "un-inplace reversed sort of global 2";
@g = (2,3,1); @g = ('0', sort { $a<$b?1:$a>$b?-1:0 } @g);
ok "@g", "0 3 2 1", "un-inplace custom sort of global";
@g = (2,3,1); @g = ((sort { $a<$b?1:$a>$b?-1:0 } @g),'4');
ok "@g", "3 2 1 4", "un-inplace custom sort of global 2";
@a = qw(b c a); @a = ('x', sort mysort @a);
ok "@a", "x c b a", "un-inplace sort with function of lexical";
@a = qw(b c a); @a = ((sort mysort @a),'x');
ok "@a", "c b a x", "un-inplace sort with function of lexical 2";
}
# Test optimisations of reversed sorts. As we now guarantee stability by
# default, # optimisations which do not provide this are bogus.
{
package Oscalar;
use overload (qw("" stringify 0+ numify fallback 1));
sub new {
bless [$_[1], $_[2]], $_[0];
}
sub stringify { $_[0]->[0] }
sub numify { $_[0]->[1] }
}
sub generate {
my $count = 0;
map {new Oscalar $_, $count++} qw(A A A B B B C C C);
}
my @input = &generate;
my @output = sort @input;
ok join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", "Simple stable sort";
@input = &generate;
@input = sort @input;
ok join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8",
"Simple stable in place sort";
# This won't be very interesting
@input = &generate;
@output = sort {$a <=> $b} @input;
ok "@output", "A A A B B B C C C", 'stable $a <=> $b sort';
@input = &generate;
@output = sort {$a cmp $b} @input;
ok join(" ", map {0+$_} @output), "0 1 2 3 4 5 6 7 8", 'stable $a cmp $b sort';
@input = &generate;
@input = sort {$a cmp $b} @input;
ok join(" ", map {0+$_} @input), "0 1 2 3 4 5 6 7 8",
'stable $a cmp $b in place sort';
@input = &generate;
@output = sort {$b cmp $a} @input;
ok join(" ", map {0+$_} @output), "6 7 8 3 4 5 0 1 2", 'stable $b cmp $a sort';
@input = &generate;
@input = sort {$b cmp $a} @input;
ok join(" ", map {0+$_} @input), "6 7 8 3 4 5 0 1 2",
'stable $b cmp $a in place sort';
@input = &generate;
@output = reverse sort @input;
ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0", "Reversed stable sort";
@input = &generate;
@input = reverse sort @input;
ok join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
"Reversed stable in place sort";
@input = &generate;
my $output = reverse sort @input;
ok $output, "CCCBBBAAA", "Reversed stable sort in scalar context";
@input = &generate;
@output = reverse sort {$a cmp $b} @input;
ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
'reversed stable $a cmp $b sort';
@input = &generate;
@input = reverse sort {$a cmp $b} @input;
ok join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
'revesed stable $a cmp $b in place sort';
@input = &generate;
$output = reverse sort {$a cmp $b} @input;
ok $output, "CCCBBBAAA", 'Reversed stable $a cmp $b sort in scalar context';
@input = &generate;
@output = reverse sort {$b cmp $a} @input;
ok join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6",
'reversed stable $b cmp $a sort';
@input = &generate;
@input = reverse sort {$b cmp $a} @input;
ok join(" ", map {0+$_} @input), "2 1 0 5 4 3 8 7 6",
'revesed stable $b cmp $a in place sort';
@input = &generate;
$output = reverse sort {$b cmp $a} @input;
ok $output, "AAABBBCCC", 'Reversed stable $b cmp $a sort in scalar context';
sub stuff {
# Something complex enough to defeat any constant folding optimiser
$$ - $$;
}
@input = &generate;
@output = reverse sort {stuff || $a cmp $b} @input;
ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
'reversed stable complex sort';
@input = &generate;
@input = reverse sort {stuff || $a cmp $b} @input;
ok join(" ", map {0+$_} @input), "8 7 6 5 4 3 2 1 0",
'revesed stable complex in place sort';
@input = &generate;
$output = reverse sort {stuff || $a cmp $b } @input;
ok $output, "CCCBBBAAA", 'Reversed stable complex sort in scalar context';
sub sortr {
reverse sort @_;
}
@output = sortr &generate;
ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
'reversed stable sort return list context';
$output = sortr &generate;
ok $output, "CCCBBBAAA",
'reversed stable sort return scalar context';
sub sortcmpr {
reverse sort {$a cmp $b} @_;
}
@output = sortcmpr &generate;
ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
'reversed stable $a cmp $b sort return list context';
$output = sortcmpr &generate;
ok $output, "CCCBBBAAA",
'reversed stable $a cmp $b sort return scalar context';
sub sortcmprba {
reverse sort {$b cmp $a} @_;
}
@output = sortcmprba &generate;
ok join(" ", map {0+$_} @output), "2 1 0 5 4 3 8 7 6",
'reversed stable $b cmp $a sort return list context';
$output = sortcmprba &generate;
ok $output, "AAABBBCCC",
'reversed stable $b cmp $a sort return scalar context';
sub sortcmprq {
reverse sort {stuff || $a cmp $b} @_;
}
@output = sortcmpr &generate;
ok join(" ", map {0+$_} @output), "8 7 6 5 4 3 2 1 0",
'reversed stable complex sort return list context';
$output = sortcmpr &generate;
ok $output, "CCCBBBAAA",
'reversed stable complex sort return scalar context';
# And now with numbers
sub generate1 {
my $count = 'A';
map {new Oscalar $count++, $_} 0, 0, 0, 1, 1, 1, 2, 2, 2;
}
# This won't be very interesting
@input = &generate1;
@output = sort {$a cmp $b} @input;
ok "@output", "A B C D E F G H I", 'stable $a cmp $b sort';
@input = &generate1;
@output = sort {$a <=> $b} @input;
ok "@output", "A B C D E F G H I", 'stable $a <=> $b sort';
@input = &generate1;
@input = sort {$a <=> $b} @input;
ok "@input", "A B C D E F G H I", 'stable $a <=> $b in place sort';
@input = &generate1;
@output = sort {$b <=> $a} @input;
ok "@output", "G H I D E F A B C", 'stable $b <=> $a sort';
@input = &generate1;
@input = sort {$b <=> $a} @input;
ok "@input", "G H I D E F A B C", 'stable $b <=> $a in place sort';
# test that optimized {$b cmp $a} and {$b <=> $a} remain stable
# (new in 5.9) without overloading
{ no warnings;
@b = sort { $b <=> $a } @input = qw/5first 6first 5second 6second/;
ok "@b" , "6first 6second 5first 5second", "optimized {$b <=> $a} without overloading" ;
@input = sort {$b <=> $a} @input;
ok "@input" , "6first 6second 5first 5second","inline optimized {$b <=> $a} without overloading" ;
};
# These two are actually doing string cmp on 0 1 and 2
@input = &generate1;
@output = reverse sort @input;
ok "@output", "I H G F E D C B A", "Reversed stable sort";
@input = &generate1;
@input = reverse sort @input;
ok "@input", "I H G F E D C B A", "Reversed stable in place sort";
@input = &generate1;
$output = reverse sort @input;
ok $output, "IHGFEDCBA", "Reversed stable sort in scalar context";
@input = &generate1;
@output = reverse sort {$a <=> $b} @input;
ok "@output", "I H G F E D C B A", 'reversed stable $a <=> $b sort';
@input = &generate1;
@input = reverse sort {$a <=> $b} @input;
ok "@input", "I H G F E D C B A", 'revesed stable $a <=> $b in place sort';
@input = &generate1;
$output = reverse sort {$a <=> $b} @input;
ok $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort in scalar context';
@input = &generate1;
@output = reverse sort {$b <=> $a} @input;
ok "@output", "C B A F E D I H G", 'reversed stable $b <=> $a sort';
@input = &generate1;
@input = reverse sort {$b <=> $a} @input;
ok "@input", "C B A F E D I H G", 'revesed stable $b <=> $a in place sort';
@input = &generate1;
$output = reverse sort {$b <=> $a} @input;
ok $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort in scalar context';
@input = &generate1;
@output = reverse sort {stuff || $a <=> $b} @input;
ok "@output", "I H G F E D C B A", 'reversed stable complex sort';
@input = &generate1;
@input = reverse sort {stuff || $a <=> $b} @input;
ok "@input", "I H G F E D C B A", 'revesed stable complex in place sort';
@input = &generate1;
$output = reverse sort {stuff || $a <=> $b} @input;
ok $output, "IHGFEDCBA", 'reversed stable complex sort in scalar context';
sub sortnumr {
reverse sort {$a <=> $b} @_;
}
@output = sortnumr &generate1;
ok "@output", "I H G F E D C B A",
'reversed stable $a <=> $b sort return list context';
$output = sortnumr &generate1;
ok $output, "IHGFEDCBA", 'reversed stable $a <=> $b sort return scalar context';
sub sortnumrba {
reverse sort {$b <=> $a} @_;
}
@output = sortnumrba &generate1;
ok "@output", "C B A F E D I H G",
'reversed stable $b <=> $a sort return list context';
$output = sortnumrba &generate1;
ok $output, "CBAFEDIHG", 'reversed stable $b <=> $a sort return scalar context';
sub sortnumrq {
reverse sort {stuff || $a <=> $b} @_;
}
@output = sortnumrq &generate1;
ok "@output", "I H G F E D C B A",
'reversed stable complex sort return list context';
$output = sortnumrq &generate1;
ok $output, "IHGFEDCBA", 'reversed stable complex sort return scalar context';
@output = reverse (sort(qw(C A B)), 0);
ok "@output", "0 C B A", 'reversed sort with trailing argument';
@output = reverse (0, sort(qw(C A B)));
ok "@output", "C B A 0", 'reversed sort with leading argument';
--- NEW FILE: substr.t ---
#!./perl -w
#P = start of string Q = start of substr R = end of substr S = end of string
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use warnings ;
$a = 'abcdefxyz';
$SIG{__WARN__} = sub {
if ($_[0] =~ /^substr outside of string/) {
$w++;
} elsif ($_[0] =~ /^Attempt to use reference as lvalue in substr/) {
$w += 2;
} elsif ($_[0] =~ /^Use of uninitialized value/) {
$w += 3;
} else {
warn $_[0];
}
};
require './test.pl';
plan(325);
$FATAL_MSG = qr/^substr outside of string/;
is(substr($a,0,3), 'abc'); # P=Q R S
is(substr($a,3,3), 'def'); # P Q R S
is(substr($a,6,999), 'xyz'); # P Q S R
$b = substr($a,999,999) ; # warn # P R Q S
is ($w--, 1);
eval{substr($a,999,999) = "" ; };# P R Q S
like ($@, $FATAL_MSG);
is(substr($a,0,-6), 'abc'); # P=Q R S
is(substr($a,-3,1), 'x'); # P Q R S
$[ = 1;
is(substr($a,1,3), 'abc' ); # P=Q R S
is(substr($a,4,3), 'def' ); # P Q R S
is(substr($a,7,999), 'xyz');# P Q S R
$b = substr($a,999,999) ; # warn # P R Q S
is($w--, 1);
eval{substr($a,999,999) = "" ; } ; # P R Q S
like ($@, $FATAL_MSG);
is(substr($a,1,-6), 'abc' );# P=Q R S
is(substr($a,-3,1), 'x' ); # P Q R S
$[ = 0;
substr($a,3,3) = 'XYZ';
is($a, 'abcXYZxyz' );
substr($a,0,2) = '';
is($a, 'cXYZxyz' );
substr($a,0,0) = 'ab';
is($a, 'abcXYZxyz' );
substr($a,0,0) = '12345678';
is($a, '12345678abcXYZxyz' );
substr($a,-3,3) = 'def';
is($a, '12345678abcXYZdef');
substr($a,-3,3) = '<';
is($a, '12345678abcXYZ<' );
substr($a,-1,1) = '12345678';
is($a, '12345678abcXYZ12345678' );
$a = 'abcdefxyz';
is(substr($a,6), 'xyz' ); # P Q R=S
is(substr($a,-3), 'xyz' ); # P Q R=S
$b = substr($a,999,999) ; # warning # P R=S Q
is($w--, 1);
eval{substr($a,999,999) = "" ; } ; # P R=S Q
like($@, $FATAL_MSG);
is(substr($a,0), 'abcdefxyz'); # P=Q R=S
is(substr($a,9), ''); # P Q=R=S
is(substr($a,-11), 'abcdefxyz'); # Q P R=S
is(substr($a,-9), 'abcdefxyz'); # P=Q R=S
$a = '54321';
$b = substr($a,-7, 1) ; # warn # Q R P S
is($w--, 1);
eval{substr($a,-7, 1) = "" ; }; # Q R P S
like($@, $FATAL_MSG);
$b = substr($a,-7,-6) ; # warn # Q R P S
is($w--, 1);
eval{substr($a,-7,-6) = "" ; }; # Q R P S
like($@, $FATAL_MSG);
is(substr($a,-5,-7), ''); # R P=Q S
is(substr($a, 2,-7), ''); # R P Q S
is(substr($a,-3,-7), ''); # R P Q S
is(substr($a, 2,-5), ''); # P=R Q S
is(substr($a,-3,-5), ''); # P=R Q S
is(substr($a, 2,-4), ''); # P R Q S
is(substr($a,-3,-4), ''); # P R Q S
is(substr($a, 5,-6), ''); # R P Q=S
is(substr($a, 5,-5), ''); # P=R Q S
is(substr($a, 5,-3), ''); # P R Q=S
$b = substr($a, 7,-7) ; # warn # R P S Q
is($w--, 1);
eval{substr($a, 7,-7) = "" ; }; # R P S Q
like($@, $FATAL_MSG);
$b = substr($a, 7,-5) ; # warn # P=R S Q
is($w--, 1);
eval{substr($a, 7,-5) = "" ; }; # P=R S Q
like($@, $FATAL_MSG);
$b = substr($a, 7,-3) ; # warn # P Q S Q
is($w--, 1);
eval{substr($a, 7,-3) = "" ; }; # P Q S Q
like($@, $FATAL_MSG);
$b = substr($a, 7, 0) ; # warn # P S Q=R
is($w--, 1);
eval{substr($a, 7, 0) = "" ; }; # P S Q=R
like($@, $FATAL_MSG);
is(substr($a,-7,2), ''); # Q P=R S
is(substr($a,-7,4), '54'); # Q P R S
is(substr($a,-7,7), '54321');# Q P R=S
is(substr($a,-7,9), '54321');# Q P S R
is(substr($a,-5,0), ''); # P=Q=R S
is(substr($a,-5,3), '543');# P=Q R S
is(substr($a,-5,5), '54321');# P=Q R=S
is(substr($a,-5,7), '54321');# P=Q S R
is(substr($a,-3,0), ''); # P Q=R S
is(substr($a,-3,3), '321');# P Q R=S
is(substr($a,-2,3), '21'); # P Q S R
is(substr($a,0,-5), ''); # P=Q=R S
is(substr($a,2,-3), ''); # P Q=R S
is(substr($a,0,0), ''); # P=Q=R S
is(substr($a,0,5), '54321');# P=Q R=S
is(substr($a,0,7), '54321');# P=Q S R
is(substr($a,2,0), ''); # P Q=R S
is(substr($a,2,3), '321'); # P Q R=S
is(substr($a,5,0), ''); # P Q=R=S
is(substr($a,5,2), ''); # P Q=S R
is(substr($a,-7,-5), ''); # Q P=R S
is(substr($a,-7,-2), '543');# Q P R S
is(substr($a,-5,-5), ''); # P=Q=R S
is(substr($a,-5,-2), '543');# P=Q R S
is(substr($a,-3,-3), ''); # P Q=R S
is(substr($a,-3,-1), '32');# P Q R S
$a = '';
is(substr($a,-2,2), ''); # Q P=R=S
is(substr($a,0,0), ''); # P=Q=R=S
is(substr($a,0,1), ''); # P=Q=S R
is(substr($a,-2,3), ''); # Q P=S R
is(substr($a,-2), ''); # Q P=R=S
is(substr($a,0), ''); # P=Q=R=S
is(substr($a,0,-1), ''); # R P=Q=S
$b = substr($a,-2, 0) ; # warn # Q=R P=S
is($w--, 1);
eval{substr($a,-2, 0) = "" ; }; # Q=R P=S
like($@, $FATAL_MSG);
$b = substr($a,-2, 1) ; # warn # Q R P=S
is($w--, 1);
eval{substr($a,-2, 1) = "" ; }; # Q R P=S
like($@, $FATAL_MSG);
$b = substr($a,-2,-1) ; # warn # Q R P=S
is($w--, 1);
eval{substr($a,-2,-1) = "" ; }; # Q R P=S
like($@, $FATAL_MSG);
$b = substr($a,-2,-2) ; # warn # Q=R P=S
is($w--, 1);
eval{substr($a,-2,-2) = "" ; }; # Q=R P=S
like($@, $FATAL_MSG);
$b = substr($a, 1,-2) ; # warn # R P=S Q
is($w--, 1);
eval{substr($a, 1,-2) = "" ; }; # R P=S Q
like($@, $FATAL_MSG);
$b = substr($a, 1, 1) ; # warn # P=S Q R
is($w--, 1);
eval{substr($a, 1, 1) = "" ; }; # P=S Q R
like($@, $FATAL_MSG);
$b = substr($a, 1, 0) ;# warn # P=S Q=R
is($w--, 1);
eval{substr($a, 1, 0) = "" ; }; # P=S Q=R
like($@, $FATAL_MSG);
$b = substr($a,1) ; # warning # P=R=S Q
is($w--, 1);
eval{substr($a,1) = "" ; }; # P=R=S Q
like($@, $FATAL_MSG);
my $a = 'zxcvbnm';
substr($a,2,0) = '';
is($a, 'zxcvbnm');
substr($a,7,0) = '';
is($a, 'zxcvbnm');
substr($a,5,0) = '';
is($a, 'zxcvbnm');
substr($a,0,2) = 'pq';
is($a, 'pqcvbnm');
substr($a,2,0) = 'r';
is($a, 'pqrcvbnm');
substr($a,8,0) = 'asd';
is($a, 'pqrcvbnmasd');
substr($a,0,2) = 'iop';
is($a, 'ioprcvbnmasd');
substr($a,0,5) = 'fgh';
is($a, 'fghvbnmasd');
substr($a,3,5) = 'jkl';
is($a, 'fghjklsd');
substr($a,3,2) = '1234';
is($a, 'fgh1234lsd');
# with lexicals (and in re-entered scopes)
for (0,1) {
my $txt;
unless ($_) {
$txt = "Foo";
substr($txt, -1) = "X";
is($txt, "FoX");
}
else {
substr($txt, 0, 1) = "X";
is($txt, "X");
}
}
$w = 0 ;
# coercion of references
{
my $s = [];
substr($s, 0, 1) = 'Foo';
is (substr($s,0,7), "FooRRAY");
is ($w,2);
$w = 0;
}
# check no spurious warnings
is($w, 0);
# check new 4 arg replacement syntax
$a = "abcxyz";
$w = 0;
is(substr($a, 0, 3, ""), "abc");
is($a, "xyz");
is(substr($a, 0, 0, "abc"), "");
is($a, "abcxyz");
is(substr($a, 3, -1, ""), "xy");
is($a, "abcz");
is(substr($a, 3, undef, "xy"), "");
is($a, "abcxyz");
is($w, 3);
$w = 0;
is(substr($a, 3, 9999999, ""), "xyz");
is($a, "abc");
eval{substr($a, -99, 0, "") };
like($@, $FATAL_MSG);
eval{substr($a, 99, 3, "") };
like($@, $FATAL_MSG);
substr($a, 0, length($a), "foo");
is ($a, "foo");
is ($w, 0);
# using 4 arg substr as lvalue is a compile time error
eval 'substr($a,0,0,"") = "abc"';
like ($@, qr/Can't modify substr/);
is ($a, "foo");
$a = "abcdefgh";
is(sub { shift }->(substr($a, 0, 4, "xxxx")), 'abcd');
is($a, 'xxxxefgh');
{
my $y = 10;
$y = "2" . $y;
is ($y, 210);
}
# utf8 sanity
{
my $x = substr("a\x{263a}b",0);
is(length($x), 3);
$x = substr($x,1,1);
is($x, "\x{263a}");
$x = $x x 2;
is(length($x), 2);
substr($x,0,1) = "abcd";
is($x, "abcd\x{263a}");
is(length($x), 5);
$x = reverse $x;
is(length($x), 5);
is($x, "\x{263a}dcba");
my $z = 10;
$z = "21\x{263a}" . $z;
is(length($z), 5);
is($z, "21\x{263a}10");
}
# replacement should work on magical values
require Tie::Scalar;
my %data;
tie $data{'a'}, 'Tie::StdScalar'; # makes $data{'a'} magical
$data{a} = "firstlast";
is(substr($data{'a'}, 0, 5, ""), "first");
is($data{'a'}, "last");
# more utf8
# The following two originally from Ignasi Roca.
$x = "\xF1\xF2\xF3";
substr($x, 0, 1) = "\x{100}"; # Ignasi had \x{FF}
is(length($x), 3);
is($x, "\x{100}\xF2\xF3");
is(substr($x, 0, 1), "\x{100}");
is(substr($x, 1, 1), "\x{F2}");
is(substr($x, 2, 1), "\x{F3}");
$x = "\xF1\xF2\xF3";
substr($x, 0, 1) = "\x{100}\x{FF}"; # Ignasi had \x{FF}
is(length($x), 4);
is($x, "\x{100}\x{FF}\xF2\xF3");
is(substr($x, 0, 1), "\x{100}");
is(substr($x, 1, 1), "\x{FF}");
is(substr($x, 2, 1), "\x{F2}");
is(substr($x, 3, 1), "\x{F3}");
# more utf8 lval exercise
$x = "\xF1\xF2\xF3";
substr($x, 0, 2) = "\x{100}\xFF";
is(length($x), 3);
is($x, "\x{100}\xFF\xF3");
is(substr($x, 0, 1), "\x{100}");
is(substr($x, 1, 1), "\x{FF}");
is(substr($x, 2, 1), "\x{F3}");
$x = "\xF1\xF2\xF3";
substr($x, 1, 1) = "\x{100}\xFF";
is(length($x), 4);
is($x, "\xF1\x{100}\xFF\xF3");
is(substr($x, 0, 1), "\x{F1}");
is(substr($x, 1, 1), "\x{100}");
is(substr($x, 2, 1), "\x{FF}");
is(substr($x, 3, 1), "\x{F3}");
$x = "\xF1\xF2\xF3";
substr($x, 2, 1) = "\x{100}\xFF";
is(length($x), 4);
is($x, "\xF1\xF2\x{100}\xFF");
is(substr($x, 0, 1), "\x{F1}");
is(substr($x, 1, 1), "\x{F2}");
is(substr($x, 2, 1), "\x{100}");
is(substr($x, 3, 1), "\x{FF}");
$x = "\xF1\xF2\xF3";
substr($x, 3, 1) = "\x{100}\xFF";
is(length($x), 5);
is($x, "\xF1\xF2\xF3\x{100}\xFF");
is(substr($x, 0, 1), "\x{F1}");
is(substr($x, 1, 1), "\x{F2}");
is(substr($x, 2, 1), "\x{F3}");
is(substr($x, 3, 1), "\x{100}");
is(substr($x, 4, 1), "\x{FF}");
$x = "\xF1\xF2\xF3";
substr($x, -1, 1) = "\x{100}\xFF";
is(length($x), 4);
is($x, "\xF1\xF2\x{100}\xFF");
is(substr($x, 0, 1), "\x{F1}");
is(substr($x, 1, 1), "\x{F2}");
is(substr($x, 2, 1), "\x{100}");
is(substr($x, 3, 1), "\x{FF}");
$x = "\xF1\xF2\xF3";
substr($x, -1, 0) = "\x{100}\xFF";
is(length($x), 5);
is($x, "\xF1\xF2\x{100}\xFF\xF3");
is(substr($x, 0, 1), "\x{F1}");
is(substr($x, 1, 1), "\x{F2}");
is(substr($x, 2, 1), "\x{100}");
is(substr($x, 3, 1), "\x{FF}");
is(substr($x, 4, 1), "\x{F3}");
$x = "\xF1\xF2\xF3";
substr($x, 0, -1) = "\x{100}\xFF";
is(length($x), 3);
is($x, "\x{100}\xFF\xF3");
is(substr($x, 0, 1), "\x{100}");
is(substr($x, 1, 1), "\x{FF}");
is(substr($x, 2, 1), "\x{F3}");
$x = "\xF1\xF2\xF3";
substr($x, 0, -2) = "\x{100}\xFF";
is(length($x), 4);
is($x, "\x{100}\xFF\xF2\xF3");
is(substr($x, 0, 1), "\x{100}");
is(substr($x, 1, 1), "\x{FF}");
is(substr($x, 2, 1), "\x{F2}");
is(substr($x, 3, 1), "\x{F3}");
$x = "\xF1\xF2\xF3";
substr($x, 0, -3) = "\x{100}\xFF";
is(length($x), 5);
is($x, "\x{100}\xFF\xF1\xF2\xF3");
is(substr($x, 0, 1), "\x{100}");
is(substr($x, 1, 1), "\x{FF}");
is(substr($x, 2, 1), "\x{F1}");
is(substr($x, 3, 1), "\x{F2}");
is(substr($x, 4, 1), "\x{F3}");
$x = "\xF1\xF2\xF3";
substr($x, 1, -1) = "\x{100}\xFF";
is(length($x), 4);
is($x, "\xF1\x{100}\xFF\xF3");
is(substr($x, 0, 1), "\x{F1}");
is(substr($x, 1, 1), "\x{100}");
is(substr($x, 2, 1), "\x{FF}");
is(substr($x, 3, 1), "\x{F3}");
$x = "\xF1\xF2\xF3";
substr($x, -1, -1) = "\x{100}\xFF";
is(length($x), 5);
is($x, "\xF1\xF2\x{100}\xFF\xF3");
is(substr($x, 0, 1), "\x{F1}");
is(substr($x, 1, 1), "\x{F2}");
is(substr($x, 2, 1), "\x{100}");
is(substr($x, 3, 1), "\x{FF}");
is(substr($x, 4, 1), "\x{F3}");
# And tests for already-UTF8 one
$x = "\x{101}\x{F2}\x{F3}";
substr($x, 0, 1) = "\x{100}";
is(length($x), 3);
is($x, "\x{100}\xF2\xF3");
is(substr($x, 0, 1), "\x{100}");
is(substr($x, 1, 1), "\x{F2}");
is(substr($x, 2, 1), "\x{F3}");
$x = "\x{101}\x{F2}\x{F3}";
substr($x, 0, 1) = "\x{100}\x{FF}";
is(length($x), 4);
is($x, "\x{100}\x{FF}\xF2\xF3");
is(substr($x, 0, 1), "\x{100}");
is(substr($x, 1, 1), "\x{FF}");
is(substr($x, 2, 1), "\x{F2}");
is(substr($x, 3, 1), "\x{F3}");
$x = "\x{101}\x{F2}\x{F3}";
substr($x, 0, 2) = "\x{100}\xFF";
is(length($x), 3);
is($x, "\x{100}\xFF\xF3");
is(substr($x, 0, 1), "\x{100}");
is(substr($x, 1, 1), "\x{FF}");
is(substr($x, 2, 1), "\x{F3}");
$x = "\x{101}\x{F2}\x{F3}";
substr($x, 1, 1) = "\x{100}\xFF";
is(length($x), 4);
is($x, "\x{101}\x{100}\xFF\xF3");
is(substr($x, 0, 1), "\x{101}");
is(substr($x, 1, 1), "\x{100}");
is(substr($x, 2, 1), "\x{FF}");
is(substr($x, 3, 1), "\x{F3}");
$x = "\x{101}\x{F2}\x{F3}";
substr($x, 2, 1) = "\x{100}\xFF";
is(length($x), 4);
is($x, "\x{101}\xF2\x{100}\xFF");
is(substr($x, 0, 1), "\x{101}");
is(substr($x, 1, 1), "\x{F2}");
is(substr($x, 2, 1), "\x{100}");
is(substr($x, 3, 1), "\x{FF}");
$x = "\x{101}\x{F2}\x{F3}";
substr($x, 3, 1) = "\x{100}\xFF";
is(length($x), 5);
is($x, "\x{101}\x{F2}\x{F3}\x{100}\xFF");
is(substr($x, 0, 1), "\x{101}");
is(substr($x, 1, 1), "\x{F2}");
is(substr($x, 2, 1), "\x{F3}");
is(substr($x, 3, 1), "\x{100}");
is(substr($x, 4, 1), "\x{FF}");
$x = "\x{101}\x{F2}\x{F3}";
substr($x, -1, 1) = "\x{100}\xFF";
is(length($x), 4);
is($x, "\x{101}\xF2\x{100}\xFF");
is(substr($x, 0, 1), "\x{101}");
is(substr($x, 1, 1), "\x{F2}");
is(substr($x, 2, 1), "\x{100}");
is(substr($x, 3, 1), "\x{FF}");
$x = "\x{101}\x{F2}\x{F3}";
substr($x, -1, 0) = "\x{100}\xFF";
is(length($x), 5);
is($x, "\x{101}\xF2\x{100}\xFF\xF3");
is(substr($x, 0, 1), "\x{101}");
is(substr($x, 1, 1), "\x{F2}");
is(substr($x, 2, 1), "\x{100}");
is(substr($x, 3, 1), "\x{FF}");
is(substr($x, 4, 1), "\x{F3}");
$x = "\x{101}\x{F2}\x{F3}";
substr($x, 0, -1) = "\x{100}\xFF";
is(length($x), 3);
is($x, "\x{100}\xFF\xF3");
is(substr($x, 0, 1), "\x{100}");
is(substr($x, 1, 1), "\x{FF}");
is(substr($x, 2, 1), "\x{F3}");
$x = "\x{101}\x{F2}\x{F3}";
substr($x, 0, -2) = "\x{100}\xFF";
is(length($x), 4);
is($x, "\x{100}\xFF\xF2\xF3");
is(substr($x, 0, 1), "\x{100}");
is(substr($x, 1, 1), "\x{FF}");
is(substr($x, 2, 1), "\x{F2}");
is(substr($x, 3, 1), "\x{F3}");
$x = "\x{101}\x{F2}\x{F3}";
substr($x, 0, -3) = "\x{100}\xFF";
is(length($x), 5);
is($x, "\x{100}\xFF\x{101}\x{F2}\x{F3}");
is(substr($x, 0, 1), "\x{100}");
is(substr($x, 1, 1), "\x{FF}");
is(substr($x, 2, 1), "\x{101}");
is(substr($x, 3, 1), "\x{F2}");
is(substr($x, 4, 1), "\x{F3}");
$x = "\x{101}\x{F2}\x{F3}";
substr($x, 1, -1) = "\x{100}\xFF";
is(length($x), 4);
is($x, "\x{101}\x{100}\xFF\xF3");
is(substr($x, 0, 1), "\x{101}");
is(substr($x, 1, 1), "\x{100}");
is(substr($x, 2, 1), "\x{FF}");
is(substr($x, 3, 1), "\x{F3}");
$x = "\x{101}\x{F2}\x{F3}";
substr($x, -1, -1) = "\x{100}\xFF";
is(length($x), 5);
is($x, "\x{101}\xF2\x{100}\xFF\xF3");
is(substr($x, 0, 1), "\x{101}");
is(substr($x, 1, 1), "\x{F2}");
is(substr($x, 2, 1), "\x{100}");
is(substr($x, 3, 1), "\x{FF}");
is(substr($x, 4, 1), "\x{F3}");
substr($x = "ab", 0, 0, "\x{100}\x{200}");
is($x, "\x{100}\x{200}ab");
substr($x = "\x{100}\x{200}", 0, 0, "ab");
is($x, "ab\x{100}\x{200}");
substr($x = "ab", 1, 0, "\x{100}\x{200}");
is($x, "a\x{100}\x{200}b");
substr($x = "\x{100}\x{200}", 1, 0, "ab");
is($x, "\x{100}ab\x{200}");
substr($x = "ab", 2, 0, "\x{100}\x{200}");
is($x, "ab\x{100}\x{200}");
substr($x = "\x{100}\x{200}", 2, 0, "ab");
is($x, "\x{100}\x{200}ab");
substr($x = "\xFFb", 0, 0, "\x{100}\x{200}");
is($x, "\x{100}\x{200}\xFFb");
substr($x = "\x{100}\x{200}", 0, 0, "\xFFb");
is($x, "\xFFb\x{100}\x{200}");
substr($x = "\xFFb", 1, 0, "\x{100}\x{200}");
is($x, "\xFF\x{100}\x{200}b");
substr($x = "\x{100}\x{200}", 1, 0, "\xFFb");
is($x, "\x{100}\xFFb\x{200}");
substr($x = "\xFFb", 2, 0, "\x{100}\x{200}");
is($x, "\xFFb\x{100}\x{200}");
substr($x = "\x{100}\x{200}", 2, 0, "\xFFb");
is($x, "\x{100}\x{200}\xFFb");
# [perl #20933]
{
my $s = "ab";
my @r;
$r[$_] = \ substr $s, $_, 1 for (0, 1);
is(join("", map { $$_ } @r), "ab");
}
# [perl #23207]
{
sub ss {
substr($_[0],0,1) ^= substr($_[0],1,1) ^=
substr($_[0],0,1) ^= substr($_[0],1,1);
}
my $x = my $y = 'AB'; ss $x; ss $y;
is($x, $y);
}
# [perl #24605]
{
my $x = "0123456789\x{500}";
my $y = substr $x, 4;
is(substr($x, 7, 1), "7");
}
# [perl #24200] string corruption with lvalue sub
{
my $foo = "a";
sub bar: lvalue { substr $foo, 0 }
bar = "XXX";
is(bar, 'XXX');
$foo = '123456789';
is(bar, '123456789');
}
# [perl #29149]
{
my $text = "0123456789\xED ";
utf8::upgrade($text);
my $pos = 5;
pos($text) = $pos;
my $a = substr($text, $pos, $pos);
is(substr($text,$pos,1), $pos);
}
# [perl #23765]
{
my $a = pack("C", 0xbf);
substr($a, -1) &= chr(0xfeff);
is($a, "\xbf");
}
# [perl #34976] incorrect caching of utf8 substr length
{
my $a = "abcd\x{100}";
is(substr($a,1,2), 'bc');
is(substr($a,1,1), 'b');
}
--- NEW FILE: index.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use strict;
require './test.pl';
plan( tests => 58 );
my $foo = 'Now is the time for all good men to come to the aid of their country.';
my $first = substr($foo,0,index($foo,'the'));
is($first, "Now is ");
my $last = substr($foo,rindex($foo,'the'),100);
is($last, "their country.");
$last = substr($foo,index($foo,'Now'),2);
is($last, "No");
$last = substr($foo,rindex($foo,'Now'),2);
is($last, "No");
$last = substr($foo,index($foo,'.'),100);
is($last, ".");
$last = substr($foo,rindex($foo,'.'),100);
is($last, ".");
is(index("ababa","a",-1), 0);
is(index("ababa","a",0), 0);
is(index("ababa","a",1), 2);
is(index("ababa","a",2), 2);
is(index("ababa","a",3), 4);
is(index("ababa","a",4), 4);
is(index("ababa","a",5), -1);
is(rindex("ababa","a",-1), -1);
is(rindex("ababa","a",0), 0);
is(rindex("ababa","a",1), 0);
is(rindex("ababa","a",2), 2);
is(rindex("ababa","a",3), 2);
is(rindex("ababa","a",4), 4);
is(rindex("ababa","a",5), 4);
# tests for empty search string
is(index("abc", "", -1), 0);
is(index("abc", "", 0), 0);
is(index("abc", "", 1), 1);
is(index("abc", "", 2), 2);
is(index("abc", "", 3), 3);
is(index("abc", "", 4), 3);
is(rindex("abc", "", -1), 0);
is(rindex("abc", "", 0), 0);
is(rindex("abc", "", 1), 1);
is(rindex("abc", "", 2), 2);
is(rindex("abc", "", 3), 3);
is(rindex("abc", "", 4), 3);
$a = "foo \x{1234}bar";
is(index($a, "\x{1234}"), 4);
is(index($a, "bar", ), 5);
is(rindex($a, "\x{1234}"), 4);
is(rindex($a, "foo", ), 0);
{
my $needle = "\x{1230}\x{1270}";
my @needles = split ( //, $needle );
my $haystack = "\x{1228}\x{1228}\x{1230}\x{1270}";
foreach ( @needles ) {
my $a = index ( "\x{1228}\x{1228}\x{1230}\x{1270}", $_ );
my $b = index ( $haystack, $_ );
is($a, $b, q{[perl #22375] 'split'/'index' problem for utf8});
}
$needle = "\x{1270}\x{1230}"; # Transpose them.
@needles = split ( //, $needle );
foreach ( @needles ) {
my $a = index ( "\x{1228}\x{1228}\x{1230}\x{1270}", $_ );
my $b = index ( $haystack, $_ );
is($a, $b, q{[perl #22375] 'split'/'index' problem for utf8});
}
}
{
my $search = "foo \xc9 bar";
my $text = "a\xa3\xa3a $search $search quux";
my $text_utf8 = $text;
utf8::upgrade($text_utf8);
my $search_utf8 = $search;
utf8::upgrade($search_utf8);
is (index($text, $search), 5);
is (rindex($text, $search), 18);
is (index($text, $search_utf8), 5);
is (rindex($text, $search_utf8), 18);
is (index($text_utf8, $search), 5);
is (rindex($text_utf8, $search), 18);
is (index($text_utf8, $search_utf8), 5);
is (rindex($text_utf8, $search_utf8), 18);
my $text_octets = $text_utf8;
utf8::encode ($text_octets);
my $search_octets = $search_utf8;
utf8::encode ($search_octets);
is (index($text_octets, $search_octets), 7, "index octets, octets")
or _diag ($text_octets, $search_octets);
is (rindex($text_octets, $search_octets), 21, "rindex octets, octets");
is (index($text_octets, $search_utf8), -1);
is (rindex($text_octets, $search_utf8), -1);
is (index($text_utf8, $search_octets), -1);
is (rindex($text_utf8, $search_octets), -1);
is (index($text_octets, $search), -1);
is (rindex($text_octets, $search), -1);
is (index($text, $search_octets), -1);
is (rindex($text, $search_octets), -1);
}
--- NEW FILE: pow.t ---
#!./perl -w
# Now they'll be wanting biff! and zap! tests too.
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
# This calcualtion ought to be within 0.001 of the right answer.
my $bits_in_uv = int (0.001 + log (~0+1) / log 2);
# 3**30 < 2**48, don't trust things outside that range on a Cray
# Likewise other 3 should not overflow 48 bits if I did my sums right.
my @pow = ([ 3, 30, 1e-14],
[ 4, 32, 0],
[ 5, 20, 1e-14],
[2.5, 10, 1e-14],
[ -2, 69, 0],
[ -3, 30, 1e-14],
);
my $tests;
$tests += $_->[1] foreach @pow;
plan tests => 13 + $bits_in_uv + $tests;
# (-3)**3 gave 27 instead of -27 before change #20167.
# Let's test the other similar edge cases, too.
is((-3)**0, 1, "negative ** 0 = 1");
is((-3)**1, -3, "negative ** 1 = self");
is((-3)**2, 9, "negative ** 2 = positive");
is((-3)**3, -27, "(negative int) ** (odd power) is negative");
# Positives shouldn't be a problem
is(3**0, 1, "positive ** 0 = 1");
is(3**1, 3, "positive ** 1 = self");
is(3**2, 9, "positive ** 2 = positive");
is(3**3, 27, "(positive int) ** (odd power) is positive");
# And test order of operations while we're at it
is(-3**0, -1);
is(-3**1, -3);
is(-3**2, -9);
is(-3**3, -27);
# Ought to be 32, 64, 36 or something like that.
my $remainder = $bits_in_uv & 3;
cmp_ok ($remainder, '==', 0, 'Sanity check bits in UV calculation')
or printf "# ~0 is %d (0x%d) which gives $bits_in_uv bits\n", ~0, ~0;
# These are a lot of brute force tests to see how accurate $m ** $n is.
# Unfortunately rather a lot of perl programs expect 2 ** $n to be integer
# perfect, forgetting that it's a call to floating point pow() which never
# claims to deliver perfection.
foreach my $n (0..$bits_in_uv - 1) {
my $pow = 2 ** $n;
my $int = 1 << $n;
cmp_ok ($pow, '==', $int, "2 ** $n vs 1 << $n");
}
foreach my $pow (@pow) {
my ($base, $max, $range) = @$pow;
my $expect = 1;
foreach my $n (0..$max-1) {
my $got = $base ** $n;
within ($got, $expect, $range, "$base ** $n got[$got] expect[$expect]");
$expect *= $base;
}
}
--- NEW FILE: ref.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
}
require 'test.pl';
use strict qw(refs subs);
plan (74);
# Test glob operations.
$bar = "one";
$foo = "two";
{
local(*foo) = *bar;
is($foo, 'one');
}
is ($foo, 'two');
$baz = "three";
$foo = "four";
{
local(*foo) = 'baz';
is ($foo, 'three');
}
is ($foo, 'four');
$foo = "global";
{
local(*foo);
is ($foo, undef);
$foo = "local";
is ($foo, 'local');
}
is ($foo, 'global');
{
no strict 'refs';
# Test fake references.
$baz = "valid";
$bar = 'baz';
$foo = 'bar';
is ($$$foo, 'valid');
}
# Test real references.
$FOO = \$BAR;
$BAR = \$BAZ;
$BAZ = "hit";
is ($$$FOO, 'hit');
# Test references to real arrays.
my $test = curr_test();
@ary = ($test,$test+1,$test+2,$test+3);
$ref[0] = \@a;
$ref[1] = \@b;
$ref[2] = \@c;
$ref[3] = \@d;
for $i (3,1,2,0) {
push(@{$ref[$i]}, "ok $ary[$i]\n");
}
print @a;
print ${$ref[1]}[0];
print @{$ref[2]}[0];
{
no strict 'refs';
print @{'d'};
}
curr_test($test+4);
# Test references to references.
$refref = \\$x;
$x = "Good";
is ($$$refref, 'Good');
# Test nested anonymous lists.
$ref = [[],2,[3,4,5,]];
is (scalar @$ref, 3);
is ($$ref[1], 2);
is (${$$ref[2]}[2], 5);
is (scalar @{$$ref[0]}, 0);
is ($ref->[1], 2);
is ($ref->[2]->[0], 3);
# Test references to hashes of references.
$refref = \%whatever;
$refref->{"key"} = $ref;
is ($refref->{"key"}->[2]->[0], 3);
# Test to see if anonymous subarrays spring into existence.
$spring[5]->[0] = 123;
$spring[5]->[1] = 456;
push(@{$spring[5]}, 789);
is (join(':',@{$spring[5]}), "123:456:789");
# Test to see if anonymous subhashes spring into existence.
@{$spring2{"foo"}} = (1,2,3);
$spring2{"foo"}->[3] = 4;
is (join(':',@{$spring2{"foo"}}), "1:2:3:4");
# Test references to subroutines.
{
my $called;
sub mysub { $called++; }
$subref = \&mysub;
&$subref;
is ($called, 1);
}
$subrefref = \\&mysub2;
is ($$subrefref->("GOOD"), "good");
sub mysub2 { lc shift }
# Test the ref operator.
is (ref $subref, 'CODE');
is (ref $ref, 'ARRAY');
is (ref $refref, 'HASH');
# Test anonymous hash syntax.
$anonhash = {};
is (ref $anonhash, 'HASH');
$anonhash2 = {FOO => 'BAR', ABC => 'XYZ',};
is (join('', sort values %$anonhash2), 'BARXYZ');
# Test bless operator.
package MYHASH;
$object = bless $main'anonhash2;
main::is (ref $object, 'MYHASH');
main::is ($object->{ABC}, 'XYZ');
$object2 = bless {};
main::is (ref $object2, 'MYHASH');
# Test ordinary call on object method.
&mymethod($object,"argument");
sub mymethod {
local($THIS, @ARGS) = @_;
die 'Got a "' . ref($THIS). '" instead of a MYHASH'
unless ref $THIS eq 'MYHASH';
main::is ($ARGS[0], "argument");
main::is ($THIS->{FOO}, 'BAR');
}
# Test automatic destructor call.
$string = "bad";
$object = "foo";
$string = "good";
$main'anonhash2 = "foo";
$string = "";
DESTROY {
return unless $string;
main::is ($string, 'good');
# Test that the object has not already been "cursed".
main::isnt (ref shift, 'HASH');
}
# Now test inheritance of methods.
package OBJ;
@ISA = ('BASEOBJ');
$main'object = bless {FOO => 'foo', BAR => 'bar'};
package main;
# Test arrow-style method invocation.
is ($object->doit("BAR"), 'bar');
# Test indirect-object-style method invocation.
$foo = doit $object "FOO";
main::is ($foo, 'foo');
sub BASEOBJ'doit {
local $ref = shift;
die "Not an OBJ" unless ref $ref eq 'OBJ';
$ref->{shift()};
}
package UNIVERSAL;
@ISA = 'LASTCHANCE';
package LASTCHANCE;
sub foo { main::is ($_[1], 'works') }
package WHATEVER;
foo WHATEVER "works";
#
# test the \(@foo) construct
#
package main;
@foo = \(1..3);
@bar = \(@foo);
@baz = \(1, at foo, at bar);
is (scalar (@bar), 3);
is (scalar grep(ref($_), @bar), 3);
is (scalar (@baz), 3);
my(@fuu) = \(1..2,3);
my(@baa) = \(@fuu);
my(@bzz) = \(1, at fuu, at baa);
is (scalar (@baa), 3);
is (scalar grep(ref($_), @baa), 3);
is (scalar (@bzz), 3);
# also, it can't be an lvalue
eval '\\($x, $y) = (1, 2);';
like ($@, qr/Can\'t modify.*ref.*in.*assignment/);
# test for proper destruction of lexical objects
$test = curr_test();
sub larry::DESTROY { print "# larry\nok $test\n"; }
sub curly::DESTROY { print "# curly\nok ", $test + 1, "\n"; }
sub moe::DESTROY { print "# moe\nok ", $test + 2, "\n"; }
{
my ($joe, @curly, %larry);
my $moe = bless \$joe, 'moe';
my $curly = bless \@curly, 'curly';
my $larry = bless \%larry, 'larry';
print "# leaving block\n";
}
print "# left block\n";
curr_test($test + 3);
# another glob test
$foo = "garbage";
{ local(*bar) = "foo" }
$bar = "glob 3";
local(*bar) = *bar;
is ($bar, "glob 3");
$var = "glob 4";
$_ = \$var;
is ($$_, 'glob 4');
# test if reblessing during destruction results in more destruction
$test = curr_test();
{
package A;
sub new { bless {}, shift }
DESTROY { print "# destroying 'A'\nok ", $test + 1, "\n" }
package _B;
sub new { bless {}, shift }
DESTROY { print "# destroying '_B'\nok $test\n"; bless shift, 'A' }
package main;
my $b = _B->new;
}
curr_test($test + 2);
# test if $_[0] is properly protected in DESTROY()
{
my $test = curr_test();
my $i = 0;
local $SIG{'__DIE__'} = sub {
my $m = shift;
if ($i++ > 4) {
print "# infinite recursion, bailing\nnot ok $test\n";
exit 1;
}
like ($m, qr/^Modification of a read-only/);
};
package C;
sub new { bless {}, shift }
DESTROY { $_[0] = 'foo' }
{
print "# should generate an error...\n";
my $c = C->new;
}
print "# good, didn't recurse\n";
}
# test if refgen behaves with autoviv magic
{
my @a;
$a[1] = "good";
my $got;
for (@a) {
$got .= ${\$_};
$got .= ';';
}
is ($got, ";good;");
}
# This test is the reason for postponed destruction in sv_unref
$a = [1,2,3];
$a = $a->[1];
is ($a, 2);
# This test used to coredump. The BEGIN block is important as it causes the
# op that created the constant reference to be freed. Hence the only
# reference to the constant string "pass" is in $a. The hack that made
# sure $a = $a->[1] would work didn't work with references to constants.
foreach my $lexical ('', 'my $a; ') {
my $expect = "pass\n";
my $result = runperl (switches => ['-wl'], stderr => 1,
prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a');
is ($?, 0);
is ($result, $expect);
}
$test = curr_test();
sub x::DESTROY {print "ok ", $test + shift->[0], "\n"}
{ my $a1 = bless [3],"x";
my $a2 = bless [2],"x";
{ my $a3 = bless [1],"x";
my $a4 = bless [0],"x";
567;
}
}
curr_test($test+4);
is (runperl (switches=>['-l'],
prog=> 'print 1; print qq-*$\*-;print 1;'),
"1\n*\n*\n1\n");
# bug #21347
runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' );
is ($?, 0, 'UNIVERSAL::AUTOLOAD called when freeing qr//');
runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1);
is ($?, 0, 'warn called inside UNIVERSAL::DESTROY');
# bug #22719
runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();');
is ($?, 0, 'coredump on typeglob = (SvRV && !SvROK)');
# bug #27268: freeing self-referential typeglobs could trigger
# "Attempt to free unreferenced scalar" warnings
is (runperl(
prog => 'use Symbol;my $x=bless \gensym,"t"; print;*$$x=$x',
stderr => 1
), '', 'freeing self-referential typeglob');
# using a regex in the destructor for STDOUT segfaulted because the
# REGEX pad had already been freed (ithreads build only). The
# object is required to trigger the early freeing of GV refs to to STDOUT
like (runperl(
prog => '$x=bless[]; sub IO::Handle::DESTROY{$_="bad";s/bad/ok/;print}',
stderr => 1
), qr/^(ok)+$/, 'STDOUT destructor');
# Bit of a hack to make test.pl happy. There are 3 more tests after it leaves.
$test = curr_test();
curr_test($test + 3);
# test global destruction
my $test1 = $test + 1;
my $test2 = $test + 2;
package FINALE;
{
$ref3 = bless ["ok $test2\n"]; # package destruction
my $ref2 = bless ["ok $test1\n"]; # lexical destruction
local $ref1 = bless ["ok $test\n"]; # dynamic destruction
1; # flush any temp values on stack
}
DESTROY {
print $_[0][0];
}
--- NEW FILE: flip.t ---
#!./perl
# $RCSfile: flip.t,v $$Revision: 1.2 $$Date: 2006-12-04 17:02:01 $
chdir 't' if -d 't';
print "1..15\n";
@a = (1,2,3,4,5,6,7,8,9,10,11,12);
while ($_ = shift(@a)) {
if ($x = /4/../8/) { $z = $x; print "ok ", $x + 0, "\n"; }
$y .= /1/../2/;
}
if ($z eq '5E0') {print "ok 6\n";} else {print "not ok 6\n";}
if ($y eq '12E0123E0') {print "ok 7\n";} else {print "not ok 7\n";}
@a = ('a','b','c','d','e','f','g');
{
local $.;
open(of,'harness') or die "Can't open harness: $!";
while (<of>) {
(3 .. 5) && ($foo .= $_);
}
$x = ($foo =~ y/\n/\n/);
if ($x eq 3) {print "ok 8\n";} else {print "not ok 8 $x:$foo:\n";}
$x = 3.14;
if (($x...$x) eq "1") {print "ok 9\n";} else {print "not ok 9\n";}
{
# coredump reported in bug 20001018.008
readline(UNKNOWN);
$. = 1;
$x = 1..10;
print "ok 10\n";
}
}
if (!defined $.) { print "ok 11\n" } else { print "not ok 11 # $.\n" }
use warnings;
my $warn='';
$SIG{__WARN__} = sub { $warn .= join '', @_ };
if (0..2) { print "ok 12\n" } else { print "not ok 12\n" }
if ($warn =~ /uninitialized/) { print "ok 13\n" } else { print "not ok 13\n" }
$warn = '';
$x = "foo".."bar";
if ((() = ($warn =~ /isn't numeric/g)) == 2) {
print "ok 14\n"
}
else {
print "not ok 14\n"
}
$warn = '';
$. = 15;
if (15..0) { print "ok 15\n" } else { print "not ok 15\n" }
--- NEW FILE: loopctl.t ---
#!./perl
# We have the following types of loop:
#
# 1a) while(A) {B}
# 1b) B while A;
#
# 2a) until(A) {B}
# 2b) B until A;
#
# 3a) for(@A) {B}
# 3b) B for A;
#
# 4a) for (A;B;C) {D}
#
# 5a) { A } # a bare block is a loop which runs once
#
# Loops of type (b) don't allow for next/last/redo style
# control, so we ignore them here. Type (a) loops can
# all be labelled, so there are ten possibilities (each
# of 5 types, labelled/unlabelled). We therefore need
# thirty tests to try the three control statements against
# the ten types of loop. For the first four types it's useful
# to distinguish the case where next re-iterates from the case
# where it leaves the loop. That makes 38.
# All these tests rely on "last LABEL"
# so if they've *all* failed, maybe you broke that...
#
# These tests are followed by an extra test of nested loops.
# Feel free to add more here.
#
# -- .robin. <robin at kitsite.com> 2001-03-13
print "1..44\n";
my $ok;
## while() loop without a label
TEST1: { # redo
$ok = 0;
my $x = 1;
my $first_time = 1;
while($x--) {
if (!$first_time) {
$ok = 1;
last TEST1;
}
$ok = 0;
$first_time = 0;
redo;
last TEST1;
}
continue {
$ok = 0;
last TEST1;
}
$ok = 0;
}
print ($ok ? "ok 1\n" : "not ok 1\n");
TEST2: { # next (succesful)
$ok = 0;
my $x = 2;
my $first_time = 1;
my $been_in_continue = 0;
while($x--) {
if (!$first_time) {
$ok = $been_in_continue;
last TEST2;
}
$ok = 0;
$first_time = 0;
next;
last TEST2;
}
continue {
$been_in_continue = 1;
}
$ok = 0;
}
print ($ok ? "ok 2\n" : "not ok 2\n");
TEST3: { # next (unsuccesful)
$ok = 0;
my $x = 1;
my $first_time = 1;
my $been_in_loop = 0;
my $been_in_continue = 0;
while($x--) {
$been_in_loop = 1;
if (!$first_time) {
$ok = 0;
last TEST3;
}
$ok = 0;
$first_time = 0;
next;
last TEST3;
}
continue {
$been_in_continue = 1;
}
$ok = $been_in_loop && $been_in_continue;
}
print ($ok ? "ok 3\n" : "not ok 3\n");
TEST4: { # last
$ok = 0;
my $x = 1;
my $first_time = 1;
while($x++) {
if (!$first_time) {
$ok = 0;
last TEST4;
}
$ok = 0;
$first_time = 0;
last;
last TEST4;
}
continue {
$ok = 0;
last TEST4;
}
$ok = 1;
}
print ($ok ? "ok 4\n" : "not ok 4\n");
## until() loop without a label
TEST5: { # redo
$ok = 0;
my $x = 0;
my $first_time = 1;
until($x++) {
if (!$first_time) {
$ok = 1;
last TEST5;
}
$ok = 0;
$first_time = 0;
redo;
last TEST5;
}
continue {
$ok = 0;
last TEST5;
}
$ok = 0;
}
print ($ok ? "ok 5\n" : "not ok 5\n");
TEST6: { # next (succesful)
$ok = 0;
my $x = 0;
my $first_time = 1;
my $been_in_continue = 0;
until($x++ >= 2) {
if (!$first_time) {
$ok = $been_in_continue;
last TEST6;
}
$ok = 0;
$first_time = 0;
next;
last TEST6;
}
continue {
$been_in_continue = 1;
}
$ok = 0;
}
print ($ok ? "ok 6\n" : "not ok 6\n");
TEST7: { # next (unsuccesful)
$ok = 0;
my $x = 0;
my $first_time = 1;
my $been_in_loop = 0;
my $been_in_continue = 0;
until($x++) {
$been_in_loop = 1;
if (!$first_time) {
$ok = 0;
last TEST7;
}
$ok = 0;
$first_time = 0;
next;
last TEST7;
}
continue {
$been_in_continue = 1;
}
$ok = $been_in_loop && $been_in_continue;
}
print ($ok ? "ok 7\n" : "not ok 7\n");
TEST8: { # last
$ok = 0;
my $x = 0;
my $first_time = 1;
until($x++ == 10) {
if (!$first_time) {
$ok = 0;
last TEST8;
}
$ok = 0;
$first_time = 0;
last;
last TEST8;
}
continue {
$ok = 0;
last TEST8;
}
$ok = 1;
}
print ($ok ? "ok 8\n" : "not ok 8\n");
## for(@array) loop without a label
TEST9: { # redo
$ok = 0;
my $first_time = 1;
for(1) {
if (!$first_time) {
$ok = 1;
last TEST9;
}
$ok = 0;
$first_time = 0;
redo;
last TEST9;
}
continue {
$ok = 0;
last TEST9;
}
$ok = 0;
}
print ($ok ? "ok 9\n" : "not ok 9\n");
TEST10: { # next (succesful)
$ok = 0;
my $first_time = 1;
my $been_in_continue = 0;
for(1,2) {
if (!$first_time) {
$ok = $been_in_continue;
last TEST10;
}
$ok = 0;
$first_time = 0;
next;
last TEST10;
}
continue {
$been_in_continue = 1;
}
$ok = 0;
}
print ($ok ? "ok 10\n" : "not ok 10\n");
TEST11: { # next (unsuccesful)
$ok = 0;
my $first_time = 1;
my $been_in_loop = 0;
my $been_in_continue = 0;
for(1) {
$been_in_loop = 1;
if (!$first_time) {
$ok = 0;
last TEST11;
}
$ok = 0;
$first_time = 0;
next;
last TEST11;
}
continue {
$been_in_continue = 1;
}
$ok = $been_in_loop && $been_in_continue;
}
print ($ok ? "ok 11\n" : "not ok 11\n");
TEST12: { # last
$ok = 0;
my $first_time = 1;
for(1..10) {
if (!$first_time) {
$ok = 0;
last TEST12;
}
$ok = 0;
$first_time = 0;
last;
last TEST12;
}
continue {
$ok=0;
last TEST12;
}
$ok = 1;
}
print ($ok ? "ok 12\n" : "not ok 12\n");
## for(;;) loop without a label
TEST13: { # redo
$ok = 0;
for(my $first_time = 1; 1;) {
if (!$first_time) {
$ok = 1;
last TEST13;
}
$ok = 0;
$first_time=0;
redo;
last TEST13;
}
$ok = 0;
}
print ($ok ? "ok 13\n" : "not ok 13\n");
TEST14: { # next (successful)
$ok = 0;
for(my $first_time = 1; 1; $first_time=0) {
if (!$first_time) {
$ok = 1;
last TEST14;
}
$ok = 0;
next;
last TEST14;
}
$ok = 0;
}
print ($ok ? "ok 14\n" : "not ok 14\n");
TEST15: { # next (unsuccesful)
$ok = 0;
my $x=1;
my $been_in_loop = 0;
for(my $first_time = 1; $x--;) {
$been_in_loop = 1;
if (!$first_time) {
$ok = 0;
last TEST15;
}
$ok = 0;
$first_time = 0;
next;
last TEST15;
}
$ok = $been_in_loop;
}
print ($ok ? "ok 15\n" : "not ok 15\n");
TEST16: { # last
$ok = 0;
for(my $first_time = 1; 1; last TEST16) {
if (!$first_time) {
$ok = 0;
last TEST16;
}
$ok = 0;
$first_time = 0;
last;
last TEST16;
}
$ok = 1;
}
print ($ok ? "ok 16\n" : "not ok 16\n");
## bare block without a label
TEST17: { # redo
$ok = 0;
my $first_time = 1;
{
if (!$first_time) {
$ok = 1;
last TEST17;
}
$ok = 0;
$first_time=0;
redo;
last TEST17;
}
continue {
$ok = 0;
last TEST17;
}
$ok = 0;
}
print ($ok ? "ok 17\n" : "not ok 17\n");
TEST18: { # next
$ok = 0;
{
next;
last TEST18;
}
continue {
$ok = 1;
last TEST18;
}
$ok = 0;
}
print ($ok ? "ok 18\n" : "not ok 18\n");
TEST19: { # last
$ok = 0;
{
last;
last TEST19;
}
continue {
$ok = 0;
last TEST19;
}
$ok = 1;
}
print ($ok ? "ok 19\n" : "not ok 19\n");
### Now do it all again with labels
## while() loop with a label
TEST20: { # redo
$ok = 0;
my $x = 1;
my $first_time = 1;
LABEL20: while($x--) {
if (!$first_time) {
$ok = 1;
last TEST20;
}
$ok = 0;
$first_time = 0;
redo LABEL20;
last TEST20;
}
continue {
$ok = 0;
last TEST20;
}
$ok = 0;
}
print ($ok ? "ok 20\n" : "not ok 20\n");
TEST21: { # next (succesful)
$ok = 0;
my $x = 2;
my $first_time = 1;
my $been_in_continue = 0;
LABEL21: while($x--) {
if (!$first_time) {
$ok = $been_in_continue;
last TEST21;
}
$ok = 0;
$first_time = 0;
next LABEL21;
last TEST21;
}
continue {
$been_in_continue = 1;
}
$ok = 0;
}
print ($ok ? "ok 21\n" : "not ok 21\n");
TEST22: { # next (unsuccesful)
$ok = 0;
my $x = 1;
my $first_time = 1;
my $been_in_loop = 0;
my $been_in_continue = 0;
LABEL22: while($x--) {
$been_in_loop = 1;
if (!$first_time) {
$ok = 0;
last TEST22;
}
$ok = 0;
$first_time = 0;
next LABEL22;
last TEST22;
}
continue {
$been_in_continue = 1;
}
$ok = $been_in_loop && $been_in_continue;
}
print ($ok ? "ok 22\n" : "not ok 22\n");
TEST23: { # last
$ok = 0;
my $x = 1;
my $first_time = 1;
LABEL23: while($x++) {
if (!$first_time) {
$ok = 0;
last TEST23;
}
$ok = 0;
$first_time = 0;
last LABEL23;
last TEST23;
}
continue {
$ok = 0;
last TEST23;
}
$ok = 1;
}
print ($ok ? "ok 23\n" : "not ok 23\n");
## until() loop with a label
TEST24: { # redo
$ok = 0;
my $x = 0;
my $first_time = 1;
LABEL24: until($x++) {
if (!$first_time) {
$ok = 1;
last TEST24;
}
$ok = 0;
$first_time = 0;
redo LABEL24;
last TEST24;
}
continue {
$ok = 0;
last TEST24;
}
$ok = 0;
}
print ($ok ? "ok 24\n" : "not ok 24\n");
TEST25: { # next (succesful)
$ok = 0;
my $x = 0;
my $first_time = 1;
my $been_in_continue = 0;
LABEL25: until($x++ >= 2) {
if (!$first_time) {
$ok = $been_in_continue;
last TEST25;
}
$ok = 0;
$first_time = 0;
next LABEL25;
last TEST25;
}
continue {
$been_in_continue = 1;
}
$ok = 0;
}
print ($ok ? "ok 25\n" : "not ok 25\n");
TEST26: { # next (unsuccesful)
$ok = 0;
my $x = 0;
my $first_time = 1;
my $been_in_loop = 0;
my $been_in_continue = 0;
LABEL26: until($x++) {
$been_in_loop = 1;
if (!$first_time) {
$ok = 0;
last TEST26;
}
$ok = 0;
$first_time = 0;
next LABEL26;
last TEST26;
}
continue {
$been_in_continue = 1;
}
$ok = $been_in_loop && $been_in_continue;
}
print ($ok ? "ok 26\n" : "not ok 26\n");
TEST27: { # last
$ok = 0;
my $x = 0;
my $first_time = 1;
LABEL27: until($x++ == 10) {
if (!$first_time) {
$ok = 0;
last TEST27;
}
$ok = 0;
$first_time = 0;
last LABEL27;
last TEST27;
}
continue {
$ok = 0;
last TEST8;
}
$ok = 1;
}
print ($ok ? "ok 27\n" : "not ok 27\n");
## for(@array) loop with a label
TEST28: { # redo
$ok = 0;
my $first_time = 1;
LABEL28: for(1) {
if (!$first_time) {
$ok = 1;
last TEST28;
}
$ok = 0;
$first_time = 0;
redo LABEL28;
last TEST28;
}
continue {
$ok = 0;
last TEST28;
}
$ok = 0;
}
print ($ok ? "ok 28\n" : "not ok 28\n");
TEST29: { # next (succesful)
$ok = 0;
my $first_time = 1;
my $been_in_continue = 0;
LABEL29: for(1,2) {
if (!$first_time) {
$ok = $been_in_continue;
last TEST29;
}
$ok = 0;
$first_time = 0;
next LABEL29;
last TEST29;
}
continue {
$been_in_continue = 1;
}
$ok = 0;
}
print ($ok ? "ok 29\n" : "not ok 29\n");
TEST30: { # next (unsuccesful)
$ok = 0;
my $first_time = 1;
my $been_in_loop = 0;
my $been_in_continue = 0;
LABEL30: for(1) {
$been_in_loop = 1;
if (!$first_time) {
$ok = 0;
last TEST30;
}
$ok = 0;
$first_time = 0;
next LABEL30;
last TEST30;
}
continue {
$been_in_continue = 1;
}
$ok = $been_in_loop && $been_in_continue;
}
print ($ok ? "ok 30\n" : "not ok 30\n");
TEST31: { # last
$ok = 0;
my $first_time = 1;
LABEL31: for(1..10) {
if (!$first_time) {
$ok = 0;
last TEST31;
}
$ok = 0;
$first_time = 0;
last LABEL31;
last TEST31;
}
continue {
$ok=0;
last TEST31;
}
$ok = 1;
}
print ($ok ? "ok 31\n" : "not ok 31\n");
## for(;;) loop with a label
TEST32: { # redo
$ok = 0;
LABEL32: for(my $first_time = 1; 1;) {
if (!$first_time) {
$ok = 1;
last TEST32;
}
$ok = 0;
$first_time=0;
redo LABEL32;
last TEST32;
}
$ok = 0;
}
print ($ok ? "ok 32\n" : "not ok 32\n");
TEST33: { # next (successful)
$ok = 0;
LABEL33: for(my $first_time = 1; 1; $first_time=0) {
if (!$first_time) {
$ok = 1;
last TEST33;
}
$ok = 0;
next LABEL33;
last TEST33;
}
$ok = 0;
}
print ($ok ? "ok 33\n" : "not ok 33\n");
TEST34: { # next (unsuccesful)
$ok = 0;
my $x=1;
my $been_in_loop = 0;
LABEL34: for(my $first_time = 1; $x--;) {
$been_in_loop = 1;
if (!$first_time) {
$ok = 0;
last TEST34;
}
$ok = 0;
$first_time = 0;
next LABEL34;
last TEST34;
}
$ok = $been_in_loop;
}
print ($ok ? "ok 34\n" : "not ok 34\n");
TEST35: { # last
$ok = 0;
LABEL35: for(my $first_time = 1; 1; last TEST16) {
if (!$first_time) {
$ok = 0;
last TEST35;
}
$ok = 0;
$first_time = 0;
last LABEL35;
last TEST35;
}
$ok = 1;
}
print ($ok ? "ok 35\n" : "not ok 35\n");
## bare block with a label
TEST36: { # redo
$ok = 0;
my $first_time = 1;
LABEL36: {
if (!$first_time) {
$ok = 1;
last TEST36;
}
$ok = 0;
$first_time=0;
redo LABEL36;
last TEST36;
}
continue {
$ok = 0;
last TEST36;
}
$ok = 0;
}
print ($ok ? "ok 36\n" : "not ok 36\n");
TEST37: { # next
$ok = 0;
LABEL37: {
next LABEL37;
last TEST37;
}
continue {
$ok = 1;
last TEST37;
}
$ok = 0;
}
print ($ok ? "ok 37\n" : "not ok 37\n");
TEST38: { # last
$ok = 0;
LABEL38: {
last LABEL38;
last TEST38;
}
continue {
$ok = 0;
last TEST38;
}
$ok = 1;
}
print ($ok ? "ok 38\n" : "not ok 38\n");
### Now test nested constructs
TEST39: {
$ok = 0;
my ($x, $y, $z) = (1,1,1);
one39: while ($x--) {
$ok = 0;
two39: while ($y--) {
$ok = 0;
three39: while ($z--) {
next two39;
}
continue {
$ok = 0;
last TEST39;
}
}
continue {
$ok = 1;
last TEST39;
}
$ok = 0;
}
}
print ($ok ? "ok 39\n" : "not ok 39\n");
### Test that loop control is dynamicly scoped.
sub test_last_label { last TEST40 }
TEST40: {
$ok = 1;
test_last_label();
$ok = 0;
}
print ($ok ? "ok 40\n" : "not ok 40\n");
sub test_last { last }
TEST41: {
$ok = 1;
test_last();
$ok = 0;
}
print ($ok ? "ok 41\n" : "not ok 41\n");
# [perl #27206] Memory leak in continue loop
# Ensure that the temporary object is freed each time round the loop,
# rather then all 10 of them all being freed right at the end
{
my $n=10; my $late_free = 0;
sub X::DESTROY { $late_free++ if $n < 0 };
{
($n-- && bless {}, 'X') && redo;
}
print $late_free ? "not " : "", "ok 42 - redo memory leak\n";
$n = 10; $late_free = 0;
{
($n-- && bless {}, 'X') && redo;
}
continue { }
print $late_free ? "not " : "", "ok 43 - redo with continue memory leak\n";
}
{
# [perl #37725]
$a37725[3] = 1; # use package var
$i = 2;
for my $x (reverse @a37725) {
$x = $i++;
}
print "@a37725" == "5 4 3 2" ? "" : "not ",
"ok 44 - reverse with empty slots (@a37725)\n";
}
--- NEW FILE: hash.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
use strict;
plan tests => 5;
my %h;
ok (!Internals::HvREHASH(%h), "hash doesn't start with rehash flag on");
foreach (1..10) {
$h{"\0"x$_}++;
}
ok (!Internals::HvREHASH(%h), "10 entries doesn't trigger rehash");
foreach (11..20) {
$h{"\0"x$_}++;
}
ok (Internals::HvREHASH(%h), "20 entries triggers rehash");
# second part using an emulation of the PERL_HASH in perl, mounting an
# attack on a prepopulated hash. This is also useful if you need normal
# keys which don't contain \0 -- suitable for stashes
use constant MASK_U32 => 2**32;
use constant HASH_SEED => 0;
use constant THRESHOLD => 14;
use constant START => "a";
# some initial hash data
my %h2 = map {$_ => 1} 'a'..'cc';
ok (!Internals::HvREHASH(%h2),
"starting with pre-populated non-pathalogical hash (rehash flag if off)");
my @keys = get_keys(\%h2);
$h2{$_}++ for @keys;
ok (Internals::HvREHASH(%h2),
scalar(@keys) . " colliding into the same bucket keys are triggerring rehash");
sub get_keys {
my $hr = shift;
# the minimum of bits required to mount the attack on a hash
my $min_bits = log(THRESHOLD)/log(2);
# if the hash has already been populated with a significant amount
# of entries the number of mask bits can be higher
my $keys = scalar keys %$hr;
my $bits = $keys ? log($keys)/log(2) : 0;
$bits = $min_bits if $min_bits > $bits;
$bits = int($bits) < $bits ? int($bits) + 1 : int($bits);
# need to add 2 bits to cover the internal split cases
$bits += 2;
my $mask = 2**$bits-1;
print "# using mask: $mask ($bits)\n";
my @keys;
my $s = START;
my $c = 0;
# get 2 keys on top of the THRESHOLD
my $hash;
while (@keys < THRESHOLD+2) {
# next if exists $hash->{$s};
$hash = hash($s);
next unless ($hash & $mask) == 0;
$c++;
printf "# %2d: %5s, %10s\n", $c, $s, $hash;
push @keys, $s;
} continue {
$s++;
}
return @keys;
}
# trying to provide the fastest equivalent of C macro's PERL_HASH in
# Perl - the main complication is that it uses U32 integer, which we
# can't do it perl, without doing some tricks
sub hash {
my $s = shift;
my @c = split //, $s;
my $u = HASH_SEED;
for (@c) {
# (A % M) + (B % M) == (A + B) % M
# This works because '+' produces a NV, which is big enough to hold
# the intermidiate result. We only need the % before any "^" and "&"
# to get the result in the range for an I32.
# and << doesn't work on NV, so using 1 << 10
$u += ord;
$u += $u * (1 << 10); $u %= MASK_U32;
$u ^= $u >> 6;
}
$u += $u << 3; $u %= MASK_U32;
$u ^= $u >> 11; $u %= MASK_U32;
$u += $u << 15; $u %= MASK_U32;
$u;
}
--- NEW FILE: quotemeta.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = qw(../lib .);
require Config; import Config;
require "test.pl";
}
plan tests => 22;
if ($Config{ebcdic} eq 'define') {
$_ = join "", map chr($_), 129..233;
# 105 characters - 52 letters = 53 backslashes
# 105 characters + 53 backslashes = 158 characters
$_ = quotemeta $_;
is(length($_), 158, "quotemeta string");
# 104 non-backslash characters
is(tr/\\//cd, 104, "tr count non-backslashed");
} else { # some ASCII descendant, then.
$_ = join "", map chr($_), 32..127;
# 96 characters - 52 letters - 10 digits - 1 underscore = 33 backslashes
# 96 characters + 33 backslashes = 129 characters
$_ = quotemeta $_;
is(length($_), 129, "quotemeta string");
# 95 non-backslash characters
is(tr/\\//cd, 95, "tr count non-backslashed");
}
is(length(quotemeta ""), 0, "quotemeta empty string");
is("aA\UbB\LcC\EdD", "aABBccdD", 'aA\UbB\LcC\EdD');
is("aA\LbB\UcC\EdD", "aAbbCCdD", 'aA\LbB\UcC\EdD');
is("\L\upERL", "Perl", '\L\upERL');
is("\u\LpERL", "Perl", '\u\LpERL');
is("\U\lPerl", "pERL", '\U\lPerl');
is("\l\UPerl", "pERL", '\l\UPerl');
is("\u\LpE\Q#X#\ER\EL", "Pe\\#x\\#rL", '\u\LpE\Q#X#\ER\EL');
is("\l\UPe\Q!x!\Er\El", "pE\\!X\\!Rl", '\l\UPe\Q!x!\Er\El');
is("\Q\u\LpE.X.R\EL\E.", "Pe\\.x\\.rL.", '\Q\u\LpE.X.R\EL\E.');
is("\Q\l\UPe*x*r\El\E*", "pE\\*X\\*Rl*", '\Q\l\UPe*x*r\El\E*');
is("\U\lPerl\E\E\E\E", "pERL", '\U\lPerl\E\E\E\E');
is("\l\UPerl\E\E\E\E", "pERL", '\l\UPerl\E\E\E\E');
is(quotemeta("\x{263a}"), "\x{263a}", "quotemeta Unicode");
is(length(quotemeta("\x{263a}")), 1, "quotemeta Unicode length");
$a = "foo|bar";
is("a\Q\Ec$a", "acfoo|bar", '\Q\E');
is("a\L\Ec$a", "acfoo|bar", '\L\E');
is("a\l\Ec$a", "acfoo|bar", '\l\E');
is("a\U\Ec$a", "acfoo|bar", '\U\E');
is("a\u\Ec$a", "acfoo|bar", '\u\E');
--- NEW FILE: sub_lval.t ---
print "1..71\n";
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary
sub b : lvalue { ${\shift} }
my $out = a(b()); # Check that temporaries are allowed.
print "# `$out'\nnot " unless ref $out eq 'main'; # Not reached if error.
print "ok 1\n";
my @out = grep /main/, a(b()); # Check that temporaries are allowed.
print "# `@out'\nnot " unless @out==1; # Not reached if error.
print "ok 2\n";
my $in;
# Check that we can return localized values from subroutines:
sub in : lvalue { $in = shift; }
sub neg : lvalue { #(num_str) return num_str
local $_ = shift;
s/^\+/-/;
$_;
}
in(neg("+2"));
print "# `$in'\nnot " unless $in eq '-2';
print "ok 3\n";
sub get_lex : lvalue { $in }
sub get_st : lvalue { $blah }
sub id : lvalue { ${\shift} }
sub id1 : lvalue { $_[0] }
sub inc : lvalue { ${\++$_[0]} }
$in = 5;
$blah = 3;
get_st = 7;
print "# `$blah' ne 7\nnot " unless $blah == 7;
print "ok 4\n";
get_lex = 7;
print "# `$in' ne 7\nnot " unless $in == 7;
print "ok 5\n";
++get_st;
print "# `$blah' ne 8\nnot " unless $blah == 8;
print "ok 6\n";
++get_lex;
print "# `$in' ne 8\nnot " unless $in == 8;
print "ok 7\n";
id(get_st) = 10;
print "# `$blah' ne 10\nnot " unless $blah == 10;
print "ok 8\n";
id(get_lex) = 10;
print "# `$in' ne 10\nnot " unless $in == 10;
print "ok 9\n";
++id(get_st);
print "# `$blah' ne 11\nnot " unless $blah == 11;
print "ok 10\n";
++id(get_lex);
print "# `$in' ne 11\nnot " unless $in == 11;
print "ok 11\n";
id1(get_st) = 20;
print "# `$blah' ne 20\nnot " unless $blah == 20;
print "ok 12\n";
id1(get_lex) = 20;
print "# `$in' ne 20\nnot " unless $in == 20;
print "ok 13\n";
++id1(get_st);
print "# `$blah' ne 21\nnot " unless $blah == 21;
print "ok 14\n";
++id1(get_lex);
print "# `$in' ne 21\nnot " unless $in == 21;
print "ok 15\n";
inc(get_st);
print "# `$blah' ne 22\nnot " unless $blah == 22;
print "ok 16\n";
inc(get_lex);
print "# `$in' ne 22\nnot " unless $in == 22;
print "ok 17\n";
inc(id(get_st));
print "# `$blah' ne 23\nnot " unless $blah == 23;
print "ok 18\n";
inc(id(get_lex));
print "# `$in' ne 23\nnot " unless $in == 23;
print "ok 19\n";
++inc(id1(id(get_st)));
print "# `$blah' ne 25\nnot " unless $blah == 25;
print "ok 20\n";
++inc(id1(id(get_lex)));
print "# `$in' ne 25\nnot " unless $in == 25;
print "ok 21\n";
@a = (1) x 3;
@b = (undef) x 2;
$#c = 3; # These slots are not fillable.
# Explanation: empty slots contain &sv_undef.
=for disabled constructs
sub a3 :lvalue {@a}
sub b2 : lvalue {@b}
sub c4: lvalue {@c}
$_ = '';
eval <<'EOE' or $_ = $@;
($x, a3, $y, b2, $z, c4, $t) = (34 .. 78);
1;
EOE
#@out = ($x, a3, $y, b2, $z, c4, $t);
#@in = (34 .. 41, (undef) x 4, 46);
#print "# `@out' ne `@in'\nnot " unless "@out" eq "@in";
print "# '$_'.\nnot "
unless /Can\'t return an uninitialized value from lvalue subroutine/;
=cut
print "ok 22\n";
my $var;
sub a::var : lvalue { $var }
"a"->var = 45;
print "# `$var' ne 45\nnot " unless $var == 45;
print "ok 23\n";
my $oo;
$o = bless \$oo, "a";
$o->var = 47;
print "# `$var' ne 47\nnot " unless $var == 47;
print "ok 24\n";
sub o : lvalue { $o }
o->var = 49;
print "# `$var' ne 49\nnot " unless $var == 49;
print "ok 25\n";
sub nolv () { $x0, $x1 } # Not lvalue
$_ = '';
eval <<'EOE' or $_ = $@;
nolv = (2,3);
1;
EOE
print "not "
unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
print "ok 26\n";
$_ = '';
eval <<'EOE' or $_ = $@;
nolv = (2,3) if $_;
1;
EOE
print "not "
unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
print "ok 27\n";
$_ = '';
eval <<'EOE' or $_ = $@;
&nolv = (2,3) if $_;
1;
EOE
print "not "
unless /Can\'t modify non-lvalue subroutine call in scalar assignment/;
print "ok 28\n";
$x0 = $x1 = $_ = undef;
$nolv = \&nolv;
eval <<'EOE' or $_ = $@;
$nolv->() = (2,3) if $_;
1;
EOE
print "# '$_', '$x0', '$x1'.\nnot " if defined $_;
print "ok 29\n";
$x0 = $x1 = $_ = undef;
$nolv = \&nolv;
eval <<'EOE' or $_ = $@;
$nolv->() = (2,3);
1;
EOE
print "# '$_', '$x0', '$x1'.\nnot "
unless /Can\'t modify non-lvalue subroutine call/;
print "ok 30\n";
sub lv0 : lvalue { } # Converted to lv10 in scalar context
$_ = undef;
eval <<'EOE' or $_ = $@;
lv0 = (2,3);
1;
EOE
print "# '$_'.\nnot "
unless /Can't return undef from lvalue subroutine/;
print "ok 31\n";
sub lv10 : lvalue {}
$_ = undef;
eval <<'EOE' or $_ = $@;
(lv0) = (2,3);
1;
EOE
print "# '$_'.\nnot " if defined $_;
print "ok 32\n";
sub lv1u :lvalue { undef }
$_ = undef;
eval <<'EOE' or $_ = $@;
lv1u = (2,3);
1;
EOE
print "# '$_'.\nnot "
unless /Can't return undef from lvalue subroutine/;
print "ok 33\n";
$_ = undef;
eval <<'EOE' or $_ = $@;
(lv1u) = (2,3);
1;
EOE
# Fixed by change @10777
#print "# '$_'.\nnot "
# unless /Can\'t return an uninitialized value from lvalue subroutine/;
print "ok 34 # Skip: removed test\n";
$x = '1234567';
$_ = undef;
eval <<'EOE' or $_ = $@;
sub lv1t : lvalue { index $x, 2 }
lv1t = (2,3);
1;
EOE
print "# '$_'.\nnot "
unless /Can\'t modify index in lvalue subroutine return/;
print "ok 35\n";
$_ = undef;
eval <<'EOE' or $_ = $@;
sub lv2t : lvalue { shift }
(lv2t) = (2,3);
1;
EOE
print "# '$_'.\nnot "
unless /Can\'t modify shift in lvalue subroutine return/;
print "ok 36\n";
$xxx = 'xxx';
sub xxx () { $xxx } # Not lvalue
$_ = undef;
eval <<'EOE' or $_ = $@;
sub lv1tmp : lvalue { xxx } # is it a TEMP?
lv1tmp = (2,3);
1;
EOE
print "# '$_'.\nnot "
unless /Can\'t modify non-lvalue subroutine call in lvalue subroutine return/;
print "ok 37\n";
$_ = undef;
eval <<'EOE' or $_ = $@;
(lv1tmp) = (2,3);
1;
EOE
print "# '$_'.\nnot "
unless /Can\'t return a temporary from lvalue subroutine/;
print "ok 38\n";
sub yyy () { 'yyy' } # Const, not lvalue
$_ = undef;
eval <<'EOE' or $_ = $@;
sub lv1tmpr : lvalue { yyy } # is it read-only?
lv1tmpr = (2,3);
1;
EOE
print "# '$_'.\nnot "
unless /Can\'t modify constant item in lvalue subroutine return/;
print "ok 39\n";
$_ = undef;
eval <<'EOE' or $_ = $@;
(lv1tmpr) = (2,3);
1;
EOE
print "# '$_'.\nnot "
unless /Can\'t return a readonly value from lvalue subroutine/;
print "ok 40\n";
sub lva : lvalue {@a}
$_ = undef;
@a = ();
$a[1] = 12;
eval <<'EOE' or $_ = $@;
(lva) = (2,3);
1;
EOE
print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
print "ok 41\n";
$_ = undef;
@a = ();
$a[0] = undef;
$a[1] = 12;
eval <<'EOE' or $_ = $@;
(lva) = (2,3);
1;
EOE
print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
print "ok 42\n";
$_ = undef;
@a = ();
$a[0] = undef;
$a[1] = 12;
eval <<'EOE' or $_ = $@;
(lva) = (2,3);
1;
EOE
print "# '$_'.\nnot " unless "'@a' $_" eq "'2 3' ";
print "ok 43\n";
sub lv1n : lvalue { $newvar }
$_ = undef;
eval <<'EOE' or $_ = $@;
lv1n = (3,4);
1;
EOE
print "# '$_', '$newvar'.\nnot " unless "'$newvar' $_" eq "'4' ";
print "ok 44\n";
sub lv1nn : lvalue { $nnewvar }
$_ = undef;
eval <<'EOE' or $_ = $@;
(lv1nn) = (3,4);
1;
EOE
print "# '$_'.\nnot " unless "'$nnewvar' $_" eq "'3' ";
print "ok 45\n";
$a = \&lv1nn;
$a->() = 8;
print "# '$nnewvar'.\nnot " unless $nnewvar eq '8';
print "ok 46\n";
eval 'sub AUTOLOAD : lvalue { $newvar }';
foobar() = 12;
print "# '$newvar'.\nnot " unless $newvar eq "12";
print "ok 47\n";
print "ok 48 # Skip: removed test\n";
print "ok 49 # Skip: removed test\n";
{
my %hash; my @array;
sub alv : lvalue { $array[1] }
sub alv2 : lvalue { $array[$_[0]] }
sub hlv : lvalue { $hash{"foo"} }
sub hlv2 : lvalue { $hash{$_[0]} }
$array[1] = "not ok 51\n";
alv() = "ok 50\n";
print alv();
alv2(20) = "ok 51\n";
print $array[20];
$hash{"foo"} = "not ok 52\n";
hlv() = "ok 52\n";
print $hash{foo};
$hash{bar} = "not ok 53\n";
hlv("bar") = "ok 53\n";
print hlv("bar");
sub array : lvalue { @array }
sub array2 : lvalue { @array2 } # This is a global.
sub hash : lvalue { %hash }
sub hash2 : lvalue { %hash2 } # So's this.
@array2 = qw(foo bar);
%hash2 = qw(foo bar);
(array()) = qw(ok 54);
print "not " unless "@array" eq "ok 54";
print "ok 54\n";
(array2()) = qw(ok 55);
print "not " unless "@array2" eq "ok 55";
print "ok 55\n";
(hash()) = qw(ok 56);
print "not " unless $hash{ok} == 56;
print "ok 56\n";
(hash2()) = qw(ok 57);
print "not " unless $hash2{ok} == 57;
print "ok 57\n";
@array = qw(a b c d);
sub aslice1 : lvalue { @array[0,2] };
(aslice1()) = ("ok", "already");
print "# @array\nnot " unless "@array" eq "ok b already d";
print "ok 58\n";
@array2 = qw(a B c d);
sub aslice2 : lvalue { @array2[0,2] };
(aslice2()) = ("ok", "already");
print "not " unless "@array2" eq "ok B already d";
print "ok 59\n";
%hash = qw(a Alpha b Beta c Gamma);
sub hslice : lvalue { @hash{"c", "b"} }
(hslice()) = ("CISC", "BogoMIPS");
print "not " unless join("/", at hash{"c","a","b"}) eq "CISC/Alpha/BogoMIPS";
print "ok 60\n";
}
$str = "Hello, world!";
sub sstr : lvalue { substr($str, 1, 4) }
sstr() = "i";
print "not " unless $str eq "Hi, world!";
print "ok 61\n";
$str = "Made w/ JavaScript";
sub veclv : lvalue { vec($str, 2, 32) }
if (ord('A') != 193) {
veclv() = 0x5065726C;
}
else { # EBCDIC?
veclv() = 0xD7859993;
}
print "# $str\nnot " unless $str eq "Made w/ PerlScript";
print "ok 62\n";
sub position : lvalue { pos }
@p = ();
$_ = "fee fi fo fum";
while (/f/g) {
push @p, position;
position() += 6;
}
print "# @p\nnot " unless "@p" eq "1 8";
print "ok 63\n";
# Bug 20001223.002: split thought that the list had only one element
@ary = qw(4 5 6);
sub lval1 : lvalue { $ary[0]; }
sub lval2 : lvalue { $ary[1]; }
(lval1(), lval2()) = split ' ', "1 2 3 4";
print "not " unless join(':', @ary) eq "1:2:6";
print "ok 64\n";
# check that an element of a tied hash/array can be assigned to via lvalueness
package Tie_Hash;
our ($key, $val);
sub TIEHASH { bless \my $v => __PACKAGE__ }
sub STORE { ($key, $val) = @_[1,2] }
package main;
sub lval_tie_hash : lvalue {
tie my %t => 'Tie_Hash';
$t{key};
}
eval { lval_tie_hash() = "value"; };
print "# element of tied hash: $@\nnot " if $@;
print "ok 65\n";
print "not " if "$Tie_Hash::key-$Tie_Hash::val" ne "key-value";
print "ok 66\n";
package Tie_Array;
our @val;
sub TIEARRAY { bless \my $v => __PACKAGE__ }
sub STORE { $val[ $_[1] ] = $_[2] }
package main;
sub lval_tie_array : lvalue {
tie my @t => 'Tie_Array';
$t[0];
}
eval { lval_tie_array() = "value"; };
print "# element of tied array: $@\nnot " if $@;
print "ok 67\n";
print "not " if $Tie_Array::val[0] ne "value";
print "ok 68\n";
require './test.pl';
curr_test(69);
TODO: {
local $TODO = 'test explicit return of lval expr';
# subs are corrupted copies from tests 1-~4
sub bad_get_lex : lvalue { return $in };
sub bad_get_st : lvalue { return $blah }
sub bad_id : lvalue { return ${\shift} }
sub bad_id1 : lvalue { return $_[0] }
sub bad_inc : lvalue { return ${\++$_[0]} }
$in = 5;
$blah = 3;
bad_get_st = 7;
is( $blah, 7 );
bad_get_lex = 7;
is($in, 7, "yada");
++bad_get_st;
is($blah, 8, "yada");
}
--- NEW FILE: sprintf.t ---
#!./perl
# Tests sprintf, excluding handling of 64-bit integers or long
# doubles (if supported), of machine-specific short and long
# integers, machine-specific floating point exceptions (infinity,
# not-a-number ...), of the effects of locale, and of features
# specific to multi-byte characters (under the utf8 pragma and such).
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use warnings;
use Config;
use strict;
my @tests = ();
my ($i, $template, $data, $result, $comment, $w, $x, $evalData, $n, $p);
my $Is_VMS_VAX = 0;
# We use HW_MODEL since ARCH_NAME was not in VMS V5.*
if ($^O eq 'VMS') {
my $hw_model;
chomp($hw_model = `write sys\$output f\$getsyi("HW_MODEL")`);
$Is_VMS_VAX = $hw_model < 1024 ? 1 : 0;
}
# No %Config.
my $Is_Ultrix_VAX = $^O eq 'ultrix' && `uname -m` =~ /^VAX$/;
while (<DATA>) {
s/^\s*>//; s/<\s*$//;
($template, $data, $result, $comment) = split(/<\s*>/, $_, 4);
if ($^O eq 'os390' || $^O eq 's390') { # non-IEEE (s390 is UTS)
$data =~ s/([eE])96$/${1}63/; # smaller exponents
$result =~ s/([eE]\+)102$/${1}69/; # " "
$data =~ s/([eE])\-101$/${1}-56/; # larger exponents
$result =~ s/([eE])\-102$/${1}-57/; # " "
}
if ($Is_VMS_VAX || $Is_Ultrix_VAX) {
# VAX DEC C 5.3 at least since there is no
# ccflags =~ /float=ieee/ on VAX.
# AXP is unaffected whether or not it's using ieee.
$data =~ s/([eE])96$/${1}26/; # smaller exponents
$result =~ s/([eE]\+)102$/${1}32/; # " "
$data =~ s/([eE])\-101$/${1}-24/; # larger exponents
$result =~ s/([eE])\-102$/${1}-25/; # " "
}
$evalData = eval $data;
$data = ref $evalData ? $evalData : [$evalData];
push @tests, [$template, $data, $result, $comment];
}
print '1..', scalar @tests, "\n";
$SIG{__WARN__} = sub {
if ($_[0] =~ /^Invalid conversion/) {
$w = ' INVALID';
} elsif ($_[0] =~ /^Use of uninitialized value/) {
$w = ' UNINIT';
} else {
warn @_;
}
};
for ($i = 1; @tests; $i++) {
($template, $data, $result, $comment) = @{shift @tests};
$w = undef;
$x = sprintf(">$template<", @$data);
substr($x, -1, 0) = $w if $w;
# $x may have 3 exponent digits, not 2
my $y = $x;
if ($y =~ s/([Ee][-+])0(\d)/$1$2/) {
# if result is left-adjusted, append extra space
if ($template =~ /%\+?\-/ and $result =~ / $/) {
$y =~ s/<$/ </;
}
# if result is zero-filled, add extra zero
elsif ($template =~ /%\+?0/ and $result =~ /^0/) {
$y =~ s/^>0/>00/;
}
# if result is right-adjusted, prepend extra space
elsif ($result =~ /^ /) {
$y =~ s/^>/> /;
}
}
my $skip = 0;
if ($comment =~ s/\s+skip:\s*(.*)//) {
my $os = $1;
my $osv = exists $Config{osvers} ? $Config{osvers} : "0";
# >comment skip: all<
if ($os =~ /\ball\b/i) {
$skip = 1;
# >comment skip: VMS hpux:10.20<
} elsif ($os =~ /\b$^O(?::(\S+))?\b/i) {
my $vsn = defined $1 ? $1 : "0";
# Only compare on the the first pair of digits, as numeric
# compares don't like 2.6.10-3mdksmp or 2.6.8-24.10-default
s/^(\d+(\.\d+)?).*/$1/ for $osv, $vsn;
$skip = $vsn ? ($osv <= $vsn ? 1 : 0) : 1;
}
$skip and $comment =~ s/$/, failure expected on $^O $osv/;
}
if ($x eq ">$result<") {
print "ok $i\n";
}
elsif ($skip) {
print "ok $i # skip $comment\n";
}
elsif ($y eq ">$result<") # Some C libraries always give
{ # three-digit exponent
print("ok $i # >$result< $x three-digit exponent accepted\n");
}
elsif ($result =~ /[-+]\d{3}$/ &&
# Suppress tests with modulo of exponent >= 100 on platforms
# which can't handle such magnitudes (or where we can't tell).
((!eval {require POSIX}) || # Costly: only do this if we must!
(length(&POSIX::DBL_MAX) - rindex(&POSIX::DBL_MAX, '+')) == 3))
{
print("ok $i # >$template< >$data< >$result<",
" Suppressed: exponent out of range?\n");
}
else {
$y = ($x eq $y ? "" : " => $y");
print("not ok $i >$template< >$data< >$result< $x$y",
$comment ? " # $comment\n" : "\n");
}
}
# In each of the following lines, there are three required fields:
# printf template, data to be formatted (as a Perl expression), and
# expected result of formatting. An optional fourth field can contain
# a comment. Each field is delimited by a starting '>' and a
# finishing '<'; any whitespace outside these start and end marks is
# not part of the field. If formatting requires more than one data
# item (for example, if variable field widths are used), the Perl data
# expression should return a reference to an array having the requisite
# number of elements. Even so, subterfuge is sometimes required: see
# tests for %n and %p.
#
# Tests that are expected to fail on a certain OS can be marked as such
# by trailing the comment with a skip: section. Skips are tags separated
# bu space consisting of a $^O optionally trailed with :osvers. In the
# latter case, all os-levels below that are expected to fail. A special
# tag 'all' is allowed for todo tests that should fail on any system
#
# >%G< >1234567e96< >1.23457E+102< >exponent too big skip: os390<
# >%.0g< >-0.0< >-0< >No minus skip: MSWin32 VMS hpux:10.20<
# >%d< >4< >1< >4 != 1 skip: all<
#
# The following tests are not currently run, for the reasons stated:
=pod
=begin problematic
>%.0f< >1.5< >2< >Standard vague: no rounding rules<
>%.0f< >2.5< >2< >Standard vague: no rounding rules<
=end problematic
=cut
# template data result
__END__
>%6. 6s< >''< >%6. 6s INVALID< >(See use of $w in code above)<
>%6 .6s< >''< >%6 .6s INVALID<
>%6.6 s< >''< >%6.6 s INVALID<
>%A< >''< >%A INVALID<
>%B< >''< >%B INVALID<
>%C< >''< >%C INVALID<
>%D< >0x7fffffff< >2147483647< >Synonym for %ld<
>%E< >123456.789< >1.234568E+05< >Like %e, but using upper-case "E"<
>%F< >123456.789< >123456.789000< >Synonym for %f<
>%G< >1234567.89< >1.23457E+06< >Like %g, but using upper-case "E"<
>%G< >1234567e96< >1.23457E+102<
>%G< >.1234567e-101< >1.23457E-102<
>%G< >12345.6789< >12345.7<
>%G< >1234567e96< >1.23457E+102< >exponent too big skip: os390<
>%G< >.1234567e-101< >1.23457E-102< >exponent too small skip: os390<
>%H< >''< >%H INVALID<
>%I< >''< >%I INVALID<
>%J< >''< >%J INVALID<
>%K< >''< >%K INVALID<
>%L< >''< >%L INVALID<
>%M< >''< >%M INVALID<
>%N< >''< >%N INVALID<
>%O< >2**32-1< >37777777777< >Synonym for %lo<
>%P< >''< >%P INVALID<
>%Q< >''< >%Q INVALID<
>%R< >''< >%R INVALID<
>%S< >''< >%S INVALID<
>%T< >''< >%T INVALID<
>%U< >2**32-1< >4294967295< >Synonym for %lu<
>%V< >''< >%V INVALID<
>%W< >''< >%W INVALID<
>%X< >2**32-1< >FFFFFFFF< >Like %x, but with u/c letters<
>%#X< >2**32-1< >0XFFFFFFFF<
>%Y< >''< >%Y INVALID<
>%Z< >''< >%Z INVALID<
>%a< >''< >%a INVALID<
>%b< >2**32-1< >11111111111111111111111111111111<
>%+b< >2**32-1< >11111111111111111111111111111111<
>%#b< >2**32-1< >0b11111111111111111111111111111111<
>%34b< >2**32-1< > 11111111111111111111111111111111<
>%034b< >2**32-1< >0011111111111111111111111111111111<
>%-34b< >2**32-1< >11111111111111111111111111111111 <
>%-034b< >2**32-1< >11111111111111111111111111111111 <
>%c< >ord('A')< >A<
>%10c< >ord('A')< > A<
>%#10c< >ord('A')< > A< ># modifier: no effect<
>%010c< >ord('A')< >000000000A<
>%10lc< >ord('A')< > A< >l modifier: no effect<
>%10hc< >ord('A')< > A< >h modifier: no effect<
>%10.5c< >ord('A')< > A< >precision: no effect<
>%-10c< >ord('A')< >A <
>%d< >123456.789< >123456<
>%d< >-123456.789< >-123456<
>%d< >0< >0<
>%+d< >0< >+0<
>%0d< >0< >0<
>%.0d< >0< ><
>%+.0d< >0< >+<
>%.0d< >1< >1<
>%d< >1< >1<
>%+d< >1< >+1<
>%#3.2d< >1< > 01< ># modifier: no effect<
>%3.2d< >1< > 01<
>%03.2d< >1< >001<
>%-3.2d< >1< >01 <
>%-03.2d< >1< >01 < >zero pad + left just.: no effect<
>%d< >-1< >-1<
>%+d< >-1< >-1<
>%hd< >1< >1< >More extensive testing of<
>%ld< >1< >1< >length modifiers would be<
>%Vd< >1< >1< >platform-specific<
>%vd< >chr(1)< >1<
>%+vd< >chr(1)< >+1<
>%#vd< >chr(1)< >1<
>%vd< >"\01\02\03"< >1.2.3<
>%v.3d< >"\01\02\03"< >001.002.003<
>%0v3d< >"\01\02\03"< >001.002.003<
>%-v3d< >"\01\02\03"< >1 .2 .3 <
>%+-v3d< >"\01\02\03"< >+1 .2 .3 <
>%v4.3d< >"\01\02\03"< > 001. 002. 003<
>%0v4.3d< >"\01\02\03"< >0001.0002.0003<
>%0*v2d< >['-', "\0\7\14"]< >00-07-12<
>%v.*d< >["\01\02\03", 3]< >001.002.003<
>%0v*d< >["\01\02\03", 3]< >001.002.003<
>%-v*d< >["\01\02\03", 3]< >1 .2 .3 <
>%+-v*d< >["\01\02\03", 3]< >+1 .2 .3 <
>%v*.*d< >["\01\02\03", 4, 3]< > 001. 002. 003<
>%0v*.*d< >["\01\02\03", 4, 3]< >0001.0002.0003<
>%0*v*d< >['-', "\0\7\13", 2]< >00-07-11<
>%e< >1234.875< >1.234875e+03<
>%e< >0.000012345< >1.234500e-05<
>%e< >1234567E96< >1.234567e+102<
>%e< >0< >0.000000e+00<
>%e< >.1234567E-101< >1.234567e-102<
>%+e< >1234.875< >+1.234875e+03<
>%#e< >1234.875< >1.234875e+03<
>%e< >-1234.875< >-1.234875e+03<
>%+e< >-1234.875< >-1.234875e+03<
>%#e< >-1234.875< >-1.234875e+03<
>%.0e< >1234.875< >1e+03<
>%#.0e< >1234.875< >1.e+03<
>%.0e< >1.875< >2e+00<
>%.0e< >0.875< >9e-01<
>%.*e< >[0, 1234.875]< >1e+03<
>%.1e< >1234.875< >1.2e+03<
>%-12.4e< >1234.875< >1.2349e+03 <
>%12.4e< >1234.875< > 1.2349e+03<
>%+-12.4e< >1234.875< >+1.2349e+03 <
>%+12.4e< >1234.875< > +1.2349e+03<
>%+-12.4e< >-1234.875< >-1.2349e+03 <
>%+12.4e< >-1234.875< > -1.2349e+03<
>%e< >1234567E96< >1.234567e+102< >exponent too big skip: os390<
>%e< >.1234567E-101< >1.234567e-102< >exponent too small skip: os390<
>%f< >1234.875< >1234.875000<
>%+f< >1234.875< >+1234.875000<
>%#f< >1234.875< >1234.875000<
>%f< >-1234.875< >-1234.875000<
>%+f< >-1234.875< >-1234.875000<
>%#f< >-1234.875< >-1234.875000<
>%6f< >1234.875< >1234.875000<
>%*f< >[6, 1234.875]< >1234.875000<
>%.0f< >-0.1< >-0< >C library bug: no minus skip: VMS<
>%.0f< >1234.875< >1235<
>%.1f< >1234.875< >1234.9<
>%-8.1f< >1234.875< >1234.9 <
>%8.1f< >1234.875< > 1234.9<
>%+-8.1f< >1234.875< >+1234.9 <
>%+8.1f< >1234.875< > +1234.9<
>%+-8.1f< >-1234.875< >-1234.9 <
>%+8.1f< >-1234.875< > -1234.9<
>%*.*f< >[5, 2, 12.3456]< >12.35<
>%f< >0< >0.000000<
>%.0f< >0< >0<
>%.0f< >2**38< >274877906944< >Should have exact int'l rep'n<
>%.0f< >0.1< >0<
>%.0f< >0.6< >1< >Known to fail with sfio, (irix|nonstop-ux|powerux); -DHAS_LDBL_SPRINTF_BUG may fix<
>%.0f< >-0.6< >-1< >Known to fail with sfio, (irix|nonstop-ux|powerux); -DHAS_LDBL_SPRINTF_BUG may fix<
>%.0f< >1.6< >2<
>%.0f< >-1.6< >-2<
>%.0f< >1< >1<
>%#.0f< >1< >1.<
>%.0lf< >1< >1< >'l' should have no effect<
>%.0hf< >1< >%.0hf INVALID< >'h' should be rejected<
>%g< >12345.6789< >12345.7<
>%+g< >12345.6789< >+12345.7<
>%#g< >12345.6789< >12345.7<
>%.0g< >-0.0< >-0< >C99 standard mandates minus sign but C89 does not skip: MSWin32 VMS hpux:10.20 openbsd netbsd:1.5 irix<
>%.0g< >12345.6789< >1e+04<
>%#.0g< >12345.6789< >1.e+04<
>%.2g< >12345.6789< >1.2e+04<
>%.*g< >[2, 12345.6789]< >1.2e+04<
>%.9g< >12345.6789< >12345.6789<
>%12.9g< >12345.6789< > 12345.6789<
>%012.9g< >12345.6789< >0012345.6789<
>%-12.9g< >12345.6789< >12345.6789 <
>%*.*g< >[-12, 9, 12345.6789]< >12345.6789 <
>%-012.9g< >12345.6789< >12345.6789 <
>%g< >-12345.6789< >-12345.7<
>%+g< >-12345.6789< >-12345.7<
>%g< >1234567.89< >1.23457e+06<
>%+g< >1234567.89< >+1.23457e+06<
>%#g< >1234567.89< >1.23457e+06<
>%g< >-1234567.89< >-1.23457e+06<
>%+g< >-1234567.89< >-1.23457e+06<
>%#g< >-1234567.89< >-1.23457e+06<
>%g< >0.00012345< >0.00012345<
>%g< >0.000012345< >1.2345e-05<
>%g< >1234567E96< >1.23457e+102<
>%g< >.1234567E-101< >1.23457e-102<
>%g< >0< >0<
>%13g< >1234567.89< > 1.23457e+06<
>%+13g< >1234567.89< > +1.23457e+06<
>%013g< >1234567.89< >001.23457e+06<
>%-13g< >1234567.89< >1.23457e+06 <
>%g< >.1234567E-101< >1.23457e-102< >exponent too small skip: os390<
>%g< >1234567E96< >1.23457e+102< >exponent too big skip: os390<
>%h< >''< >%h INVALID<
>%i< >123456.789< >123456< >Synonym for %d<
>%j< >''< >%j INVALID<
>%k< >''< >%k INVALID<
>%l< >''< >%l INVALID<
>%m< >''< >%m INVALID<
>%s< >sprintf('%%n%n %d', $n, $n)< >%n 2< >Slight sneakiness to test %n<
>%o< >2**32-1< >37777777777<
>%+o< >2**32-1< >37777777777<
>%#o< >2**32-1< >037777777777<
>%o< >642< >1202< >check smaller octals across platforms<
>%+o< >642< >1202<
>%#o< >642< >01202<
>%d< >$p=sprintf('%p',$p);$p=~/^[0-9a-f]+$/< >1< >Coarse hack: hex from %p?<
>%d< >$p=sprintf('%-8p',$p);$p=~/^[0-9a-f]+\s*$/< >1< >Coarse hack: hex from %p?<
>%#p< >''< >%#p INVALID<
>%q< >''< >%q INVALID<
>%r< >''< >%r INVALID<
>%s< >'string'< >string<
>%10s< >'string'< > string<
>%+10s< >'string'< > string<
>%#10s< >'string'< > string<
>%010s< >'string'< >0000string<
>%0*s< >[10, 'string']< >0000string<
>%-10s< >'string'< >string <
>%3s< >'string'< >string<
>%.3s< >'string'< >str<
>%.*s< >[3, 'string']< >str<
>%t< >''< >%t INVALID<
>%u< >2**32-1< >4294967295<
>%+u< >2**32-1< >4294967295<
>%#u< >2**32-1< >4294967295<
>%12u< >2**32-1< > 4294967295<
>%012u< >2**32-1< >004294967295<
>%-12u< >2**32-1< >4294967295 <
>%-012u< >2**32-1< >4294967295 <
>%v< >''< >%v INVALID<
>%w< >''< >%w INVALID<
>%x< >2**32-1< >ffffffff<
>%+x< >2**32-1< >ffffffff<
>%#x< >2**32-1< >0xffffffff<
>%10x< >2**32-1< > ffffffff<
>%010x< >2**32-1< >00ffffffff<
>%-10x< >2**32-1< >ffffffff <
>%-010x< >2**32-1< >ffffffff <
>%0-10x< >2**32-1< >ffffffff <
>%0*x< >[-10, ,2**32-1]< >ffffffff <
>%y< >''< >%y INVALID<
>%z< >''< >%z INVALID<
>%2$d %1$d< >[12, 34]< >34 12<
>%*2$d< >[12, 3]< > 12<
>%2$d %d< >[12, 34]< >34 12<
>%2$d %d %d< >[12, 34]< >34 12 34<
>%3$d %d %d< >[12, 34, 56]< >56 12 34<
>%2$*3$d %d< >[12, 34, 3]< > 34 12<
>%*3$2$d %d< >[12, 34, 3]< >%*3$2$d 12 INVALID<
>%2$d< >12< >0 UNINIT<
>%0$d< >12< >%0$d INVALID<
>%1$$d< >12< >%1$$d INVALID<
>%1$1$d< >12< >%1$1$d INVALID<
>%*2$*2$d< >[12, 3]< >%*2$*2$d INVALID<
>%*2*2$d< >[12, 3]< >%*2*2$d INVALID<
>%*2$1d< >[12, 3]< >%*2$1d INVALID<
>%0v2.2d< >''< ><
>%vc,%d< >[63, 64, 65]< >?,64<
>%vd,%d< >[1, 2, 3]< >49,2<
>%vf,%d< >[1, 2, 3]< >1.000000,2<
>%vp< >''< >%vp INVALID<
>%vs,%d< >[1, 2, 3]< >1,2<
>%v_< >''< >%v_ INVALID<
>%v#x< >''< >%v#x INVALID<
>%v02x< >"foo\012"< >66.6f.6f.0a<
>%V-%s< >["Hello"]< >%V-Hello INVALID<
>%K %d %d< >[13, 29]< >%K 13 29 INVALID<
>%*.*K %d< >[13, 29, 76]< >%*.*K 13 INVALID<
>%4$K %d< >[45, 67]< >%4$K 45 INVALID<
>%d %K %d< >[23, 45]< >23 %K 45 INVALID<
>%*v*999\$d %d %d< >[11, 22, 33]< >%*v*999\$d 11 22 INVALID<
>%#b< >0< >0<
>%#o< >0< >0<
>%#x< >0< >0<
>%2918905856$v2d< >''< ><
>%*2918905856$v2d< >''< > UNINIT<
--- NEW FILE: getpid.t ---
#!perl -w
# Tests if $$ and getppid return consistent values across threads
BEGIN {
chdir 't' if -d 't';
@INC = qw(../lib);
require './test.pl';
}
use strict;
use Config;
BEGIN {
if (!$Config{useithreads}) {
print "1..0 # Skip: no ithreads\n";
exit;
}
if (!$Config{d_getppid}) {
print "1..0 # Skip: no getppid\n";
exit;
}
if ($ENV{PERL_CORE_MINITEST}) {
print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
exit 0;
}
eval 'use threads; use threads::shared';
plan tests => 3;
if ($@) {
fail("unable to load thread modules");
}
else {
pass("thread modules loaded");
}
}
my ($pid, $ppid) = ($$, getppid());
my $pid2 : shared = 0;
my $ppid2 : shared = 0;
new threads( sub { ($pid2, $ppid2) = ($$, getppid()); } ) -> join();
is($pid, $pid2, 'pids');
is($ppid, $ppid2, 'ppids');
--- NEW FILE: goto_xs.t ---
#!./perl
# tests for "goto &sub"-ing into XSUBs
# $RCSfile: goto_xs.t,v $$Revision: 1.2 $$Date: 2006-12-04 17:02:02 $
# Note: This only tests things that should *work*. At some point, it may
# be worth while to write some failure tests for things that should
# *break* (such as calls with wrong number of args). For now, I'm
# guessing that if all of these work correctly, the bad ones will
# break correctly as well.
BEGIN { $| = 1; }
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
$ENV{PERL5LIB} = "../lib";
# turn warnings into fatal errors
$SIG{__WARN__} = sub { die "WARNING: @_" } ;
foreach (qw(Fcntl XS::APItest)) {
eval "require $_"
or do { print "1..0\n# $_ unavailable, can't test XS goto.\n"; exit 0 }
}
}
print "1..10\n";
# We don't know what symbols are defined in platform X's system headers.
# We don't even want to guess, because some platform out there will
# likely do the unthinkable. However, Fcntl::constant("LOCK_SH",0)
# should always return a value, even on platforms which don't define the
# cpp symbol; Fcntl.xs says:
# /* We support flock() on systems which don't have it, so
# always supply the constants. */
# If this ceases to be the case, we're in trouble. =)
$VALID = 'LOCK_SH';
### First, we check whether Fcntl::constant returns sane answers.
# Fcntl::constant("LOCK_SH",0) should always succeed.
$value = Fcntl::constant($VALID);
print((!defined $value)
? "not ok 1\n# Sanity check broke, remaining tests will fail.\n"
: "ok 1\n");
### OK, we're ready to do real tests.
# test "goto &function_constant"
sub goto_const { goto &Fcntl::constant; }
$ret = goto_const($VALID);
print(($ret == $value) ? "ok 2\n" : "not ok 2\n# ($ret != $value)\n");
# test "goto &$function_package_and_name"
$FNAME1 = 'Fcntl::constant';
sub goto_name1 { goto &$FNAME1; }
$ret = goto_name1($VALID);
print(($ret == $value) ? "ok 3\n" : "not ok 3\n# ($ret != $value)\n");
# test "goto &$function_package_and_name" again, with dirtier stack
$ret = goto_name1($VALID);
print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n");
$ret = goto_name1($VALID);
print(($ret == $value) ? "ok 5\n" : "not ok 5\n# ($ret != $value)\n");
# test "goto &$function_name" from local package
package Fcntl;
$FNAME2 = 'constant';
sub goto_name2 { goto &$FNAME2; }
package main;
$ret = Fcntl::goto_name2($VALID);
print(($ret == $value) ? "ok 6\n" : "not ok 6\n# ($ret != $value)\n");
# test "goto &$function_ref"
$FREF = \&Fcntl::constant;
sub goto_ref { goto &$FREF; }
$ret = goto_ref($VALID);
print(($ret == $value) ? "ok 7\n" : "not ok 7\n# ($ret != $value)\n");
### tests where the args are not on stack but in GvAV(defgv) (ie, @_)
# test "goto &function_constant" from a sub called without arglist
sub call_goto_const { &goto_const; }
$ret = call_goto_const($VALID);
print(($ret == $value) ? "ok 8\n" : "not ok 8\n# ($ret != $value)\n");
# test "goto &$function_package_and_name" from a sub called without arglist
sub call_goto_name1 { &goto_name1; }
$ret = call_goto_name1($VALID);
print(($ret == $value) ? "ok 9\n" : "not ok 9\n# ($ret != $value)\n");
# test "goto &$function_ref" from a sub called without arglist
sub call_goto_ref { &goto_ref; }
$ret = call_goto_ref($VALID);
print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n");
--- NEW FILE: repeat.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
require './test.pl';
plan(tests => 42);
# compile time
is('-' x 5, '-----', 'compile time x');
is('-' x 3.1, '---', 'compile time 3.1');
is('-' x 3.9, '---', 'compile time 3.9');
is('-' x 1, '-', ' x 1');
is('-' x 0, '', ' x 0');
is('-' x -1, '', ' x -1');
is('-' x undef, '', ' x undef');
is('-' x "foo", '', ' x "foo"');
is('-' x "3rd", '---', ' x "3rd"');
is('ab' x 3, 'ababab', ' more than one char');
# run time
$a = '-';
is($a x 5, '-----', 'run time x');
is($a x 3.1, '---', ' x 3.1');
is($a x 3.9, '---', ' x 3.9');
is($a x 1, '-', ' x 1');
is($a x 0, '', ' x 0');
is($a x -3, '', ' x -3');
is($a x undef, '', ' x undef');
is($a x "foo", '', ' x "foo"');
is($a x "3rd", '---', ' x "3rd"');
$a = 'ab';
is($a x 3, 'ababab', ' more than one char');
$a = 'ab';
is($a x 0, '', ' more than one char');
$a = 'ab';
is($a x -12, '', ' more than one char');
$a = 'xyz';
$a x= 2;
is($a, 'xyzxyz', 'x=2');
$a x= 1;
is($a, 'xyzxyz', 'x=1');
$a x= 0;
is($a, '', 'x=0');
@x = (1,2,3);
is(join('', @x x 4), '3333', '@x x Y');
is(join('', (@x) x 4), '123123123123', '(@x) x Y');
is(join('', (@x,()) x 4), '123123123123', '(@x,()) x Y');
is(join('', (@x,1) x 4), '1231123112311231', '(@x,1) x Y');
is(join(':', () x 4), '', '() x Y');
is(join(':', (9) x 4), '9:9:9:9', '(X) x Y');
is(join(':', (9,9) x 4), '9:9:9:9:9:9:9:9', '(X,X) x Y');
is(join('', (split(//,"123")) x 2), '123123', 'split and x');
is(join('', @x x -12), '', '@x x -12');
is(join('', (@x) x -14), '', '(@x) x -14');
# This test is actually testing for Digital C compiler optimizer bug,
# present in Dec C versions 5.* and 6.0 (used in Digital UNIX and VMS),
# found in December 1998. The bug was reported to Digital^WCompaq as
# DECC 2745 (21-Dec-1998)
# GEM_BUGS 7619 (23-Dec-1998)
# As of April 1999 the bug has been fixed in Tru64 UNIX 5.0 and is planned
# to be fixed also in 4.0G.
#
# The bug was as follows: broken code was produced for util.c:repeatcpy()
# (a utility function for the 'x' operator) in the case *all* these
# four conditions held:
#
# (1) len == 1
# (2) "from" had the 8th bit on in its single character
# (3) count > 7 (the 'x' count > 16)
# (4) the highest optimization level was used in compilation
# (which is the default when compiling Perl)
#
# The bug looked like this (. being the eight-bit character and ? being \xff):
#
# 16 ................
# 17 .........???????.
# 18 .........???????..
# 19 .........???????...
# 20 .........???????....
# 21 .........???????.....
# 22 .........???????......
# 23 .........???????.......
# 24 .........???????.???????
# 25 .........???????.???????.
#
# The bug was triggered in the "if (len == 1)" branch. The fix
# was to introduce a new temporary variable. In diff -u format:
#
# register char *frombase = from;
#
# if (len == 1) {
#- todo = *from;
#+ register char c = *from;
# while (count-- > 0)
#- *to++ = todo;
#+ *to++ = c;
# return;
# }
#
# The bug could also be (obscurely) avoided by changing "from" to
# be an unsigned char pointer.
#
# This obscure bug was not found by the then test suite but instead
# by Mark.Martinec at nsc.ijs.si while trying to install Digest-MD5-2.00.
#
# jhi at iki.fi
#
is("\xdd" x 24, "\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd", 'Dec C bug');
# When we use a list repeat in a scalar context, it behaves like
# a scalar repeat. Make sure that works properly, and doesn't leave
# extraneous values on the stack.
# -- robin at kitsite.com
my ($x, $y) = scalar ((1,2)x2);
is($x, "22", 'list repeat in scalar context');
is($y, undef, ' no extra values on stack');
# Make sure the stack doesn't get truncated too much - the left
# operand of the eq binop needs to remain!
is(77, scalar ((1,7)x2), 'stack truncation');
# perlbug 20011113.110 works in 5.6.1, broken in 5.7.2
{
my $x= [("foo") x 2];
is( join('', @$x), 'foofoo', 'list repeat in anon array ref broken [ID 20011113.110]' );
}
# [ID 20010809.028] x operator not copying elements in 'for' list?
{
local $TODO = "x operator not copying elements in 'for' list? [ID 20010809.028]";
my $x = 'abcd';
my $y = '';
for (($x =~ /./g) x 2) {
$y .= chop;
}
is($y, 'abcdabcd');
}
# [perl #35885]
is( (join ',', (qw(a b c) x 3)), 'a,b,c,a,b,c,a,b,c', 'x on qw produces list' );
--- NEW FILE: fh.t ---
#!./perl
BEGIN {
chdir 't';
@INC = '../lib';
require './test.pl';
}
plan tests => 8;
# symbolic filehandles should only result in glob entries with FH constructors
$|=1;
my $a = "SYM000";
ok(!defined(fileno($a)));
ok(!defined *{$a});
select select $a;
ok(defined *{$a});
$a++;
ok(!close $a);
ok(!defined *{$a});
ok(open($a, ">&STDOUT"));
ok(defined *{$a});
ok(close $a);
--- NEW FILE: regexp.t ---
#!./perl
# The tests are in a separate file 't/op/re_tests'.
# Each line in that file is a separate test.
# There are five columns, separated by tabs.
#
# Column 1 contains the pattern, optionally enclosed in C<''>.
# Modifiers can be put after the closing C<'>.
#
# Column 2 contains the string to be matched.
#
# Column 3 contains the expected result:
# y expect a match
# n expect no match
# c expect an error
# B test exposes a known bug in Perl, should be skipped
# b test exposes a known bug in Perl, should be skipped if noamp
#
# Columns 4 and 5 are used only if column 3 contains C<y> or C<c>.
#
# Column 4 contains a string, usually C<$&>.
#
# Column 5 contains the expected result of double-quote
# interpolating that string after the match, or start of error message.
#
# Column 6, if present, contains a reason why the test is skipped.
# This is printed with "skipped", for harness to pick up.
#
# \n in the tests are interpolated, as are variables of the form ${\w+}.
#
# If you want to add a regular expression test that can't be expressed
# in this format, don't add it here: put it in op/pat.t instead.
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
$iters = shift || 1; # Poor man performance suite, 10000 is OK.
open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests') || open(TESTS,':op:re_tests') ||
die "Can't open re_tests";
while (<TESTS>) { }
$numtests = $.;
seek(TESTS,0,0);
$. = 0;
$bang = sprintf "\\%03o", ord "!"; # \41 would not be portable.
$ffff = chr(0xff) x 2;
$nulnul = "\0" x 2;
$| = 1;
print "1..$numtests\n# $iters iterations\n";
TEST:
while (<TESTS>) {
chomp;
s/\\n/\n/g;
($pat, $subject, $result, $repl, $expect, $reason) = split(/\t/,$_,6);
$input = join(':',$pat,$subject,$result,$repl,$expect);
infty_subst(\$pat);
infty_subst(\$expect);
$pat = "'$pat'" unless $pat =~ /^[:']/;
$pat =~ s/(\$\{\w+\})/$1/eeg;
$pat =~ s/\\n/\n/g;
$subject =~ s/(\$\{\w+\})/$1/eeg;
$subject =~ s/\\n/\n/g;
$expect =~ s/(\$\{\w+\})/$1/eeg;
$expect =~ s/\\n/\n/g;
$expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
$skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//));
$reason = 'skipping $&' if $reason eq '' && $skip_amp;
$result =~ s/B//i unless $skip;
for $study ('', 'study \$subject') {
$c = $iters;
eval "$study; \$match = (\$subject =~ m$pat) while \$c--; \$got = \"$repl\";";
chomp( $err = $@ );
if ($result eq 'c') {
if ($err !~ m!^\Q$expect!) { print "not ok $. (compile) $input => `$err'\n"; next TEST }
last; # no need to study a syntax error
}
elsif ( $skip ) {
print "ok $. # skipped", length($reason) ? " $reason" : '', "\n";
next TEST;
}
elsif ($@) {
print "not ok $. $input => error `$err'\n"; next TEST;
}
elsif ($result eq 'n') {
if ($match) { print "not ok $. ($study) $input => false positive\n"; next TEST }
}
else {
if (!$match || $got ne $expect) {
print "not ok $. ($study) $input => `$got', match=$match\n";
next TEST;
}
}
}
print "ok $.\n";
}
close(TESTS);
sub infty_subst # Special-case substitution
{ # of $reg_infty and friends
my $tp = shift;
$$tp =~ s/,\$reg_infty_m}/,$reg_infty_m}/o;
$$tp =~ s/,\$reg_infty_p}/,$reg_infty_p}/o;
$$tp =~ s/,\$reg_infty}/,$reg_infty}/o;
}
--- NEW FILE: my_stash.t ---
#!./perl
package Foo;
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use Test;
plan tests => 7;
use constant MyClass => 'Foo::Bar::Biz::Baz';
{
package Foo::Bar::Biz::Baz;
1;
}
for (qw(Foo Foo:: MyClass __PACKAGE__)) {
eval "sub { my $_ \$obj = shift; }";
ok ! $@;
# print $@ if $@;
}
use constant NoClass => 'Nope::Foo::Bar::Biz::Baz';
for (qw(Nope Nope:: NoClass)) {
eval "sub { my $_ \$obj = shift; }";
ok $@;
# print $@ if $@;
}
--- NEW FILE: filetest.t ---
#!./perl
# There are few filetest operators that are portable enough to test.
# See pod/perlport.pod for details.
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
use Config;
plan(tests => 10);
ok( -d 'op' );
ok( -f 'TEST' );
ok( !-f 'op' );
ok( !-d 'TEST' );
ok( -r 'TEST' );
# make sure TEST is r-x
eval { chmod 0555, 'TEST' or die "chmod 0555, 'TEST' failed: $!" };
chomp ($bad_chmod = $@);
$oldeuid = $>; # root can read and write anything
eval '$> = 1'; # so switch uid (may not be implemented)
print "# oldeuid = $oldeuid, euid = $>\n";
SKIP: {
if (!$Config{d_seteuid}) {
skip('no seteuid');
}
elsif ($Config{config_args} =~/Dmksymlinks/) {
skip('we cannot chmod symlinks');
}
elsif ($bad_chmod) {
skip( $bad_chmod );
}
else {
ok( !-w 'TEST' );
}
}
# Scripts are not -x everywhere so cannot test that.
eval '$> = $oldeuid'; # switch uid back (may not be implemented)
# this would fail for the euid 1
# (unless we have unpacked the source code as uid 1...)
ok( -r 'op' );
# this would fail for the euid 1
# (unless we have unpacked the source code as uid 1...)
SKIP: {
if ($Config{d_seteuid}) {
ok( -w 'op' );
} else {
skip('no seteuid');
}
}
ok( -x 'op' ); # Hohum. Are directories -x everywhere?
is( "@{[grep -r, qw(foo io noo op zoo)]}", "io op" );
--- NEW FILE: tiehandle.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
my @expect;
my $data = "";
my @data = ();
require './test.pl';
plan(tests => 41);
sub compare {
return unless @expect;
return ::fail() unless(@_ == @expect);
for my $i (0..$#_) {
next if $_[$i] eq $expect[$i];
return ::fail();
}
::pass();
}
package Implement;
sub TIEHANDLE {
::compare(TIEHANDLE => @_);
my ($class, at val) = @_;
return bless \@val,$class;
}
sub PRINT {
::compare(PRINT => @_);
1;
}
sub PRINTF {
::compare(PRINTF => @_);
2;
}
sub READLINE {
::compare(READLINE => @_);
wantarray ? @data : shift @data;
}
sub GETC {
::compare(GETC => @_);
substr($data,0,1);
}
sub READ {
::compare(READ => @_);
substr($_[1],$_[3] || 0) = substr($data,0,$_[2]);
3;
}
sub WRITE {
::compare(WRITE => @_);
$data = substr($_[1],$_[3] || 0, $_[2]);
length($data);
}
sub CLOSE {
::compare(CLOSE => @_);
5;
}
package main;
use Symbol;
my $fh = gensym;
@expect = (TIEHANDLE => 'Implement');
my $ob = tie *$fh,'Implement';
is(ref($ob), 'Implement');
is(tied(*$fh), $ob);
@expect = (PRINT => $ob,"some","text");
$r = print $fh @expect[2,3];
is($r, 1);
@expect = (PRINTF => $ob,"%s","text");
$r = printf $fh @expect[2,3];
is($r, 2);
$text = (@data = ("the line\n"))[0];
@expect = (READLINE => $ob);
$ln = <$fh>;
is($ln, $text);
@expect = ();
@in = @data = qw(a line at a time);
@line = <$fh>;
@expect = @in;
compare(@line);
@expect = (GETC => $ob);
$data = "abc";
$ch = getc $fh;
is($ch, "a");
$buf = "xyz";
@expect = (READ => $ob, $buf, 3);
$data = "abc";
$r = read $fh,$buf,3;
is($r, 3);
is($buf, "abc");
$buf = "xyzasd";
@expect = (READ => $ob, $buf, 3,3);
$data = "abc";
$r = sysread $fh,$buf,3,3;
is($r, 3);
is($buf, "xyzabc");
$buf = "qwerty";
@expect = (WRITE => $ob, $buf, 4,1);
$data = "";
$r = syswrite $fh,$buf,4,1;
is($r, 4);
is($data, "wert");
$buf = "qwerty";
@expect = (WRITE => $ob, $buf, 4);
$data = "";
$r = syswrite $fh,$buf,4;
is($r, 4);
is($data, "qwer");
$buf = "qwerty";
@expect = (WRITE => $ob, $buf, 6);
$data = "";
$r = syswrite $fh,$buf;
is($r, 6);
is($data, "qwerty");
@expect = (CLOSE => $ob);
$r = close $fh;
is($r, 5);
# Does aliasing work with tied FHs?
*ALIAS = *$fh;
@expect = (PRINT => $ob,"some","text");
$r = print ALIAS @expect[2,3];
is($r, 1);
{
use warnings;
# Special case of aliasing STDERR, which used
# to dump core when warnings were enabled
local *STDERR = *$fh;
@expect = (PRINT => $ob,"some","text");
$r = print STDERR @expect[2,3];
is($r, 1);
}
{
# Test for change #11536
package Foo;
use strict;
sub TIEHANDLE { bless {} }
my $cnt = 'a';
sub READ {
$_[1] = $cnt++;
1;
}
sub do_read {
my $fh = shift;
read $fh, my $buff, 1;
::pass();
}
$|=1;
tie *STDIN, 'Foo';
read STDIN, my $buff, 1;
::pass();
do_read(\*STDIN);
untie *STDIN;
}
{
# test for change 11639: Can't localize *FH, then tie it
{
local *foo;
tie %foo, 'Blah';
}
ok(!tied %foo);
{
local *bar;
tie @bar, 'Blah';
}
ok(!tied @bar);
{
local *BAZ;
tie *BAZ, 'Blah';
}
ok(!tied *BAZ);
package Blah;
sub TIEHANDLE {bless {}}
sub TIEHASH {bless {}}
sub TIEARRAY {bless {}}
}
{
# warnings should pass to the PRINT method of tied STDERR
my @received;
local *STDERR = *$fh;
no warnings 'redefine';
local *Implement::PRINT = sub { @received = @_ };
$r = warn("some", "text", "\n");
@expect = (PRINT => $ob,"sometext\n");
compare(PRINT => @received);
use warnings;
print undef;
like($received[1], qr/Use of uninitialized value/);
}
{
# [ID 20020713.001] chomp($data=<tied_fh>)
local *TEST;
tie *TEST, 'CHOMP';
my $data;
chomp($data = <TEST>);
is($data, 'foobar');
package CHOMP;
sub TIEHANDLE { bless {}, $_[0] }
sub READLINE { "foobar\n" }
}
--- NEW FILE: utfhash.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
plan(tests => 97);
}
use strict;
# Two hashes one will all keys 8-bit possible (initially), other
# with a utf8 requiring key from the outset.
my %hash8 = ( "\xff" => 0xff,
"\x7f" => 0x7f,
);
my %hashu = ( "\xff" => 0xff,
"\x7f" => 0x7f,
"\x{1ff}" => 0x1ff,
);
# Check that we can find the 8-bit things by various litterals
is($hash8{"\x{00ff}"},0xFF);
is($hash8{"\x{007f}"},0x7F);
is($hash8{"\xff"},0xFF);
is($hash8{"\x7f"},0x7F);
is($hashu{"\x{00ff}"},0xFF);
is($hashu{"\x{007f}"},0x7F);
is($hashu{"\xff"},0xFF);
is($hashu{"\x7f"},0x7F);
# Now try same thing with variables forced into various forms.
foreach ("\x7f","\xff")
{
my $a = $_; # Force a copy
utf8::upgrade($a);
is($hash8{$a},ord($a));
is($hashu{$a},ord($a));
utf8::downgrade($a);
is($hash8{$a},ord($a));
is($hashu{$a},ord($a));
my $b = $a.chr(100);
chop($b);
is($hash8{$b},ord($b));
is($hashu{$b},ord($b));
}
# Check we have not got an spurious extra keys
is(join('',sort { ord $a <=> ord $b } keys %hash8),"\x7f\xff");
is(join('',sort { ord $a <=> ord $b } keys %hashu),"\x7f\xff\x{1ff}");
# Now add a utf8 key to the 8-bit hash
$hash8{chr(0x1ff)} = 0x1ff;
# Check we have not got an spurious extra keys
is(join('',sort { ord $a <=> ord $b } keys %hash8),"\x7f\xff\x{1ff}");
foreach ("\x7f","\xff","\x{1ff}")
{
my $a = $_;
utf8::upgrade($a);
is($hash8{$a},ord($a));
my $b = $a.chr(100);
chop($b);
is($hash8{$b},ord($b));
}
# and remove utf8 from the other hash
is(delete $hashu{chr(0x1ff)},0x1ff);
is(join('',sort keys %hashu),"\x7f\xff");
foreach ("\x7f","\xff")
{
my $a = $_;
utf8::upgrade($a);
is($hashu{$a},ord($a));
utf8::downgrade($a);
is($hashu{$a},ord($a));
my $b = $a.chr(100);
chop($b);
is($hashu{$b},ord($b));
}
{
print "# Unicode hash keys and \\w\n";
# This is not really a regex test but regexes bring
# out the issue nicely.
use strict;
my $u3 = "f\x{df}\x{100}";
my $u2 = substr($u3,0,2);
my $u1 = substr($u2,0,1);
my $u0 = chr (0xdf)x4; # Make this 4 chars so that all lengths are distinct.
my @u = ($u0, $u1, $u2, $u3);
while (@u) {
my %u = (map {( $_, $_)} @u);
my $keys = scalar @u;
$keys .= ($keys == 1) ? " key" : " keys";
for (keys %u) {
my $l = 0 + /^\w+$/;
my $r = 0 + $u{$_} =~ /^\w+$/;
is ($l, $r, "\\w on keys with $keys, key of length " . length $_);
}
my $more;
do {
$more = 0;
# Want to do this direct, rather than copying to a temporary variable
# The first time each will return key and value at the start of the hash.
# each will return () after we've done the last pair. $more won't get
# set then, and the do will exit.
for (each %u) {
$more = 1;
my $l = 0 + /^\w+$/;
my $r = 0 + $u{$_} =~ /^\w+$/;
is ($l, $r, "\\w on each, with $keys, key of length " . length $_);
}
} while ($more);
for (%u) {
my $l = 0 + /^\w+$/;
my $r = 0 + $u{$_} =~ /^\w+$/;
is ($l, $r, "\\w on hash with $keys, key of length " . length $_);
}
pop @u;
undef %u;
}
}
{
my $utf8_sz = my $bytes_sz = "\x{df}";
$utf8_sz .= chr 256;
chop ($utf8_sz);
my (%bytes_first, %utf8_first);
$bytes_first{$bytes_sz} = $bytes_sz;
for (keys %bytes_first) {
my $l = 0 + /^\w+$/;
my $r = 0 + $bytes_first{$_} =~ /^\w+$/;
is ($l, $r, "\\w on each, bytes");
}
$bytes_first{$utf8_sz} = $utf8_sz;
for (keys %bytes_first) {
my $l = 0 + /^\w+$/;
my $r = 0 + $bytes_first{$_} =~ /^\w+$/;
is ($l, $r, "\\w on each, bytes now utf8");
}
$utf8_first{$utf8_sz} = $utf8_sz;
for (keys %utf8_first) {
my $l = 0 + /^\w+$/;
my $r = 0 + $utf8_first{$_} =~ /^\w+$/;
is ($l, $r, "\\w on each, utf8");
}
$utf8_first{$bytes_sz} = $bytes_sz;
for (keys %utf8_first) {
my $l = 0 + /^\w+$/;
my $r = 0 + $utf8_first{$_} =~ /^\w+$/;
is ($l, $r, "\\w on each, utf8 now bytes");
}
}
{
# See if utf8 barewords work [perl #22969]
use utf8;
my %hash = (теÑÑ‚ => 123);
is($hash{теÑÑ‚}, $hash{'теÑÑ‚'});
is($hash{теÑÑ‚}, 123);
is($hash{'теÑÑ‚'}, 123);
%hash = (теÑÑ‚ => 123);
is($hash{теÑÑ‚}, $hash{'теÑÑ‚'});
is($hash{теÑÑ‚}, 123);
is($hash{'теÑÑ‚'}, 123);
}
--- NEW FILE: gmagic.t ---
#!./perl -w
BEGIN {
$| = 1;
chdir 't' if -d 't';
@INC = '../lib';
}
print "1..18\n";
my $t = 1;
tie my $c => 'Tie::Monitor';
sub ok {
my($ok, $got, $exp, $rexp, $wexp) = @_;
my($rgot, $wgot) = (tied $c)->init(0);
print $ok ? "ok $t\n" : "# expected $exp, got $got\nnot ok $t\n";
++$t;
if ($rexp == $rgot && $wexp == $wgot) {
print "ok $t\n";
} else {
print "# read $rgot expecting $rexp\n" if $rgot != $rexp;
print "# wrote $wgot expecting $wexp\n" if $wgot != $wexp;
print "not ok $t\n";
}
++$t;
}
sub ok_undef { ok(!defined($_[0]), shift, "undef", @_) }
sub ok_numeric { ok($_[0] == $_[1], @_) }
sub ok_string { ok($_[0] eq $_[1], @_) }
my($r, $s);
# the thing itself
ok_numeric($r = $c + 0, 0, 1, 0);
ok_string($r = "$c", '0', 1, 0);
# concat
ok_string($c . 'x', '0x', 1, 0);
ok_string('x' . $c, 'x0', 1, 0);
$s = $c . $c;
ok_string($s, '00', 2, 0);
$r = 'x';
$s = $c = $r . 'y';
ok_string($s, 'xy', 1, 1);
$s = $c = $c . 'x';
ok_string($s, '0x', 2, 1);
$s = $c = 'x' . $c;
ok_string($s, 'x0', 2, 1);
$s = $c = $c . $c;
ok_string($s, '00', 3, 1);
# adapted from Tie::Counter by Abigail
package Tie::Monitor;
sub TIESCALAR {
my($class, $value) = @_;
bless {
read => 0,
write => 0,
values => [ 0 ],
};
}
sub FETCH {
my $self = shift;
++$self->{read};
$self->{values}[$#{ $self->{values} }];
}
sub STORE {
my($self, $value) = @_;
++$self->{write};
push @{ $self->{values} }, $value;
}
sub init {
my $self = shift;
my @results = ($self->{read}, $self->{write});
$self->{read} = $self->{write} = 0;
$self->{values} = [ 0 ];
@results;
}
--- NEW FILE: wantarray.t ---
#!./perl
print "1..12\n";
sub context {
my ( $cona, $testnum ) = @_;
my $conb = (defined wantarray) ? ( wantarray ? 'A' : 'S' ) : 'V';
unless ( $cona eq $conb ) {
print "# Context $conb should be $cona\nnot ";
}
print "ok $testnum\n";
}
context('V',1);
$a = context('S',2);
@a = context('A',3);
scalar context('S',4);
$a = scalar context('S',5);
($a) = context('A',6);
($a) = scalar context('S',7);
{
# [ID 20020626.011] incorrect wantarray optimisation
sub simple { wantarray ? 1 : 2 }
sub inline {
my $a = wantarray ? simple() : simple();
$a;
}
my @b = inline();
my $c = inline();
print +(@b == 1 && "@b" eq "2") ? "ok 8\n" : "not ok 8\t# <@b>\n";
print +($c == 2) ? "ok 9\n" : "not ok 9\t# <$c>\n";
}
my $qcontext = q{
$q = (defined wantarray) ? ( wantarray ? 'A' : 'S' ) : 'V';
};
eval $qcontext;
print $q eq 'V' ? "ok 10\n" : "not ok 10\n";
$a = eval $qcontext;
print $q eq 'S' ? "ok 11\n" : "not ok 11\n";
@a = eval $qcontext;
print $q eq 'A' ? "ok 12\n" : "not ok 12\n";
1;
--- NEW FILE: crypt.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
}
BEGIN {
use Config;
require "test.pl";
if( !$Config{d_crypt} ) {
skip_all("crypt unimplemented");
}
else {
plan(tests => 4);
}
}
# Can't assume too much about the string returned by crypt(),
# and about how many bytes of the encrypted (really, hashed)
# string matter.
#
# HISTORICALLY the results started with the first two bytes of the salt,
# followed by 11 bytes from the set [./0-9A-Za-z], and only the first
# eight characters mattered, but those are probably no more safe
# bets, given alternative encryption/hashing schemes like MD5,
# C2 (or higher) security schemes, and non-UNIX platforms.
SKIP: {
skip ("VOS crypt ignores salt.", 1) if ($^O eq 'vos');
ok(substr(crypt("ab", "cd"), 2) ne substr(crypt("ab", "ce"), 2), "salt makes a difference");
}
$a = "a\xFF\x{100}";
eval {$b = crypt($a, "cd")};
like($@, qr/Wide character in crypt/, "wide characters ungood");
chop $a; # throw away the wide character
eval {$b = crypt($a, "cd")};
is($@, '', "downgrade to eight bit characters");
is($b, crypt("a\xFF", "cd"), "downgrade results agree");
--- NEW FILE: defins.t ---
#!./perl -w
#
# test auto defined() test insertion
#
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
$SIG{__WARN__} = sub { $warns++; warn $_[0] };
print "1..14\n";
}
$wanted_filename = $^O eq 'VMS' ? '0.' : '0';
$saved_filename = $^O eq 'MacOS' ? ':0' : './0';
print "not " if $warns;
print "ok 1\n";
open(FILE,">$saved_filename");
print FILE "1\n";
print FILE "0";
close(FILE);
open(FILE,"<$saved_filename");
my $seen = 0;
my $dummy;
while (my $name = <FILE>)
{
$seen++ if $name eq '0';
}
print "not " unless $seen;
print "ok 2\n";
seek(FILE,0,0);
$seen = 0;
my $line = '';
do
{
$seen++ if $line eq '0';
} while ($line = <FILE>);
print "not " unless $seen;
print "ok 3\n";
seek(FILE,0,0);
$seen = 0;
while (($seen ? $dummy : $name) = <FILE>)
{
$seen++ if $name eq '0';
}
print "not " unless $seen;
print "ok 4\n";
seek(FILE,0,0);
$seen = 0;
my %where;
while ($where{$seen} = <FILE>)
{
$seen++ if $where{$seen} eq '0';
}
print "not " unless $seen;
print "ok 5\n";
close FILE;
opendir(DIR,($^O eq 'MacOS' ? ':' : '.'));
$seen = 0;
while (my $name = readdir(DIR))
{
$seen++ if $name eq $wanted_filename;
}
print "not " unless $seen;
print "ok 6\n";
rewinddir(DIR);
$seen = 0;
$dummy = '';
while (($seen ? $dummy : $name) = readdir(DIR))
{
$seen++ if $name eq $wanted_filename;
}
print "not " unless $seen;
print "ok 7\n";
rewinddir(DIR);
$seen = 0;
while ($where{$seen} = readdir(DIR))
{
$seen++ if $where{$seen} eq $wanted_filename;
}
print "not " unless $seen;
print "ok 8\n";
$seen = 0;
while (my $name = glob('*'))
{
$seen++ if $name eq $wanted_filename;
}
print "not " unless $seen;
print "ok 9\n";
$seen = 0;
$dummy = '';
while (($seen ? $dummy : $name) = glob('*'))
{
$seen++ if $name eq $wanted_filename;
}
print "not " unless $seen;
print "ok 10\n";
$seen = 0;
while ($where{$seen} = glob('*'))
{
$seen++ if $where{$seen} eq $wanted_filename;
}
print "not " unless $seen;
print "ok 11\n";
unlink($saved_filename);
my %hash = (0 => 1, 1 => 2);
$seen = 0;
while (my $name = each %hash)
{
$seen++ if $name eq '0';
}
print "not " unless $seen;
print "ok 12\n";
$seen = 0;
$dummy = '';
while (($seen ? $dummy : $name) = each %hash)
{
$seen++ if $name eq '0';
}
print "not " unless $seen;
print "ok 13\n";
$seen = 0;
while ($where{$seen} = each %hash)
{
$seen++ if $where{$seen} eq '0';
}
print "not " unless $seen;
print "ok 14\n";
--- NEW FILE: 64bitint.t ---
#./perl
BEGIN {
eval { my $q = pack "q", 0 };
if ($@) {
print "1..0 # Skip: no 64-bit types\n";
exit(0);
}
chdir 't' if -d 't';
@INC = '../lib';
}
# This could use many more tests.
# so that using > 0xfffffff constants and
# 32+ bit integers don't cause noise
use warnings;
no warnings qw(overflow portable);
print "1..67\n";
# as 6 * 6 = 36, the last digit of 6**n will always be six. Hence the last
# digit of 16**n will always be six. Hence 16**n - 1 will always end in 5.
# Assumption is that UVs will always be a multiple of 4 bits long.
my $UV_max = ~0;
die "UV_max eq '$UV_max', doesn't end in 5; your UV isn't 4n bits long :-(."
unless $UV_max =~ /5$/;
my $UV_max_less3 = $UV_max - 3;
my $maths_preserves_UVs = $UV_max_less3 =~ /^\d+2$/; # 5 - 3 is 2.
if ($maths_preserves_UVs) {
print "# This perl's maths preserves all bits of a UV.\n";
} else {
print "# This perl's maths does not preserve all bits of a UV.\n";
}
my $q = 12345678901;
my $r = 23456789012;
my $f = 0xffffffff;
my $x;
my $y;
$x = unpack "q", pack "q", $q;
print "not " unless $x == $q && $x > $f;
print "ok 1\n";
$x = sprintf("%lld", 12345678901);
print "not " unless $x eq $q && $x > $f;
print "ok 2\n";
$x = sprintf("%lld", $q);
print "not " unless $x == $q && $x eq $q && $x > $f;
print "ok 3\n";
$x = sprintf("%Ld", $q);
print "not " unless $x == $q && $x eq $q && $x > $f;
print "ok 4\n";
$x = sprintf("%qd", $q);
print "not " unless $x == $q && $x eq $q && $x > $f;
print "ok 5\n";
$x = sprintf("%llx", $q);
print "not " unless hex($x) == 0x2dfdc1c35 && hex($x) > $f;
print "ok 6\n";
$x = sprintf("%Lx", $q);
print "not " unless hex($x) == 0x2dfdc1c35 && hex($x) > $f;
print "ok 7\n";
$x = sprintf("%qx", $q);
print "not " unless hex($x) == 0x2dfdc1c35 && hex($x) > $f;
print "ok 8\n";
$x = sprintf("%llo", $q);
print "not " unless oct("0$x") == 0133767016065 && oct($x) > $f;
print "ok 9\n";
$x = sprintf("%Lo", $q);
print "not " unless oct("0$x") == 0133767016065 && oct($x) > $f;
print "ok 10\n";
$x = sprintf("%qo", $q);
print "not " unless oct("0$x") == 0133767016065 && oct($x) > $f;
print "ok 11\n";
$x = sprintf("%llb", $q);
print "not " unless oct("0b$x") == 0b1011011111110111000001110000110101 &&
oct("0b$x") > $f;
print "ok 12\n";
$x = sprintf("%Lb", $q);
print "not " unless oct("0b$x") == 0b1011011111110111000001110000110101 &&
oct("0b$x") > $f;
print "ok 13\n";
$x = sprintf("%qb", $q);
print "not " unless oct("0b$x") == 0b1011011111110111000001110000110101 &&
oct("0b$x") > $f;
print "ok 14\n";
$x = sprintf("%llu", $q);
print "not " unless $x eq $q && $x > $f;
print "ok 15\n";
$x = sprintf("%Lu", $q);
print "not " unless $x == $q && $x eq $q && $x > $f;
print "ok 16\n";
$x = sprintf("%qu", $q);
print "not " unless $x == $q && $x eq $q && $x > $f;
print "ok 17\n";
$x = sprintf("%D", $q);
print "not " unless $x == $q && $x eq $q && $x > $f;
print "ok 18\n";
$x = sprintf("%U", $q);
print "not " unless $x == $q && $x eq $q && $x > $f;
print "ok 19\n";
$x = sprintf("%O", $q);
print "not " unless oct($x) == $q && oct($x) > $f;
print "ok 20\n";
$x = $q + $r;
print "not " unless $x == 35802467913 && $x > $f;
print "ok 21\n";
$x = $q - $r;
print "not " unless $x == -11111110111 && -$x > $f;
print "ok 22\n";
if ($^O ne 'unicos') {
$x = $q * 1234567;
print "not " unless $x == 15241567763770867 && $x > $f;
print "ok 23\n";
$x /= 1234567;
print "not " unless $x == $q && $x > $f;
print "ok 24\n";
$x = 98765432109 % 12345678901;
print "not " unless $x == 901;
print "ok 25\n";
# The following 12 tests adapted from op/inc.
$a = 9223372036854775807;
$c = $a++;
print "not " unless $a == 9223372036854775808;
print "ok 26\n";
$a = 9223372036854775807;
$c = ++$a;
print "not "
unless $a == 9223372036854775808 && $c == $a;
print "ok 27\n";
$a = 9223372036854775807;
$c = $a + 1;
print "not "
unless $a == 9223372036854775807 && $c == 9223372036854775808;
print "ok 28\n";
$a = -9223372036854775808;
$c = $a--;
print "not "
unless $a == -9223372036854775809 && $c == -9223372036854775808;
print "ok 29\n";
$a = -9223372036854775808;
$c = --$a;
print "not "
unless $a == -9223372036854775809 && $c == $a;
print "ok 30\n";
$a = -9223372036854775808;
$c = $a - 1;
print "not "
unless $a == -9223372036854775808 && $c == -9223372036854775809;
print "ok 31\n";
$a = 9223372036854775808;
$a = -$a;
$c = $a--;
print "not "
unless $a == -9223372036854775809 && $c == -9223372036854775808;
print "ok 32\n";
$a = 9223372036854775808;
$a = -$a;
$c = --$a;
print "not "
unless $a == -9223372036854775809 && $c == $a;
print "ok 33\n";
$a = 9223372036854775808;
$a = -$a;
$c = $a - 1;
print "not "
unless $a == -9223372036854775808 && $c == -9223372036854775809;
print "ok 34\n";
$a = 9223372036854775808;
$b = -$a;
$c = $b--;
print "not "
unless $b == -$a-1 && $c == -$a;
print "ok 35\n";
$a = 9223372036854775808;
$b = -$a;
$c = --$b;
print "not "
unless $b == -$a-1 && $c == $b;
print "ok 36\n";
$a = 9223372036854775808;
$b = -$a;
$b = $b - 1;
print "not "
unless $b == -(++$a);
print "ok 37\n";
} else {
# Unicos has imprecise doubles (14 decimal digits or so),
# especially if operating near the UV/IV limits the low-order bits
# become mangled even by simple arithmetic operations.
for (23..37) {
print "ok $_ # skipped: too imprecise numbers\n";
}
}
$x = '';
print "not " unless (vec($x, 1, 64) = $q) == $q;
print "ok 38\n";
print "not " unless vec($x, 1, 64) == $q && vec($x, 1, 64) > $f;
print "ok 39\n";
print "not " unless vec($x, 0, 64) == 0 && vec($x, 2, 64) == 0;
print "ok 40\n";
print "not " unless ~0 == 0xffffffffffffffff;
print "ok 41\n";
print "not " unless (0xffffffff<<32) == 0xffffffff00000000;
print "ok 42\n";
print "not " unless ((0xffffffff)<<32)>>32 == 0xffffffff;
print "ok 43\n";
print "not " unless 1<<63 == 0x8000000000000000;
print "ok 44\n";
print "not " unless (sprintf "%#Vx", 1<<63) eq '0x8000000000000000';
print "ok 45\n";
print "not " unless (0x8000000000000000 | 1) == 0x8000000000000001;
print "ok 46\n";
print "not "
unless (0xf000000000000000 & 0x8000000000000000) == 0x8000000000000000;
print "ok 47\n";
print "not "
unless (0xf000000000000000 ^ 0xfffffffffffffff0) == 0x0ffffffffffffff0;
print "ok 48\n";
print "not "
unless (sprintf "%b", ~0) eq
'1111111111111111111111111111111111111111111111111111111111111111';
print "ok 49\n";
print "not "
unless (sprintf "%64b", ~0) eq
'1111111111111111111111111111111111111111111111111111111111111111';
print "ok 50\n";
print "not " unless (sprintf "%d", ~0>>1) eq '9223372036854775807';
print "ok 51\n";
print "not " unless (sprintf "%u", ~0) eq '18446744073709551615';
print "ok 52\n";
# If the 53..55 fail you have problems in the parser's string->int conversion,
# see toke.c:scan_num().
$q = -9223372036854775808;
print "# $q ne\n# -9223372036854775808\nnot " unless "$q" eq "-9223372036854775808";
print "ok 53\n";
$q = 9223372036854775807;
print "# $q ne\n# 9223372036854775807\nnot " unless "$q" eq "9223372036854775807";
print "ok 54\n";
$q = 18446744073709551615;
print "# $q ne\n# 18446744073709551615\nnot " unless "$q" eq "18446744073709551615";
print "ok 55\n";
# Test that sv_2nv then sv_2iv is the same as sv_2iv direct
# fails if whatever Atol is defined as can't actually cope with >32 bits.
my $num = 4294967297;
my $string = "4294967297";
{
use integer;
$num += 0;
$string += 0;
}
if ($num eq $string) {
print "ok 56\n";
} else {
print "not ok 56 # \"$num\" ne \"$string\"\n";
}
# Test that sv_2nv then sv_2uv is the same as sv_2uv direct
$num = 4294967297;
$string = "4294967297";
$num &= 0;
$string &= 0;
if ($num eq $string) {
print "ok 57\n";
} else {
print "not ok 57 # \"$num\" ne \"$string\"\n";
}
$q = "18446744073709551616e0";
$q += 0;
print "# \"18446744073709551616e0\" += 0 gives $q\nnot " if "$q" eq "18446744073709551615";
print "ok 58\n";
# 0xFFFFFFFFFFFFFFFF == 1 * 3 * 5 * 17 * 257 * 641 * 65537 * 6700417'
$q = 0xFFFFFFFFFFFFFFFF / 3;
if ($q == 0x5555555555555555 and ($q != 0x5555555555555556
or !$maths_preserves_UVs)) {
print "ok 59\n";
} else {
print "not ok 59 # 0xFFFFFFFFFFFFFFFF / 3 = $q\n";
print "# Should not be floating point\n" if $q =~ tr/e.//;
}
$q = 0xFFFFFFFFFFFFFFFF % 0x5555555555555555;
if ($q == 0) {
print "ok 60\n";
} else {
print "not ok 60 # 0xFFFFFFFFFFFFFFFF % 0x5555555555555555 => $q\n";
}
$q = 0xFFFFFFFFFFFFFFFF % 0xFFFFFFFFFFFFFFF0;
if ($q == 0xF) {
print "ok 61\n";
} else {
print "not ok 61 # 0xFFFFFFFFFFFFFFFF % 0xFFFFFFFFFFFFFFF0 => $q\n";
}
$q = 0x8000000000000000 % 9223372036854775807;
if ($q == 1) {
print "ok 62\n";
} else {
print "not ok 62 # 0x8000000000000000 % 9223372036854775807 => $q\n";
}
$q = 0x8000000000000000 % -9223372036854775807;
if ($q == -9223372036854775806) {
print "ok 63\n";
} else {
print "not ok 63 # 0x8000000000000000 % -9223372036854775807 => $q\n";
}
{
use integer;
$q = hex "0x123456789abcdef0";
if ($q == 0x123456789abcdef0 and $q != 0x123456789abcdef1) {
print "ok 64\n";
} else {
printf "not ok 64 # hex \"0x123456789abcdef0\" = $q (%X)\n", $q;
print "# Should not be floating point\n" if $q =~ tr/e.//;
}
$q = oct "0x123456789abcdef0";
if ($q == 0x123456789abcdef0 and $q != 0x123456789abcdef1) {
print "ok 65\n";
} else {
printf "not ok 65 # oct \"0x123456789abcdef0\" = $q (%X)\n", $q;
print "# Should not be floating point\n" if $q =~ tr/e.//;
}
$q = oct "765432176543217654321";
if ($q == 0765432176543217654321 and $q != 0765432176543217654322) {
print "ok 66\n";
} else {
printf "not ok 66 # oct \"765432176543217654321\" = $q (%o)\n", $q;
print "# Should not be floating point\n" if $q =~ tr/e.//;
}
$q = oct "0b0101010101010101010101010101010101010101010101010101010101010101";
if ($q == 0x5555555555555555 and $q != 0x5555555555555556) {
print "ok 67\n";
} else {
printf "not ok 67 # oct \"0b0101010101010101010101010101010101010101010101010101010101010101\" = $q (%b)\n", $q;
print "# Should not be floating point\n" if $q =~ tr/e.//;
}
}
# eof
--- NEW FILE: avhv.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
use warnings;
no warnings 'deprecated';
use strict;
use vars qw(@fake %fake);
require Tie::Array;
package Tie::BasicArray;
@Tie::BasicArray::ISA = 'Tie::Array';
sub TIEARRAY { bless [], $_[0] }
sub STORE { $_[0]->[$_[1]] = $_[2] }
sub FETCH { $_[0]->[$_[1]] }
sub FETCHSIZE { scalar(@{$_[0]})}
sub STORESIZE { $#{$_[0]} = $_[1]+1 }
package main;
plan tests => 36;
my $sch = {
'abc' => 1,
'def' => 2,
'jkl' => 3,
};
# basic normal array
$a = [];
$a->[0] = $sch;
$a->{'abc'} = 'ABC';
$a->{'def'} = 'DEF';
$a->{'jkl'} = 'JKL';
my @keys = keys %$a;
my @values = values %$a;
is ($#keys, 2);
is ($#values, 2);
my $i = 0; # stop -w complaints
while (my ($key,$value) = each %$a) {
if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
$key =~ y/a-z/A-Z/;
$i++ if $key eq $value;
}
}
is ($i, 3);
# quick check with tied array
tie @fake, 'Tie::StdArray';
$a = \@fake;
$a->[0] = $sch;
$a->{'abc'} = 'ABC';
is ($a->{'abc'}, 'ABC');
# quick check with tied array
tie @fake, 'Tie::BasicArray';
$a = \@fake;
$a->[0] = $sch;
$a->{'abc'} = 'ABC';
is ($a->{'abc'}, 'ABC');
# quick check with tied array & tied hash
require Tie::Hash;
tie %fake, 'Tie::StdHash';
%fake = %$sch;
$a->[0] = \%fake;
$a->{'abc'} = 'ABC';
is ($a->{'abc'}, 'ABC');
# hash slice
{
no warnings 'uninitialized';
my $slice = join('', 'x',@$a{'abc','def'},'x');
is ($slice, 'xABCx');
}
# evaluation in scalar context
my $avhv = [{}];
ok (!%$avhv);
push @$avhv, "a";
ok (!%$avhv);
$avhv = [];
eval { $a = %$avhv };
like ($@, qr/^Can't coerce array into hash/);
$avhv = [{foo=>1, bar=>2}];
like (%$avhv, qr,^\d+/\d+,);
# check if defelem magic works
sub f {
is ($_[0], 'a');
$_[0] = 'b';
}
$a = [{key => 1}, 'a'];
f($a->{key});
is ($a->[1], 'b');
# check if exists() is behaving properly
$avhv = [{foo=>1,bar=>2,pants=>3}];
ok (!exists $avhv->{bar});
$avhv->{pants} = undef;
ok (exists $avhv->{pants});
ok (!exists $avhv->{bar});
$avhv->{bar} = 10;
ok (exists $avhv->{bar});
is ($avhv->{bar}, 10);
my $v = delete $avhv->{bar};
is ($v, 10);
ok (!exists $avhv->{bar});
$avhv->{foo} = 'xxx';
$avhv->{bar} = 'yyy';
$avhv->{pants} = 'zzz';
my @x = delete @{$avhv}{'foo','pants'};
is ("@x", "xxx zzz");
is ("$avhv->{bar}", "yyy");
# hash assignment
%$avhv = ();
is (ref($avhv->[0]), 'HASH');
my %hv = %$avhv;
ok (!grep defined, values %hv);
ok (!grep ref, keys %hv);
%$avhv = (foo => 29, pants => 2, bar => 0);
is ("@$avhv[1..3]", '29 0 2');
my $extra;
my @extra;
($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!");
is ("@$avhv[1..3]", '42 HIKE! 53');
is ($extra, 'moo');
%$avhv = ();
(%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!");
is ("@$avhv[1..3]", '42 HIKE! 53');
ok (!defined $extra);
@extra = qw(whatever and stuff);
%$avhv = ();
(%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!");
is ("@$avhv[1..3]", '42 HIKE! 53');
is (@extra, 0);
%$avhv = ();
(@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!");
is (ref $avhv->[0], 'HASH');
is (@extra, 6);
# Check hash slices (BUG ID 20010423.002)
$avhv = [{foo=>1, bar=>2}];
@$avhv{"foo", "bar"} = (42, 53);
is ($avhv->{foo}, 42);
is ($avhv->{bar}, 53);
--- NEW FILE: do.t ---
#!./perl
# $RCSfile: do.t,v $$Revision: 1.2 $$Date: 2006-12-04 17:02:01 $
sub foo1
{
ok($_[0]);
'value';
}
sub foo2
{
shift;
ok($_[0]);
$x = 'value';
$x;
}
my $test = 1;
sub ok {
my($ok, $name) = @_;
# You have to do it this way or VMS will get confused.
printf "%s %d%s\n", $ok ? "ok" : "not ok",
$test,
defined $name ? " - $name" : '';
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
$test++;
return $ok;
}
print "1..22\n";
# Test do &sub and proper @_ handling.
$_[0] = 0;
$result = do foo1(1);
ok( $result eq 'value', ":$result: eq :value:" );
ok( $_[0] == 0 );
$_[0] = 0;
$result = do foo2(0,1,0);
ok( $result eq 'value', ":$result: eq :value:" );
ok( $_[0] == 0 );
$result = do{ ok 1; 'value';};
ok( $result eq 'value', ":$result: eq :value:" );
sub blather {
ok 1 foreach @_;
}
do blather("ayep","sho nuff");
@x = ("jeepers", "okydoke");
@y = ("uhhuh", "yeppers");
do blather(@x,"noofie", at y);
unshift @INC, '.';
if (open(DO, ">$$.16")) {
print DO "ok(1, 'do in scalar context') if defined wantarray && not wantarray\n";
close DO or die "Could not close: $!";
}
my $a = do "$$.16";
if (open(DO, ">$$.17")) {
print DO "ok(1, 'do in list context') if defined wantarray && wantarray\n";
close DO or die "Could not close: $!";
}
my @a = do "$$.17";
if (open(DO, ">$$.18")) {
print DO "ok(1, 'do in void context') if not defined wantarray\n";
close DO or die "Could not close: $!";
}
do "$$.18";
# bug ID 20010920.007
eval qq{ do qq(a file that does not exist); };
ok( !$@, "do on a non-existing file, first try" );
eval qq{ do uc qq(a file that does not exist); };
ok( !$@, "do on a non-existing file, second try" );
# 6 must be interpreted as a file name here
ok( (!defined do 6) && $!, "'do 6' : $!" );
# [perl #19545]
push @t, ($u = (do {} . "This should be pushed."));
ok( $#t == 0, "empty do result value" );
END {
1 while unlink("$$.16", "$$.17", "$$.18");
}
--- NEW FILE: lex_assign.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
$| = 1;
umask 0;
$xref = \ "";
$runme = ($^O eq 'VMS' ? 'MCR ' : '') . $^X;
@a = (1..5);
%h = (1..6);
$aref = \@a;
$href = \%h;
open OP, qq{$runme -le "print 'aaa Ok ok' for 1..100"|};
$chopit = 'aaaaaa';
@chopar = (113 .. 119);
$posstr = '123456';
$cstr = 'aBcD.eF';
pos $posstr = 3;
$nn = $n = 2;
sub subb {"in s"}
@INPUT = <DATA>;
@simple_input = grep /^\s*\w+\s*\$\w+\s*[#\n]/, @INPUT;
print "1..", (10 + @INPUT + @simple_input), "\n";
$ord = 0;
sub wrn {"@_"}
# Check correct optimization of ucfirst etc
$ord++;
my $a = "AB";
my $b = "\u\L$a";
print "not " unless $b eq 'Ab';
print "ok $ord\n";
# Check correct destruction of objects:
my $dc = 0;
sub A::DESTROY {$dc += 1}
$a=8;
my $b;
{ my $c = 6; $b = bless \$c, "A"}
$ord++;
print "not " unless $dc == 0;
print "ok $ord\n";
$b = $a+5;
$ord++;
print "not " unless $dc == 1;
print "ok $ord\n";
$ord++;
my $xxx = 'b';
$xxx = 'c' . ($xxx || 'e');
print "not " unless $xxx eq 'cb';
print "ok $ord\n";
{ # Check calling STORE
my $sc = 0;
sub B::TIESCALAR {bless [11], 'B'}
sub B::FETCH { -(shift->[0]) }
sub B::STORE { $sc++; my $o = shift; $o->[0] = 17 + shift }
my $m;
tie $m, 'B';
$m = 100;
$ord++;
print "not " unless $sc == 1;
print "ok $ord\n";
my $t = 11;
$m = $t + 89;
$ord++;
print "not " unless $sc == 2;
print "ok $ord\n";
$ord++;
print "# $m\nnot " unless $m == -117;
print "ok $ord\n";
$m += $t;
$ord++;
print "not " unless $sc == 3;
print "ok $ord\n";
$ord++;
print "# $m\nnot " unless $m == 89;
print "ok $ord\n";
}
# Chains of assignments
my ($l1, $l2, $l3, $l4);
my $zzzz = 12;
$zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 1 + $zzzz;
$ord++;
print "# $zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 13\nnot "
unless $zzz1 == 13 and $zzz2 == 13 and $l1 == 13
and $l2 == 13 and $l3 == 13 and $l4 == 13;
print "ok $ord\n";
for (@INPUT) {
$ord++;
($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/;
$comment = $op unless defined $comment;
chomp;
$op = "$op==$op" unless $op =~ /==/;
($op, $expectop) = $op =~ /(.*)==(.*)/;
$skip = ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.*\Q$^O\E.*\)/i)
? "skip" : "# '$_'\nnot";
$integer = ($comment =~ /^i_/) ? "use integer" : '' ;
(print "#skipping $comment:\nok $ord\n"), next if $skip eq 'skip';
eval <<EOE;
local \$SIG{__WARN__} = \\&wrn;
my \$a = 'fake';
$integer;
\$a = $op;
\$b = $expectop;
if (\$a ne \$b) {
print "# \$comment: got `\$a', expected `\$b'\n";
print "\$skip " if \$a ne \$b or \$skip eq 'skip';
}
print "ok \$ord\\n";
EOE
if ($@) {
if ($@ =~ /is unimplemented/) {
print "# skipping $comment: unimplemented:\nok $ord\n";
} else {
warn $@;
print "# '$_'\nnot ok $ord\n";
}
}
}
for (@simple_input) {
$ord++;
($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/;
$comment = $op unless defined $comment;
chomp;
($operator, $variable) = /^\s*(\w+)\s*\$(\w+)/ or warn "misprocessed '$_'\n";
eval <<EOE;
local \$SIG{__WARN__} = \\&wrn;
my \$$variable = "Ac# Ca\\nxxx";
\$$variable = $operator \$$variable;
\$toself = \$$variable;
\$direct = $operator "Ac# Ca\\nxxx";
print "# \\\$$variable = $operator \\\$$variable\\nnot "
unless \$toself eq \$direct;
print "ok \$ord\\n";
EOE
if ($@) {
if ($@ =~ /is unimplemented/) {
print "# skipping $comment: unimplemented:\nok $ord\n";
} elsif ($@ =~ /Can't (modify|take log of 0)/) {
print "# skipping $comment: syntax not good for selfassign:\nok $ord\n";
} else {
warn $@;
print "# '$_'\nnot ok $ord\n";
}
}
}
__END__
ref $xref # ref
ref $cstr # ref nonref
`$runme -e "print qq[1\\n]"` # backtick skip(MSWin32)
`$undefed` # backtick undef skip(MSWin32)
<*> # glob
<OP> # readline
'faked' # rcatline
(@z = (1 .. 3)) # aassign
chop $chopit # chop
(chop (@x=@chopar)) # schop
chomp $chopit # chomp
(chop (@x=@chopar)) # schomp
pos $posstr # pos
pos $chopit # pos returns undef
$nn++==2 # postinc
$nn++==3 # i_postinc
$nn--==4 # postdec
$nn--==3 # i_postdec
$n ** $n # pow
$n * $n # multiply
$n * $n # i_multiply
$n / $n # divide
$n / $n # i_divide
$n % $n # modulo
$n % $n # i_modulo
$n x $n # repeat
$n + $n # add
$n + $n # i_add
$n - $n # subtract
$n - $n # i_subtract
$n . $n # concat
$n . $a=='2fake' # concat with self
"3$a"=='3fake' # concat with self in stringify
"$n" # stringify
$n << $n # left_shift
$n >> $n # right_shift
$n <=> $n # ncmp
$n <=> $n # i_ncmp
$n cmp $n # scmp
$n & $n # bit_and
$n ^ $n # bit_xor
$n | $n # bit_or
-$n # negate
-$n # i_negate
~$n # complement
atan2 $n,$n # atan2
sin $n # sin
cos $n # cos
'???' # rand
exp $n # exp
log $n # log
sqrt $n # sqrt
int $n # int
hex $n # hex
oct $n # oct
abs $n # abs
length $posstr # length
substr $posstr, 2, 2 # substr
vec("abc",2,8) # vec
index $posstr, 2 # index
rindex $posstr, 2 # rindex
sprintf "%i%i", $n, $n # sprintf
ord $n # ord
chr $n # chr
crypt $n, $n # crypt
ucfirst ($cstr . "a") # ucfirst padtmp
ucfirst $cstr # ucfirst
lcfirst $cstr # lcfirst
uc $cstr # uc
lc $cstr # lc
quotemeta $cstr # quotemeta
@$aref # rv2av
@$undefed # rv2av undef
(each %h) % 2 == 1 # each
values %h # values
keys %h # keys
%$href # rv2hv
pack "C2", $n,$n # pack
split /a/, "abad" # split
join "a"; @a # join
push @a,3==6 # push
unshift @aaa # unshift
reverse @a # reverse
reverse $cstr # reverse - scal
grep $_, 1,0,2,0,3 # grepwhile
map "x$_", 1,0,2,0,3 # mapwhile
subb() # entersub
caller # caller
warn "ignore this\n" # warn
'faked' # die
open BLAH, "<non-existent" # open
fileno STDERR # fileno
umask 0 # umask
select STDOUT # sselect
select undef,undef,undef,0 # select
getc OP # getc
'???' # read
'???' # sysread
'???' # syswrite
'???' # send
'???' # recv
'???' # tell
'???' # fcntl
'???' # ioctl
'???' # flock
'???' # accept
'???' # shutdown
'???' # ftsize
'???' # ftmtime
'???' # ftatime
'???' # ftctime
chdir 'non-existent' # chdir
'???' # chown
'???' # chroot
unlink 'non-existent' # unlink
chmod 'non-existent' # chmod
utime 'non-existent' # utime
rename 'non-existent', 'non-existent1' # rename
link 'non-existent', 'non-existent1' # link
'???' # symlink
readlink 'non-existent', 'non-existent1' # readlink
'???' # mkdir
'???' # rmdir
'???' # telldir
'???' # fork
'???' # wait
'???' # waitpid
system "$runme -e 0" # system skip(VMS)
'???' # exec
'???' # kill
getppid # getppid
getpgrp # getpgrp
'???' # setpgrp
getpriority $$, $$ # getpriority
'???' # setpriority
time # time
localtime $^T # localtime
gmtime $^T # gmtime
'???' # sleep: can randomly fail
'???' # alarm
'???' # shmget
'???' # shmctl
'???' # shmread
'???' # shmwrite
'???' # msgget
'???' # msgctl
'???' # msgsnd
'???' # msgrcv
'???' # semget
'???' # semctl
'???' # semop
'???' # getlogin
'???' # syscall
--- NEW FILE: list.t ---
#!./perl
print "1..31\n";
@foo = (1, 2, 3, 4);
if ($foo[0] == 1 && $foo[3] == 4) {print "ok 1\n";} else {print "not ok 1\n";}
$_ = join(':', at foo);
if ($_ eq '1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
($a,$b,$c,$d) = (1,2,3,4);
if ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 3\n";} else {print "not ok 3\n";}
($c,$b,$a) = split(/ /,"111 222 333");
if ("$a;$b;$c" eq '333;222;111') {print "ok 4\n";} else {print "not ok 4\n";}
($a,$b,$c) = ($c,$b,$a);
if ("$a;$b;$c" eq '111;222;333') {print "ok 5\n";} else {print "not ok 5 $a;$b;$c\n";}
($a, $b) = ($b, $a);
if ("$a;$b;$c" eq '222;111;333') {print "ok 6\n";} else {print "not ok 6\n";}
($a, $b[1], $c{2}, $d) = (1, 2, 3, 4);
if ($a eq 1) {print "ok 7\n";} else {print "not ok 7\n";}
if ($b[1] eq 2) {print "ok 8\n";} else {print "not ok 8\n";}
if ($c{2} eq 3) {print "ok 9\n";} else {print "not ok 9\n";}
if ($d eq 4) {print "ok 10\n";} else {print "not ok 10\n";}
@foo = (1,2,3,4,5,6,7,8);
($a, $b, $c, $d) = @foo;
print "#11 $a;$b;$c;$d eq 1;2;3;4\n";
if ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 11\n";} else {print "not ok 11\n";}
@foo = @bar = (1);
if (join(':', at foo, at bar) eq '1:1') {print "ok 12\n";} else {print "not ok 12\n";}
@foo = ();
@foo = 1+2+3;
if (join(':', at foo) eq '6') {print "ok 13\n";} else {print "not ok 13\n";}
for ($x = 0; $x < 3; $x++) {
($a, $b, $c) =
$x == 0?
('ok ', 14, "\n"):
$x == 1?
('ok ', 15, "\n"):
# default
('ok ', 16, "\n");
print $a,$b,$c;
}
@a = ($x == 12345 || (1,2,3));
if (join('', at a) eq '123') {print "ok 17\n";} else {print "not ok 17\n";}
@a = ($x == $x || (4,5,6));
if (join('', at a) eq '1') {print "ok 18\n";} else {print "not ok 18\n";}
if (join('',1,2,(3,4,5)) eq '12345'){print "ok 19\n";}else{print "not ok 19\n";}
if (join('',(1,2,3,4,5)) eq '12345'){print "ok 20\n";}else{print "not ok 20\n";}
if (join('',(1,2,3,4),5) eq '12345'){print "ok 21\n";}else{print "not ok 21\n";}
if (join('',1,(2,3,4),5) eq '12345'){print "ok 22\n";}else{print "not ok 22\n";}
if (join('',1,2,(3,4),5) eq '12345'){print "ok 23\n";}else{print "not ok 23\n";}
if (join('',1,2,3,(4),5) eq '12345'){print "ok 24\n";}else{print "not ok 24\n";}
for ($x = 0; $x < 3; $x++) {
($a, $b, $c) = do {
if ($x == 0) {
('ok ', 25, "\n");
}
elsif ($x == 1) {
('ok ', 26, "\n");
}
else {
('ok ', 27, "\n");
}
};
print $a,$b,$c;
}
# slices
{
my @a = (0, undef, undef, 3);
my @b = @a[1,2];
my @c = (0, undef, undef, 3)[1, 2];
print "not " unless @b == @c and @c == 2;
print "ok 28\n";
@b = (29, scalar @c[()]);
print "not " if join(':', at b) ne '29:';
print "ok 29\n";
my %h = (a => 1);
@b = (30, scalar @h{()});
print "not " if join(':', at b) ne '30:';
print "ok 30\n";
my $size = scalar(()[1..1]);
print "not " if $size != 0;
print "ok 31\n";
}
--- NEW FILE: delete.t ---
#!./perl
print "1..38\n";
# delete() on hash elements
$foo{1} = 'a';
$foo{2} = 'b';
$foo{3} = 'c';
$foo{4} = 'd';
$foo{5} = 'e';
$foo = delete $foo{2};
if ($foo eq 'b') {print "ok 1\n";} else {print "not ok 1 $foo\n";}
unless (exists $foo{2}) {print "ok 2\n";} else {print "not ok 2 $foo{2}\n";}
if ($foo{1} eq 'a') {print "ok 3\n";} else {print "not ok 3\n";}
if ($foo{3} eq 'c') {print "ok 4\n";} else {print "not ok 4\n";}
if ($foo{4} eq 'd') {print "ok 5\n";} else {print "not ok 5\n";}
if ($foo{5} eq 'e') {print "ok 6\n";} else {print "not ok 6\n";}
@foo = delete @foo{4, 5};
if (@foo == 2) {print "ok 7\n";} else {print "not ok 7 ", @foo+0, "\n";}
if ($foo[0] eq 'd') {print "ok 8\n";} else {print "not ok 8 ", $foo[0], "\n";}
if ($foo[1] eq 'e') {print "ok 9\n";} else {print "not ok 9 ", $foo[1], "\n";}
unless (exists $foo{4}) {print "ok 10\n";} else {print "not ok 10 $foo{4}\n";}
unless (exists $foo{5}) {print "ok 11\n";} else {print "not ok 11 $foo{5}\n";}
if ($foo{1} eq 'a') {print "ok 12\n";} else {print "not ok 12\n";}
if ($foo{3} eq 'c') {print "ok 13\n";} else {print "not ok 13\n";}
$foo = join('',values(%foo));
if ($foo eq 'ac' || $foo eq 'ca') {print "ok 14\n";} else {print "not ok 14\n";}
foreach $key (keys %foo) {
delete $foo{$key};
}
$foo{'foo'} = 'x';
$foo{'bar'} = 'y';
$foo = join('',values(%foo));
print +($foo eq 'xy' || $foo eq 'yx') ? "ok 15\n" : "not ok 15\n";
$refhash{"top"}->{"foo"} = "FOO";
$refhash{"top"}->{"bar"} = "BAR";
delete $refhash{"top"}->{"bar"};
@list = keys %{$refhash{"top"}};
print "@list" eq "foo" ? "ok 16\n" : "not ok 16 @list\n";
{
my %a = ('bar', 33);
my($a) = \(values %a);
my $b = \$a{bar};
my $c = \delete $a{bar};
print "not " unless $a == $b && $b == $c;
print "ok 17\n";
}
# delete() on array elements
@foo = ();
$foo[1] = 'a';
$foo[2] = 'b';
$foo[3] = 'c';
$foo[4] = 'd';
$foo[5] = 'e';
$foo = delete $foo[2];
if ($foo eq 'b') {print "ok 18\n";} else {print "not ok 18 $foo\n";}
unless (exists $foo[2]) {print "ok 19\n";} else {print "not ok 19 $foo[2]\n";}
if ($foo[1] eq 'a') {print "ok 20\n";} else {print "not ok 20\n";}
if ($foo[3] eq 'c') {print "ok 21\n";} else {print "not ok 21\n";}
if ($foo[4] eq 'd') {print "ok 22\n";} else {print "not ok 22\n";}
if ($foo[5] eq 'e') {print "ok 23\n";} else {print "not ok 23\n";}
@bar = delete @foo[4,5];
if (@bar == 2) {print "ok 24\n";} else {print "not ok 24 ", @bar+0, "\n";}
if ($bar[0] eq 'd') {print "ok 25\n";} else {print "not ok 25 ", $bar[0], "\n";}
if ($bar[1] eq 'e') {print "ok 26\n";} else {print "not ok 26 ", $bar[1], "\n";}
unless (exists $foo[4]) {print "ok 27\n";} else {print "not ok 27 $foo[4]\n";}
unless (exists $foo[5]) {print "ok 28\n";} else {print "not ok 28 $foo[5]\n";}
if ($foo[1] eq 'a') {print "ok 29\n";} else {print "not ok 29\n";}
if ($foo[3] eq 'c') {print "ok 30\n";} else {print "not ok 30\n";}
$foo = join('', at foo);
if ($foo eq 'ac') {print "ok 31\n";} else {print "not ok 31\n";}
if (@foo == 4) {print "ok 32\n";} else {print "not ok 32\n";}
foreach $key (0 .. $#foo) {
delete $foo[$key];
}
if (@foo == 0) {print "ok 33\n";} else {print "not ok 33\n";}
$foo[0] = 'x';
$foo[1] = 'y';
$foo = "@foo";
print +($foo eq 'x y') ? "ok 34\n" : "not ok 34\n";
$refary[0]->[0] = "FOO";
$refary[0]->[3] = "BAR";
delete $refary[0]->[3];
print @{$refary[0]} == 1 ? "ok 35\n" : "not ok 35 @list\n";
{
my @a = 33;
my($a) = \(@a);
my $b = \$a[0];
my $c = \delete $a[bar];
print "not " unless $a == $b && $b == $c;
print "ok 36\n";
}
{
# [perl #29127] scalar delete of empty slice returned garbage
my %h;
my ($x,$y) = (1, scalar delete @h{()});
print "not " if defined $y;
print "ok 37\n";
}
{
# [perl #30733] array delete didn't free returned element
my $x = 0;
sub X::DESTROY { $x++ }
{
my @a;
$a[0] = bless [], 'X';
my $y = delete $a[0];
}
print "not " unless $x == 1;
print "ok 38\n";
}
--- NEW FILE: utftaint.t ---
#!./perl -T
# tests whether tainting works with UTF-8
BEGIN {
if ($ENV{PERL_CORE_MINITEST}) {
print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
exit 0;
}
chdir 't' if -d 't';
@INC = qw(../lib);
}
use strict;
use Config;
BEGIN {
if ($Config{extensions} !~ m(\bList/Util\b)) {
print "1..0 # Skip: no Scalar::Util module\n";
exit 0;
}
}
use Scalar::Util qw(tainted);
use Test;
plan tests => 3*10 + 3*8 + 2*16;
my $cnt = 0;
my $arg = $ENV{PATH}; # a tainted value
use constant UTF8 => "\x{1234}";
sub is_utf8 {
my $s = shift;
return 0xB6 != ord pack('a*', chr(0xB6).$s);
}
for my $ary ([ascii => 'perl'], [latin1 => "\xB6"], [utf8 => "\x{100}"]) {
my $encode = $ary->[0];
my $string = $ary->[1];
my $taint = $arg; substr($taint, 0) = $ary->[1];
print tainted($taint) == tainted($arg)
? "ok " : "not ok ", ++$cnt, " # tainted: $encode, before test\n";
my $lconcat = $taint;
$lconcat .= UTF8;
print $lconcat eq $string.UTF8
? "ok " : "not ok ", ++$cnt, " # compare: $encode, concat left\n";
print tainted($lconcat) == tainted($arg)
? "ok " : "not ok ", ++$cnt, " # tainted: $encode, concat left\n";
my $rconcat = UTF8;
$rconcat .= $taint;
print $rconcat eq UTF8.$string
? "ok " : "not ok ", ++$cnt, " # compare: $encode, concat right\n";
print tainted($rconcat) == tainted($arg)
? "ok " : "not ok ", ++$cnt, " # tainted: $encode, concat right\n";
my $ljoin = join('!', $taint, UTF8);
print $ljoin eq join('!', $string, UTF8)
? "ok " : "not ok ", ++$cnt, " # compare: $encode, join left\n";
print tainted($ljoin) == tainted($arg)
? "ok " : "not ok ", ++$cnt, " # tainted: $encode, join left\n";
my $rjoin = join('!', UTF8, $taint);
print $rjoin eq join('!', UTF8, $string)
? "ok " : "not ok ", ++$cnt, " # compare: $encode, join right\n";
print tainted($rjoin) == tainted($arg)
? "ok " : "not ok ", ++$cnt, " # tainted: $encode, join right\n";
print tainted($taint) == tainted($arg)
? "ok " : "not ok ", ++$cnt, " # tainted: $encode, after test\n";
}
for my $ary ([ascii => 'perl'], [latin1 => "\xB6"], [utf8 => "\x{100}"]) {
my $encode = $ary->[0];
my $utf8 = pack('U*') . $ary->[1];
my $byte = pack('C0a*', $utf8);
my $taint = $arg; substr($taint, 0) = $utf8;
utf8::encode($taint);
print $taint eq $byte
? "ok " : "not ok ", ++$cnt, " # compare: $encode, encode utf8\n";
print pack('a*',$taint) eq pack('a*',$byte)
? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, encode utf8\n";
print !is_utf8($taint)
? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, encode utf8\n";
print tainted($taint) == tainted($arg)
? "ok " : "not ok ", ++$cnt, " # tainted: $encode, encode utf8\n";
my $taint = $arg; substr($taint, 0) = $byte;
utf8::decode($taint);
print $taint eq $utf8
? "ok " : "not ok ", ++$cnt, " # compare: $encode, decode byte\n";
print pack('a*',$taint) eq pack('a*',$utf8)
? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, decode byte\n";
print is_utf8($taint) eq ($encode ne 'ascii')
? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, decode byte\n";
print tainted($taint) == tainted($arg)
? "ok " : "not ok ", ++$cnt, " # tainted: $encode, decode byte\n";
}
for my $ary ([ascii => 'perl'], [latin1 => "\xB6"]) {
my $encode = $ary->[0];
my $up = pack('U*') . $ary->[1];
my $down = pack('C0a*', $ary->[1]);
my $taint = $arg; substr($taint, 0) = $up;
utf8::upgrade($taint);
print $taint eq $up
? "ok " : "not ok ", ++$cnt, " # compare: $encode, upgrade up\n";
print pack('a*',$taint) eq pack('a*',$up)
? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, upgrade up\n";
print is_utf8($taint)
? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, upgrade up\n";
print tainted($taint) == tainted($arg)
? "ok " : "not ok ", ++$cnt, " # tainted: $encode, upgrade up\n";
my $taint = $arg; substr($taint, 0) = $down;
utf8::upgrade($taint);
print $taint eq $up
? "ok " : "not ok ", ++$cnt, " # compare: $encode, upgrade down\n";
print pack('a*',$taint) eq pack('a*',$up)
? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, upgrade down\n";
print is_utf8($taint)
? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, upgrade down\n";
print tainted($taint) == tainted($arg)
? "ok " : "not ok ", ++$cnt, " # tainted: $encode, upgrade down\n";
my $taint = $arg; substr($taint, 0) = $up;
utf8::downgrade($taint);
print $taint eq $down
? "ok " : "not ok ", ++$cnt, " # compare: $encode, downgrade up\n";
print pack('a*',$taint) eq pack('a*',$down)
? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, downgrade up\n";
print !is_utf8($taint)
? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, downgrade up\n";
print tainted($taint) == tainted($arg)
? "ok " : "not ok ", ++$cnt, " # tainted: $encode, downgrade up\n";
my $taint = $arg; substr($taint, 0) = $down;
utf8::downgrade($taint);
print $taint eq $down
? "ok " : "not ok ", ++$cnt, " # compare: $encode, downgrade down\n";
print pack('a*',$taint) eq pack('a*',$down)
? "ok " : "not ok ", ++$cnt, " # bytecmp: $encode, downgrade down\n";
print !is_utf8($taint)
? "ok " : "not ok ", ++$cnt, " # is_utf8: $encode, downgrade down\n";
print tainted($taint) == tainted($arg)
? "ok " : "not ok ", ++$cnt, " # tainted: $encode, downgrade down\n";
}
--- NEW FILE: sprintf2.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
plan tests => 7 + 256;
is(
sprintf("%.40g ",0.01),
sprintf("%.40g", 0.01)." ",
q(the sprintf "%.<number>g" optimization)
);
is(
sprintf("%.40f ",0.01),
sprintf("%.40f", 0.01)." ",
q(the sprintf "%.<number>f" optimization)
);
{
chop(my $utf8_format = "%-3s\x{100}");
is(
sprintf($utf8_format, "\xe4"),
"\xe4 ",
q(width calculation under utf8 upgrade)
);
}
# Used to mangle PL_sv_undef
fresh_perl_is(
'print sprintf "xxx%n\n"; print undef',
'Modification of a read-only value attempted at - line 1.',
{ switches => [ '-w' ] },
q(%n should not be able to modify read-only constants),
);
# check %NNN$ for range bounds, especially negative 2's complement
{
my ($warn, $bad) = (0,0);
local $SIG{__WARN__} = sub {
if ($_[0] =~ /uninitialized/) {
$warn++
}
else {
$bad++
}
};
my $result = sprintf join('', map("%$_\$s%" . ~$_ . '$s', 1..20)),
qw(a b c d);
is($result, "abcd", "only four valid values");
is($warn, 36, "expected warnings");
is($bad, 0, "unexpected warnings");
}
{
foreach my $ord (0 .. 255) {
my $bad = 0;
local $SIG{__WARN__} = sub {
unless ($_[0] =~ /^Invalid conversion in sprintf/ ||
$_[0] =~ /^Use of uninitialized value in sprintf/) {
warn $_[0];
$bad++;
}
};
my $r = eval {sprintf '%v' . chr $ord};
is ($bad, 0, "pattern '%v' . chr $ord");
}
}
--- NEW FILE: args.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
require './test.pl';
plan( tests => 14 );
# test various operations on @_
sub new1 { bless \@_ }
{
my $x = new1("x");
my $y = new1("y");
is("@$y","y");
is("@$x","x");
}
sub new2 { splice @_, 0, 0, "a", "b", "c"; return \@_ }
{
my $x = new2("x");
my $y = new2("y");
is("@$x","a b c x");
is("@$y","a b c y");
}
sub new3 { goto &new1 }
{
my $x = new3("x");
my $y = new3("y");
is("@$y","y");
is("@$x","x");
}
sub new4 { goto &new2 }
{
my $x = new4("x");
my $y = new4("y");
is("@$x","a b c x");
is("@$y","a b c y");
}
# see if POPSUB gets to see the right pad across a dounwind() with
# a reified @_
sub methimpl {
my $refarg = \@_;
die( "got: @_\n" );
}
sub method {
&methimpl;
}
sub try {
eval { method('foo', 'bar'); };
print "# $@" if $@;
}
for (1..5) { try() }
pass();
# bug #21542 local $_[0] causes reify problems and coredumps
sub local1 { local $_[0] }
my $foo = 'foo'; local1($foo); local1($foo);
print "got [$foo], expected [foo]\nnot " if $foo ne 'foo';
pass();
sub local2 { local $_[0]; last L }
L: { local2 }
pass();
# blead has 9 tests for local(@_) from in t/op/nothr5005.t inserted here
# [perl #28032] delete $_[0] was freeing things too early
{
my $flag = 0;
sub X::DESTROY { $flag = 1 }
sub f {
delete $_[0];
ok(!$flag, 'delete $_[0] : in f');
}
{
my $x = bless [], 'X';
f($x);
ok(!$flag, 'delete $_[0] : after f');
}
ok($flag, 'delete $_[0] : outside block');
}
--- NEW FILE: bop.t ---
#!./perl
#
# test the bit operators '&', '|', '^', '~', '<<', and '>>'
#
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require "./test.pl";
require Config;
}
# Tests don't have names yet.
# If you find tests are failing, please try adding names to tests to track
# down where the failure is, and supply your new names as a patch.
# (Just-in-time test naming)
plan tests => 49;
# numerics
ok ((0xdead & 0xbeef) == 0x9ead);
ok ((0xdead | 0xbeef) == 0xfeef);
ok ((0xdead ^ 0xbeef) == 0x6042);
ok ((~0xdead & 0xbeef) == 0x2042);
# shifts
ok ((257 << 7) == 32896);
ok ((33023 >> 7) == 257);
# signed vs. unsigned
ok ((~0 > 0 && do { use integer; ~0 } == -1));
my $bits = 0;
for (my $i = ~0; $i; $i >>= 1) { ++$bits; }
my $cusp = 1 << ($bits - 1);
ok (($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0);
ok (($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0);
ok (($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0);
ok ((1 << ($bits - 1)) == $cusp &&
do { use integer; 1 << ($bits - 1) } == -$cusp);
ok (($cusp >> 1) == ($cusp / 2) &&
do { use integer; abs($cusp >> 1) } == ($cusp / 2));
$Aaz = chr(ord("A") & ord("z"));
$Aoz = chr(ord("A") | ord("z"));
$Axz = chr(ord("A") ^ ord("z"));
# short strings
is (("AAAAA" & "zzzzz"), ($Aaz x 5));
is (("AAAAA" | "zzzzz"), ($Aoz x 5));
is (("AAAAA" ^ "zzzzz"), ($Axz x 5));
# long strings
$foo = "A" x 150;
$bar = "z" x 75;
$zap = "A" x 75;
# & truncates
is (($foo & $bar), ($Aaz x 75 ));
# | does not truncate
is (($foo | $bar), ($Aoz x 75 . $zap));
# ^ does not truncate
is (($foo ^ $bar), ($Axz x 75 . $zap));
#
is ("ok \xFF\xFF\n" & "ok 19\n", "ok 19\n");
is ("ok 20\n" | "ok \0\0\n", "ok 20\n");
is ("o\000 \0001\000" ^ "\000k\0002\000\n", "ok 21\n");
#
is ("ok \x{FF}\x{FF}\n" & "ok 22\n", "ok 22\n");
is ("ok 23\n" | "ok \x{0}\x{0}\n", "ok 23\n");
is ("o\x{0} \x{0}4\x{0}" ^ "\x{0}k\x{0}2\x{0}\n", "ok 24\n");
#
is (sprintf("%vd", v4095 & v801), 801);
is (sprintf("%vd", v4095 | v801), 4095);
is (sprintf("%vd", v4095 ^ v801), 3294);
#
is (sprintf("%vd", v4095.801.4095 & v801.4095), '801.801');
is (sprintf("%vd", v4095.801.4095 | v801.4095), '4095.4095.4095');
is (sprintf("%vd", v801.4095 ^ v4095.801.4095), '3294.3294.4095');
#
is (sprintf("%vd", v120.300 & v200.400), '72.256');
is (sprintf("%vd", v120.300 | v200.400), '248.444');
is (sprintf("%vd", v120.300 ^ v200.400), '176.188');
#
my $a = v120.300;
my $b = v200.400;
$a ^= $b;
is (sprintf("%vd", $a), '176.188');
my $a = v120.300;
my $b = v200.400;
$a |= $b;
is (sprintf("%vd", $a), '248.444');
#
# UTF8 ~ behaviour
#
my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
my @not36;
for (0x100...0xFFF) {
$a = ~(chr $_);
if ($Is_EBCDIC) {
push @not36, sprintf("%#03X", $_)
if $a ne chr(~$_) or length($a) != 1;
}
else {
push @not36, sprintf("%#03X", $_)
if $a ne chr(~$_) or length($a) != 1 or ~$a ne chr($_);
}
}
is (join (', ', @not36), '');
my @not37;
for my $i (0xEEE...0xF00) {
for my $j (0x0..0x120) {
$a = ~(chr ($i) . chr $j);
if ($Is_EBCDIC) {
push @not37, sprintf("%#03X %#03X", $i, $j)
if $a ne chr(~$i).chr(~$j) or
length($a) != 2;
}
else {
push @not37, sprintf("%#03X %#03X", $i, $j)
if $a ne chr(~$i).chr(~$j) or
length($a) != 2 or
~$a ne chr($i).chr($j);
}
}
}
is (join (', ', @not37), '');
SKIP: {
skip "EBCDIC" if $Is_EBCDIC;
is (~chr(~0), "\0");
}
my @not39;
for my $i (0x100..0x120) {
for my $j (0x100...0x120) {
push @not39, sprintf("%#03X %#03X", $i, $j)
if ~(chr($i)|chr($j)) ne (~chr($i)&~chr($j));
}
}
is (join (', ', @not39), '');
my @not40;
for my $i (0x100..0x120) {
for my $j (0x100...0x120) {
push @not40, sprintf("%#03X %#03X", $i, $j)
if ~(chr($i)&chr($j)) ne (~chr($i)|~chr($j));
}
}
is (join (', ', @not40), '');
# More variations on 19 and 22.
is ("ok \xFF\x{FF}\n" & "ok 41\n", "ok 41\n");
is ("ok \x{FF}\xFF\n" & "ok 42\n", "ok 42\n");
# Tests to see if you really can do casts negative floats to unsigned properly
$neg1 = -1.0;
ok (~ $neg1 == 0);
$neg7 = -7.0;
ok (~ $neg7 == 6);
$a = "\0\x{100}"; chop($a);
ok(utf8::is_utf8($a)); # make sure UTF8 flag is still there
$a = ~$a;
is($a, "\xFF", "~ works with utf-8");
# [rt.perl.org 33003]
# This would cause a segfault without malloc wrap
SKIP: {
skip "No malloc wrap checks" unless $Config::Config{usemallocwrap};
like( runperl(prog => 'eval q($#a>>=1); print 1'), "^1\n?" );
}
# [perl #37616] Bug in &= (string) and/or m//
{
$a = "aa";
$a &= "a";
ok($a =~ /a+$/, 'ASCII "a" is NUL-terminated');
$b = "bb\x{100}";
$b &= "b";
ok($b =~ /b+$/, 'Unicode "b" is NUL-terminated');
}
--- NEW FILE: die.t ---
#!./perl
print "1..15\n";
$SIG{__DIE__} = sub { print ref($_[0]) ? ("ok ",$_[0]->[0]++,"\n") : @_ } ;
$err = "#[\000]\nok 1\n";
eval {
die $err;
};
print "not " unless $@ eq $err;
print "ok 2\n";
$x = [3];
eval { die $x; };
print "not " unless $x->[0] == 4;
print "ok 4\n";
eval {
eval {
die [ 5 ];
};
die if $@;
};
eval {
eval {
die bless [ 7 ], "Error";
};
die if $@;
};
print "not " unless ref($@) eq "Out";
print "ok 10\n";
{
package Error;
sub PROPAGATE {
print "ok ",$_[0]->[0]++,"\n";
bless [$_[0]->[0]], "Out";
}
}
{
# die/warn and utf8
use utf8;
local $SIG{__DIE__};
my $msg = "ce ºtii tu, bã ?\n";
eval { die $msg }; print "not " unless $@ eq $msg;
print "ok 11\n";
our $err;
local $SIG{__WARN__} = $SIG{__DIE__} = sub { $err = shift };
eval { die $msg }; print "not " unless $err eq $msg;
print "ok 12\n";
eval { warn $msg }; print "not " unless $err eq $msg;
print "ok 13\n";
eval qq/ use strict; \$\x{3b1} /;
print "not " unless $@ =~ /Global symbol "\$\x{3b1}"/;
print "ok 14\n";
}
# [perl #36470] got uninit warning if $@ was undef
{
my $ok = 1;
local $SIG{__DIE__};
local $SIG{__WARN__} = sub { $ok = 0 };
eval { undef $@; die };
print "not " unless $ok;
print "ok 15\n";
}
--- NEW FILE: lfs.t ---
# NOTE: this file tests how large files (>2GB) work with perlio (stdio/sfio).
# sysopen(), sysseek(), syswrite(), sysread() are tested in t/lib/syslfs.t.
# If you modify/add tests here, remember to update also ext/Fcntl/t/syslfs.t.
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
# Don't bother if there are no quad offsets.
require Config; import Config;
if ($Config{lseeksize} < 8) {
print "1..0 # Skip: no 64-bit file offsets\n";
exit(0);
}
}
use strict;
our @s;
our $fail;
sub zap {
close(BIG);
unlink("big");
unlink("big1");
unlink("big2");
}
sub bye {
zap();
exit(0);
}
my $explained;
sub explain {
unless ($explained++) {
print <<EOM;
#
# If the lfs (large file support: large meaning larger than two
# gigabytes) tests are skipped or fail, it may mean either that your
# process (or process group) is not allowed to write large files
# (resource limits) or that the file system (the network filesystem?)
# you are running the tests on doesn't let your user/group have large
# files (quota) or the filesystem simply doesn't support large files.
# You may even need to reconfigure your kernel. (This is all very
# operating system and site-dependent.)
#
# Perl may still be able to support large files, once you have
# such a process, enough quota, and such a (file) system.
# It is just that the test failed now.
#
EOM
}
print "1..0 # Skip: @_\n" if @_;
}
$| = 1;
print "# checking whether we have sparse files...\n";
# Known have-nots.
if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') {
print "1..0 # Skip: no sparse files in $^O\n";
bye();
}
# Known haves that have problems running this test
# (for example because they do not support sparse files, like UNICOS)
if ($^O eq 'unicos') {
print "1..0 # Skip: no sparse files in $^O, unable to test large files\n";
bye();
}
# Then try to heuristically deduce whether we have sparse files.
# Let's not depend on Fcntl or any other extension.
my ($SEEK_SET, $SEEK_CUR, $SEEK_END) = (0, 1, 2);
# We'll start off by creating a one megabyte file which has
# only three "true" bytes. If we have sparseness, we should
# consume less blocks than one megabyte (assuming nobody has
# one megabyte blocks...)
open(BIG, ">big1") or
do { warn "open big1 failed: $!\n"; bye };
binmode(BIG) or
do { warn "binmode big1 failed: $!\n"; bye };
seek(BIG, 1_000_000, $SEEK_SET) or
do { warn "seek big1 failed: $!\n"; bye };
print BIG "big" or
do { warn "print big1 failed: $!\n"; bye };
close(BIG) or
do { warn "close big1 failed: $!\n"; bye };
my @s1 = stat("big1");
print "# s1 = @s1\n";
open(BIG, ">big2") or
do { warn "open big2 failed: $!\n"; bye };
binmode(BIG) or
do { warn "binmode big2 failed: $!\n"; bye };
seek(BIG, 2_000_000, $SEEK_SET) or
do { warn "seek big2 failed; $!\n"; bye };
print BIG "big" or
do { warn "print big2 failed; $!\n"; bye };
close(BIG) or
do { warn "close big2 failed; $!\n"; bye };
my @s2 = stat("big2");
print "# s2 = @s2\n";
zap();
unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 &&
$s1[11] == $s2[11] && $s1[12] == $s2[12]) {
print "1..0 # Skip: no sparse files?\n";
bye;
}
print "# we seem to have sparse files...\n";
# By now we better be sure that we do have sparse files:
# if we are not, the following will hog 5 gigabytes of disk. Ooops.
# This may fail by producing some signal; run in a subprocess first for safety
$ENV{LC_ALL} = "C";
my $r = system '../perl', '-e', <<'EOF';
open(BIG, ">big");
seek(BIG, 5_000_000_000, 0);
print BIG "big";
exit 0;
EOF
open(BIG, ">big") or do { warn "open failed: $!\n"; bye };
binmode BIG;
if ($r or not seek(BIG, 5_000_000_000, $SEEK_SET)) {
my $err = $r ? 'signal '.($r & 0x7f) : $!;
explain("seeking past 2GB failed: $err");
bye();
}
# Either the print or (more likely, thanks to buffering) the close will
# fail if there are are filesize limitations (process or fs).
my $print = print BIG "big";
print "# print failed: $!\n" unless $print;
my $close = close BIG;
print "# close failed: $!\n" unless $close;
unless ($print && $close) {
if ($! =~/too large/i) {
explain("writing past 2GB failed: process limits?");
} elsif ($! =~ /quota/i) {
explain("filesystem quota limits?");
} else {
explain("error: $!");
}
bye();
}
@s = stat("big");
print "# @s\n";
unless ($s[7] == 5_000_000_003) {
explain("kernel/fs not configured to use large files?");
bye();
}
sub fail () {
print "not ";
$fail++;
}
sub offset ($$) {
my ($offset_will_be, $offset_want) = @_;
my $offset_is = eval $offset_will_be;
unless ($offset_is == $offset_want) {
print "# bad offset $offset_is, want $offset_want\n";
my ($offset_func) = ($offset_will_be =~ /^(\w+)/);
if (unpack("L", pack("L", $offset_want)) == $offset_is) {
print "# 32-bit wraparound suspected in $offset_func() since\n";
print "# $offset_want cast into 32 bits equals $offset_is.\n";
} elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1
== $offset_is) {
print "# 32-bit wraparound suspected in $offset_func() since\n";
printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n",
$offset_want,
$offset_want,
$offset_is;
}
fail;
}
}
print "1..17\n";
$fail = 0;
fail unless $s[7] == 5_000_000_003; # exercizes pp_stat
print "ok 1\n";
fail unless -s "big" == 5_000_000_003; # exercizes pp_ftsize
print "ok 2\n";
fail unless -e "big";
print "ok 3\n";
fail unless -f "big";
print "ok 4\n";
open(BIG, "big") or do { warn "open failed: $!\n"; bye };
binmode BIG;
fail unless seek(BIG, 4_500_000_000, $SEEK_SET);
print "ok 5\n";
offset('tell(BIG)', 4_500_000_000);
print "ok 6\n";
fail unless seek(BIG, 1, $SEEK_CUR);
print "ok 7\n";
# If you get 205_032_705 from here it means that
# your tell() is returning 32-bit values since (I32)4_500_000_001
# is exactly 205_032_705.
offset('tell(BIG)', 4_500_000_001);
print "ok 8\n";
fail unless seek(BIG, -1, $SEEK_CUR);
print "ok 9\n";
offset('tell(BIG)', 4_500_000_000);
print "ok 10\n";
fail unless seek(BIG, -3, $SEEK_END);
print "ok 11\n";
offset('tell(BIG)', 5_000_000_000);
print "ok 12\n";
my $big;
fail unless read(BIG, $big, 3) == 3;
print "ok 13\n";
fail unless $big eq "big";
print "ok 14\n";
# 705_032_704 = (I32)5_000_000_000
# See that we don't have "big" in the 705_... spot:
# that would mean that we have a wraparound.
fail unless seek(BIG, 705_032_704, $SEEK_SET);
print "ok 15\n";
my $zero;
fail unless read(BIG, $zero, 3) == 3;
print "ok 16\n";
fail unless $zero eq "\0\0\0";
print "ok 17\n";
explain() if $fail;
bye(); # does the necessary cleanup
END {
# unlink may fail if applied directly to a large file
# be paranoid about leaving 5 gig files lying around
open(BIG, ">big"); # truncate
close(BIG);
1 while unlink "big"; # standard portable idiom
}
# eof
--- NEW FILE: utf8decode.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
{
my $wide = v256;
use bytes;
my $ordwide = ord($wide);
printf "# under use bytes ord(v256) = 0x%02x\n", $ordwide;
if ($ordwide == 140) {
print "1..0 # Skip: UTF-EBCDIC (not UTF-8) used here\n";
exit 0;
}
elsif ($ordwide != 196) {
printf "# v256 starts with 0x%02x\n", $ordwide;
}
}
no utf8;
print "1..78\n";
my $test = 1;
# This table is based on Markus Kuhn's UTF-8 Decode Stress Tester,
# http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt,
# version dated 2000-09-02.
# We use the \x notation instead of raw binary bytes for \x00-\x1f\x7f-\xff
# because e.g. many patch programs have issues with binary data.
my @MK = split(/\n/, <<__EOMK__);
1 Correct UTF-8
1.1.1 y "\xce\xba\xe1\xbd\xb9\xcf\x83\xce\xbc\xce\xb5" - 11 ce:ba:e1:bd:b9:cf:83:ce:bc:ce:b5 5
2 Boundary conditions
2.1 First possible sequence of certain length
2.1.1 y "\x00" 0 1 00 1
2.1.2 y "\xc2\x80" 80 2 c2:80 1
2.1.3 y "\xe0\xa0\x80" 800 3 e0:a0:80 1
2.1.4 y "\xf0\x90\x80\x80" 10000 4 f0:90:80:80 1
2.1.5 y "\xf8\x88\x80\x80\x80" 200000 5 f8:88:80:80:80 1
2.1.6 y "\xfc\x84\x80\x80\x80\x80" 4000000 6 fc:84:80:80:80:80 1
2.2 Last possible sequence of certain length
2.2.1 y "\x7f" 7f 1 7f 1
2.2.2 y "\xdf\xbf" 7ff 2 df:bf 1
# The ffff is illegal unless UTF8_ALLOW_FFFF
2.2.3 n "\xef\xbf\xbf" ffff 3 ef:bf:bf 1 character 0xffff
2.2.4 y "\xf7\xbf\xbf\xbf" 1fffff 4 f7:bf:bf:bf 1
2.2.5 y "\xfb\xbf\xbf\xbf\xbf" 3ffffff 5 fb:bf:bf:bf:bf 1
2.2.6 y "\xfd\xbf\xbf\xbf\xbf\xbf" 7fffffff 6 fd:bf:bf:bf:bf:bf 1
2.3 Other boundary conditions
2.3.1 y "\xed\x9f\xbf" d7ff 3 ed:9f:bf 1
2.3.2 y "\xee\x80\x80" e000 3 ee:80:80 1
2.3.3 y "\xef\xbf\xbd" fffd 3 ef:bf:bd 1
2.3.4 y "\xf4\x8f\xbf\xbf" 10ffff 4 f4:8f:bf:bf 1
2.3.5 y "\xf4\x90\x80\x80" 110000 4 f4:90:80:80 1
3 Malformed sequences
3.1 Unexpected continuation bytes
3.1.1 n "\x80" - 1 80 - unexpected continuation byte 0x80
3.1.2 n "\xbf" - 1 bf - unexpected continuation byte 0xbf
3.1.3 n "\x80\xbf" - 2 80:bf - unexpected continuation byte 0x80
3.1.4 n "\x80\xbf\x80" - 3 80:bf:80 - unexpected continuation byte 0x80
3.1.5 n "\x80\xbf\x80\xbf" - 4 80:bf:80:bf - unexpected continuation byte 0x80
3.1.6 n "\x80\xbf\x80\xbf\x80" - 5 80:bf:80:bf:80 - unexpected continuation byte 0x80
3.1.7 n "\x80\xbf\x80\xbf\x80\xbf" - 6 80:bf:80:bf:80:bf - unexpected continuation byte 0x80
3.1.8 n "\x80\xbf\x80\xbf\x80\xbf\x80" - 7 80:bf:80:bf:80:bf:80 - unexpected continuation byte 0x80
3.1.9 n "\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf" - 64 80:81:82:83:84:85:86:87:88:89:8a:8b:8c:8d:8e:8f:90:91:92:93:94:95:96:97:98:99:9a:9b:9c:9d:9e:9f:a0:a1:a2:a3:a4:a5:a6:a7:a8:a9:aa:ab:ac:ad:ae:af:b0:b1:b2:b3:b4:b5:b6:b7:b8:b9:ba:bb:bc:bd:be:bf - unexpected continuation byte 0x80
3.2 Lonely start characters
3.2.1 n "\xc0 \xc1 \xc2 \xc3 \xc4 \xc5 \xc6 \xc7 \xc8 \xc9 \xca \xcb \xcc \xcd \xce \xcf \xd0 \xd1 \xd2 \xd3 \xd4 \xd5 \xd6 \xd7 \xd8 \xd9 \xda \xdb \xdc \xdd \xde \xdf " - 64 c0:20:c1:20:c2:20:c3:20:c4:20:c5:20:c6:20:c7:20:c8:20:c9:20:ca:20:cb:20:cc:20:cd:20:ce:20:cf:20:d0:20:d1:20:d2:20:d3:20:d4:20:d5:20:d6:20:d7:20:d8:20:d9:20:da:20:db:20:dc:20:dd:20:de:20:df:20 - unexpected non-continuation byte 0x20 after start byte 0xc0
3.2.2 n "\xe0 \xe1 \xe2 \xe3 \xe4 \xe5 \xe6 \xe7 \xe8 \xe9 \xea \xeb \xec \xed \xee \xef " - 32 e0:20:e1:20:e2:20:e3:20:e4:20:e5:20:e6:20:e7:20:e8:20:e9:20:ea:20:eb:20:ec:20:ed:20:ee:20:ef:20 - unexpected non-continuation byte 0x20 after start byte 0xe0
3.2.3 n "\xf0 \xf1 \xf2 \xf3 \xf4 \xf5 \xf6 \xf7 " - 16 f0:20:f1:20:f2:20:f3:20:f4:20:f5:20:f6:20:f7:20 - unexpected non-continuation byte 0x20 after start byte 0xf0
3.2.4 n "\xf8 \xf9 \xfa \xfb " - 8 f8:20:f9:20:fa:20:fb:20 - unexpected non-continuation byte 0x20 after start byte 0xf8
3.2.5 n "\xfc \xfd " - 4 fc:20:fd:20 - unexpected non-continuation byte 0x20 after start byte 0xfc
3.3 Sequences with last continuation byte missing
3.3.1 n "\xc0" - 1 c0 - 1 byte, need 2
3.3.2 n "\xe0\x80" - 2 e0:80 - 2 bytes, need 3
3.3.3 n "\xf0\x80\x80" - 3 f0:80:80 - 3 bytes, need 4
3.3.4 n "\xf8\x80\x80\x80" - 4 f8:80:80:80 - 4 bytes, need 5
3.3.5 n "\xfc\x80\x80\x80\x80" - 5 fc:80:80:80:80 - 5 bytes, need 6
3.3.6 n "\xdf" - 1 df - 1 byte, need 2
3.3.7 n "\xef\xbf" - 2 ef:bf - 2 bytes, need 3
3.3.8 n "\xf7\xbf\xbf" - 3 f7:bf:bf - 3 bytes, need 4
3.3.9 n "\xfb\xbf\xbf\xbf" - 4 fb:bf:bf:bf - 4 bytes, need 5
3.3.10 n "\xfd\xbf\xbf\xbf\xbf" - 5 fd:bf:bf:bf:bf - 5 bytes, need 6
3.4 Concatenation of incomplete sequences
3.4.1 n "\xc0\xe0\x80\xf0\x80\x80\xf8\x80\x80\x80\xfc\x80\x80\x80\x80\xdf\xef\xbf\xf7\xbf\xbf\xfb\xbf\xbf\xbf\xfd\xbf\xbf\xbf\xbf" - 30 c0:e0:80:f0:80:80:f8:80:80:80:fc:80:80:80:80:df:ef:bf:f7:bf:bf:fb:bf:bf:bf:fd:bf:bf:bf:bf - unexpected non-continuation byte 0xe0 after start byte 0xc0
3.5 Impossible bytes
3.5.1 n "\xfe" - 1 fe - byte 0xfe
3.5.2 n "\xff" - 1 ff - byte 0xff
3.5.3 n "\xfe\xfe\xff\xff" - 4 fe:fe:ff:ff - byte 0xfe
4 Overlong sequences
4.1 Examples of an overlong ASCII character
4.1.1 n "\xc0\xaf" - 2 c0:af - 2 bytes, need 1
4.1.2 n "\xe0\x80\xaf" - 3 e0:80:af - 3 bytes, need 1
4.1.3 n "\xf0\x80\x80\xaf" - 4 f0:80:80:af - 4 bytes, need 1
4.1.4 n "\xf8\x80\x80\x80\xaf" - 5 f8:80:80:80:af - 5 bytes, need 1
4.1.5 n "\xfc\x80\x80\x80\x80\xaf" - 6 fc:80:80:80:80:af - 6 bytes, need 1
4.2 Maximum overlong sequences
4.2.1 n "\xc1\xbf" - 2 c1:bf - 2 bytes, need 1
4.2.2 n "\xe0\x9f\xbf" - 3 e0:9f:bf - 3 bytes, need 2
4.2.3 n "\xf0\x8f\xbf\xbf" - 4 f0:8f:bf:bf - 4 bytes, need 3
4.2.4 n "\xf8\x87\xbf\xbf\xbf" - 5 f8:87:bf:bf:bf - 5 bytes, need 4
4.2.5 n "\xfc\x83\xbf\xbf\xbf\xbf" - 6 fc:83:bf:bf:bf:bf - 6 bytes, need 5
4.3 Overlong representation of the NUL character
4.3.1 n "\xc0\x80" - 2 c0:80 - 2 bytes, need 1
4.3.2 n "\xe0\x80\x80" - 3 e0:80:80 - 3 bytes, need 1
4.3.3 n "\xf0\x80\x80\x80" - 4 f0:80:80:80 - 4 bytes, need 1
4.3.4 n "\xf8\x80\x80\x80\x80" - 5 f8:80:80:80:80 - 5 bytes, need 1
4.3.5 n "\xfc\x80\x80\x80\x80\x80" - 6 fc:80:80:80:80:80 - 6 bytes, need 1
5 Illegal code positions
5.1 Single UTF-16 surrogates
5.1.1 n "\xed\xa0\x80" - 3 ed:a0:80 - UTF-16 surrogate 0xd800
5.1.2 n "\xed\xad\xbf" - 3 ed:ad:bf - UTF-16 surrogate 0xdb7f
5.1.3 n "\xed\xae\x80" - 3 ed:ae:80 - UTF-16 surrogate 0xdb80
5.1.4 n "\xed\xaf\xbf" - 3 ed:af:bf - UTF-16 surrogate 0xdbff
5.1.5 n "\xed\xb0\x80" - 3 ed:b0:80 - UTF-16 surrogate 0xdc00
5.1.6 n "\xed\xbe\x80" - 3 ed:be:80 - UTF-16 surrogate 0xdf80
5.1.7 n "\xed\xbf\xbf" - 3 ed:bf:bf - UTF-16 surrogate 0xdfff
5.2 Paired UTF-16 surrogates
5.2.1 n "\xed\xa0\x80\xed\xb0\x80" - 6 ed:a0:80:ed:b0:80 - UTF-16 surrogate 0xd800
5.2.2 n "\xed\xa0\x80\xed\xbf\xbf" - 6 ed:a0:80:ed:bf:bf - UTF-16 surrogate 0xd800
5.2.3 n "\xed\xad\xbf\xed\xb0\x80" - 6 ed:ad:bf:ed:b0:80 - UTF-16 surrogate 0xdb7f
5.2.4 n "\xed\xad\xbf\xed\xbf\xbf" - 6 ed:ad:bf:ed:bf:bf - UTF-16 surrogate 0xdb7f
5.2.5 n "\xed\xae\x80\xed\xb0\x80" - 6 ed:ae:80:ed:b0:80 - UTF-16 surrogate 0xdb80
5.2.6 n "\xed\xae\x80\xed\xbf\xbf" - 6 ed:ae:80:ed:bf:bf - UTF-16 surrogate 0xdb80
5.2.7 n "\xed\xaf\xbf\xed\xb0\x80" - 6 ed:af:bf:ed:b0:80 - UTF-16 surrogate 0xdbff
5.2.8 n "\xed\xaf\xbf\xed\xbf\xbf" - 6 ed:af:bf:ed:bf:bf - UTF-16 surrogate 0xdbff
5.3 Other illegal code positions
5.3.1 n "\xef\xbf\xbe" - 3 ef:bf:be - byte order mark 0xfffe
# The ffff is illegal unless UTF8_ALLOW_FFFF
5.3.2 n "\xef\xbf\xbf" - 3 ef:bf:bf - character 0xffff
__EOMK__
# 104..181
{
my $id;
local $SIG{__WARN__} = sub {
print "# $id: @_";
$@ = "@_";
};
sub moan {
print "$id: @_";
}
sub warn_unpack_U {
$@ = '';
my @null = unpack('U0U*', $_[0]);
return $@;
}
for (@MK) {
if (/^(?:\d+(?:\.\d+)?)\s/ || /^#/) {
# print "# $_\n";
} elsif (/^(\d+\.\d+\.\d+[bu]?)\s+([yn])\s+"(.+)"\s+([0-9a-f]{1,8}|-)\s+(\d+)\s+([0-9a-f]{2}(?::[0-9a-f]{2})*)(?:\s+((?:\d+|-)(?:\s+(.+))?))?$/) {
$id = $1;
my ($okay, $bytes, $Unicode, $byteslen, $hex, $charslen, $experr) =
($2, $3, $4, $5, $6, $7, $8);
my @hex = split(/:/, $hex);
unless (@hex == $byteslen) {
my $nhex = @hex;
moan "amount of hex ($nhex) not equal to byteslen ($byteslen)\n";
}
{
use bytes;
my $bytesbyteslen = length($bytes);
unless ($bytesbyteslen == $byteslen) {
moan "bytes length() ($bytesbyteslen) not equal to $byteslen\n";
}
}
my $warn = warn_unpack_U($bytes);
if ($okay eq 'y') {
if ($warn) {
moan "unpack('U0U*') false negative\n";
print "not ";
}
} elsif ($okay eq 'n') {
if (not $warn || ($experr ne '' && $warn !~ /$experr/)) {
moan "unpack('U0U*') false positive\n";
print "not ";
}
}
print "ok $test # $id $okay\n";
$test++;
} else {
moan "unknown format\n";
}
}
}
--- NEW FILE: method.t ---
#!./perl
#
# test method calls and autoloading.
#
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
require "test.pl";
}
print "1..78\n";
@A::ISA = 'B';
@B::ISA = 'C';
sub C::d {"C::d"}
sub D::d {"D::d"}
# First, some basic checks of method-calling syntax:
$obj = bless [], "Pack";
sub Pack::method { shift; join(",", "method", @_) }
$mname = "method";
is(Pack->method("a","b","c"), "method,a,b,c");
is(Pack->$mname("a","b","c"), "method,a,b,c");
is(method Pack ("a","b","c"), "method,a,b,c");
is((method Pack "a","b","c"), "method,a,b,c");
is(Pack->method(), "method");
is(Pack->$mname(), "method");
is(method Pack (), "method");
is(Pack->method, "method");
is(Pack->$mname, "method");
is(method Pack, "method");
is($obj->method("a","b","c"), "method,a,b,c");
is($obj->$mname("a","b","c"), "method,a,b,c");
is((method $obj ("a","b","c")), "method,a,b,c");
is((method $obj "a","b","c"), "method,a,b,c");
is($obj->method(0), "method,0");
is($obj->method(1), "method,1");
is($obj->method(), "method");
is($obj->$mname(), "method");
is((method $obj ()), "method");
is($obj->method, "method");
is($obj->$mname, "method");
is(method $obj, "method");
is( A->d, "C::d"); # Update hash table;
*B::d = \&D::d; # Import now.
is(A->d, "D::d"); # Update hash table;
{
local @A::ISA = qw(C); # Update hash table with split() assignment
is(A->d, "C::d");
$#A::ISA = -1;
is(eval { A->d } || "fail", "fail");
}
is(A->d, "D::d");
{
local *B::d;
eval 'sub B::d {"B::d1"}'; # Import now.
is(A->d, "B::d1"); # Update hash table;
undef &B::d;
is((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1);
}
is(A->d, "D::d"); # Back to previous state
eval 'sub B::d {"B::d2"}'; # Import now.
is(A->d, "B::d2"); # Update hash table;
# What follows is hardly guarantied to work, since the names in scripts
# are already linked to "pruned" globs. Say, `undef &B::d' if it were
# after `delete $B::{d}; sub B::d {}' would reach an old subroutine.
undef &B::d;
delete $B::{d};
is(A->d, "C::d"); # Update hash table;
eval 'sub B::d {"B::d3"}'; # Import now.
is(A->d, "B::d3"); # Update hash table;
delete $B::{d};
*dummy::dummy = sub {}; # Mark as updated
is(A->d, "C::d");
eval 'sub B::d {"B::d4"}'; # Import now.
is(A->d, "B::d4"); # Update hash table;
delete $B::{d}; # Should work without any help too
is(A->d, "C::d");
{
local *C::d;
is(eval { A->d } || "nope", "nope");
}
is(A->d, "C::d");
*A::x = *A::d; # See if cache incorrectly follows synonyms
A->d;
is(eval { A->x } || "nope", "nope");
eval <<'EOF';
sub C::e;
BEGIN { *B::e = \&C::e } # Shouldn't prevent AUTOLOAD in original pkg
sub Y::f;
$counter = 0;
@X::ISA = 'Y';
@Y::ISA = 'B';
sub B::AUTOLOAD {
my $c = ++$counter;
my $method = $B::AUTOLOAD;
my $msg = "B: In $method, $c";
eval "sub $method { \$msg }";
goto &$method;
}
sub C::AUTOLOAD {
my $c = ++$counter;
my $method = $C::AUTOLOAD;
my $msg = "C: In $method, $c";
eval "sub $method { \$msg }";
goto &$method;
}
EOF
is(A->e(), "C: In C::e, 1"); # We get a correct autoload
is(A->e(), "C: In C::e, 1"); # Which sticks
is(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top
is(A->ee(), "B: In A::ee, 2"); # Which sticks
is(Y->f(), "B: In Y::f, 3"); # We vivify a correct method
is(Y->f(), "B: In Y::f, 3"); # Which sticks
# This test is not intended to be reasonable. It is here just to let you
# know that you broke some old construction. Feel free to rewrite the test
# if your patch breaks it.
*B::AUTOLOAD = sub {
my $c = ++$counter;
my $method = $AUTOLOAD;
*$AUTOLOAD = sub { "new B: In $method, $c" };
goto &$AUTOLOAD;
};
is(A->eee(), "new B: In A::eee, 4"); # We get a correct $autoload
is(A->eee(), "new B: In A::eee, 4"); # Which sticks
# this test added due to bug discovery
is(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined");
# test that failed subroutine calls don't affect method calls
{
package A1;
sub foo { "foo" }
package A2;
@ISA = 'A1';
package main;
is(A2->foo(), "foo");
is(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1);
is(A2->foo(), "foo");
}
## This test was totally misguided. It passed before only because the
## code to determine if a package was loaded used to look for the hash
## %Foo::Bar instead of the package Foo::Bar:: -- and Config.pm just
## happens to export %Config.
# {
# is(do { use Config; eval 'Config->foo()';
# $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1);
# is(do { use Config; eval '$d = bless {}, "Config"; $d->foo()';
# $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1);
# }
# test error messages if method loading fails
is(do { eval '$e = bless {}, "E::A"; E::A->foo()';
$@ =~ /^\QCan't locate object method "foo" via package "E::A" at/ ? 1 : $@}, 1);
is(do { eval '$e = bless {}, "E::B"; $e->foo()';
$@ =~ /^\QCan't locate object method "foo" via package "E::B" at/ ? 1 : $@}, 1);
is(do { eval 'E::C->foo()';
$@ =~ /^\QCan't locate object method "foo" via package "E::C" (perhaps / ? 1 : $@}, 1);
is(do { eval 'UNIVERSAL->E::D::foo()';
$@ =~ /^\QCan't locate object method "foo" via package "E::D" (perhaps / ? 1 : $@}, 1);
is(do { eval '$e = bless {}, "UNIVERSAL"; $e->E::E::foo()';
$@ =~ /^\QCan't locate object method "foo" via package "E::E" (perhaps / ? 1 : $@}, 1);
$e = bless {}, "E::F"; # force package to exist
is(do { eval 'UNIVERSAL->E::F::foo()';
$@ =~ /^\QCan't locate object method "foo" via package "E::F" at/ ? 1 : $@}, 1);
is(do { eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()';
$@ =~ /^\QCan't locate object method "foo" via package "E::F" at/ ? 1 : $@}, 1);
# TODO: we need some tests for the SUPER:: pseudoclass
# failed method call or UNIVERSAL::can() should not autovivify packages
is( $::{"Foo::"} || "none", "none"); # sanity check 1
is( $::{"Foo::"} || "none", "none"); # sanity check 2
is( UNIVERSAL::can("Foo", "boogie") ? "yes":"no", "no" );
is( $::{"Foo::"} || "none", "none"); # still missing?
is( Foo->UNIVERSAL::can("boogie") ? "yes":"no", "no" );
is( $::{"Foo::"} || "none", "none"); # still missing?
is( Foo->can("boogie") ? "yes":"no", "no" );
is( $::{"Foo::"} || "none", "none"); # still missing?
is( eval 'Foo->boogie(); 1' ? "yes":"no", "no" );
is( $::{"Foo::"} || "none", "none"); # still missing?
is(do { eval 'Foo->boogie()';
$@ =~ /^\QCan't locate object method "boogie" via package "Foo" (perhaps / ? 1 : $@}, 1);
eval 'sub Foo::boogie { "yes, sir!" }';
is( $::{"Foo::"} ? "ok" : "none", "ok"); # should exist now
is( Foo->boogie(), "yes, sir!");
# TODO: universal.t should test NoSuchPackage->isa()/can()
# This is actually testing parsing of indirect objects and undefined subs
# print foo("bar") where foo does not exist is not an indirect object.
# print foo "bar" where foo does not exist is an indirect object.
eval 'sub AUTOLOAD { "ok ", shift, "\n"; }';
ok(1);
# Bug ID 20010902.002
is(
eval q[
$x = 'x';
sub Foo::x : lvalue { $x }
Foo->$x = 'ok';
] || $@, 'ok'
);
# An autoloaded, inherited DESTROY may be invoked differently than normal
# methods, and has been known to give rise to spurious warnings
# eg <200203121600.QAA11064 at gizmo.fdgroup.co.uk>
{
use warnings;
my $w = '';
local $SIG{__WARN__} = sub { $w = $_[0] };
sub AutoDest::Base::AUTOLOAD {}
@AutoDest::ISA = qw(AutoDest::Base);
{ my $x = bless {}, 'AutoDest'; }
$w =~ s/\n//g;
is($w, '');
}
# [ID 20020305.025] PACKAGE::SUPER doesn't work anymore
package main;
our @X;
package Amajor;
sub test {
push @main::X, 'Amajor', @_;
}
package Bminor;
use base qw(Amajor);
package main;
sub Bminor::test {
$_[0]->Bminor::SUPER::test('x', 'y');
push @main::X, 'Bminor', @_;
}
Bminor->test('y', 'z');
is("@X", "Amajor Bminor x y Bminor Bminor y z");
package main;
for my $meth (['Bar', 'Foo::Bar'],
['SUPER::Bar', 'main::SUPER::Bar'],
['Xyz::SUPER::Bar', 'Xyz::SUPER::Bar'])
{
fresh_perl_is(<<EOT,
package UNIVERSAL; sub AUTOLOAD { my \$c = shift; print "\$c \$AUTOLOAD\\n" }
sub DESTROY {} # IO object destructor called in MacOS, because of Mac::err
package Xyz;
package main; Foo->$meth->[0]();
EOT
"Foo $meth->[1]",
{ switches => [ '-w' ] },
"check if UNIVERSAL::AUTOLOAD works",
);
}
--- NEW FILE: exec.t ---
#!./perl
BEGIN: {
chdir 't' if -d 't';
@INC = ('../lib');
require './test.pl';
}
# supress VMS whinging about bad execs.
use vmsish qw(hushed);
$| = 1; # flush stdout
$ENV{LC_ALL} = 'C'; # Forge English error messages.
$ENV{LANGUAGE} = 'C'; # Ditto in GNU.
my $Is_VMS = $^O eq 'VMS';
my $Is_Win32 = $^O eq 'MSWin32';
skip_all("Tests mostly usesless on MacOS") if $^O eq 'MacOS';
plan(tests => 21);
my $Perl = which_perl();
my $exit;
SKIP: {
skip("bug/feature of pdksh", 2) if $^O eq 'os2';
my $tnum = curr_test();
$exit = system qq{$Perl -le "print q{ok $tnum - interp system(EXPR)"}};
next_test();
is( $exit, 0, ' exited 0' );
}
my $tnum = curr_test();
$exit = system qq{$Perl -le "print q{ok $tnum - split & direct system(EXPR)"}};
next_test();
is( $exit, 0, ' exited 0' );
# On VMS and Win32 you need the quotes around the program or it won't work.
# On Unix its the opposite.
my $quote = $Is_VMS || $Is_Win32 ? '"' : '';
$tnum = curr_test();
$exit = system $Perl, '-le',
"${quote}print q{ok $tnum - system(PROG, LIST)}${quote}";
next_test();
is( $exit, 0, ' exited 0' );
# Some basic piped commands. Some OS's have trouble with "helpfully"
# putting newlines on the end of piped output. So we split this into
# newline insensitive and newline sensitive tests.
my $echo_out = `$Perl -e "print 'ok'" | $Perl -le "print <STDIN>"`;
$echo_out =~ s/\n\n/\n/g;
is( $echo_out, "ok\n", 'piped echo emulation');
{
# here we check if extra newlines are going to be slapped on
# piped output.
local $TODO = 'VMS sticks newlines on everything' if $Is_VMS;
is( scalar `$Perl -e "print 'ok'"`,
"ok", 'no extra newlines on ``' );
is( scalar `$Perl -e "print 'ok'" | $Perl -e "print <STDIN>"`,
"ok", 'no extra newlines on pipes');
is( scalar `$Perl -le "print 'ok'" | $Perl -le "print <STDIN>"`,
"ok\n\n", 'doubled up newlines');
is( scalar `$Perl -e "print 'ok'" | $Perl -le "print <STDIN>"`,
"ok\n", 'extra newlines on inside pipes');
is( scalar `$Perl -le "print 'ok'" | $Perl -e "print <STDIN>"`,
"ok\n", 'extra newlines on outgoing pipes');
{
local($/) = \2;
$out = runperl(prog => 'print q{1234}');
is($out, "1234", 'ignore $/ when capturing output in scalar context');
}
}
is( system(qq{$Perl -e "exit 0"}), 0, 'Explicit exit of 0' );
my $exit_one = $Is_VMS ? 4 << 8 : 1 << 8;
is( system(qq{$Perl "-I../lib" -e "use vmsish qw(hushed); exit 1"}), $exit_one,
'Explicit exit of 1' );
$rc = system { "lskdfj" } "lskdfj";
unless( ok($rc == 255 << 8 or $rc == -1 or $rc == 256 or $rc == 512) ) {
print "# \$rc == $rc\n";
}
unless ( ok( $! == 2 or $! =~ /\bno\b.*\bfile/i or
$! == 13 or $! =~ /permission denied/i or
$! == 22 or $! =~ /invalid argument/ ) ) {
printf "# \$! eq %d, '%s'\n", $!, $!;
}
is( `$Perl -le "print 'ok'"`, "ok\n", 'basic ``' );
is( <<`END`, "ok\n", '<<`HEREDOC`' );
$Perl -le "print 'ok'"
END
TODO: {
my $tnum = curr_test();
if( $^O =~ /Win32/ ) {
print "not ok $tnum - exec failure doesn't terminate process " .
"# TODO Win32 exec failure waits for user input\n";
next_test();
last TODO;
}
ok( !exec("lskdjfalksdjfdjfkls"),
"exec failure doesn't terminate process");
}
my $test = curr_test();
exec $Perl, '-le', qq{${quote}print 'ok $test - exec PROG, LIST'${quote}};
fail("This should never be reached if the exec() worked");
--- NEW FILE: subst.t ---
#!./perl -wT
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
}
require './test.pl';
plan( tests => 131 );
$x = 'foo';
$_ = "x";
s/x/\$x/;
ok( $_ eq '$x', ":$_: eq :\$x:" );
$_ = "x";
s/x/$x/;
ok( $_ eq 'foo', ":$_: eq :foo:" );
$_ = "x";
s/x/\$x $x/;
ok( $_ eq '$x foo', ":$_: eq :\$x foo:" );
$b = 'cd';
($a = 'abcdef') =~ s<(b${b}e)>'\n$1';
ok( $1 eq 'bcde' && $a eq 'a\n$1f', ":$1: eq :bcde: ; :$a: eq :a\\n\$1f:" );
$a = 'abacada';
ok( ($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx' );
ok( ($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx' );
ok( ($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx' );
$_ = 'ABACADA';
ok( /a/i && s///gi && $_ eq 'BCD' );
$_ = '\\' x 4;
ok( length($_) == 4 );
$snum = s/\\/\\\\/g;
ok( $_ eq '\\' x 8 && $snum == 4 );
$_ = '\/' x 4;
ok( length($_) == 8 );
$snum = s/\//\/\//g;
ok( $_ eq '\\//' x 4 && $snum == 4 );
ok( length($_) == 12 );
$_ = 'aaaXXXXbbb';
s/^a//;
ok( $_ eq 'aaXXXXbbb' );
$_ = 'aaaXXXXbbb';
s/a//;
ok( $_ eq 'aaXXXXbbb' );
$_ = 'aaaXXXXbbb';
s/^a/b/;
ok( $_ eq 'baaXXXXbbb' );
$_ = 'aaaXXXXbbb';
s/a/b/;
ok( $_ eq 'baaXXXXbbb' );
$_ = 'aaaXXXXbbb';
s/aa//;
ok( $_ eq 'aXXXXbbb' );
$_ = 'aaaXXXXbbb';
s/aa/b/;
ok( $_ eq 'baXXXXbbb' );
$_ = 'aaaXXXXbbb';
s/b$//;
ok( $_ eq 'aaaXXXXbb' );
$_ = 'aaaXXXXbbb';
s/b//;
ok( $_ eq 'aaaXXXXbb' );
$_ = 'aaaXXXXbbb';
s/bb//;
ok( $_ eq 'aaaXXXXb' );
$_ = 'aaaXXXXbbb';
s/aX/y/;
ok( $_ eq 'aayXXXbbb' );
$_ = 'aaaXXXXbbb';
s/Xb/z/;
ok( $_ eq 'aaaXXXzbb' );
$_ = 'aaaXXXXbbb';
s/aaX.*Xbb//;
ok( $_ eq 'ab' );
$_ = 'aaaXXXXbbb';
s/bb/x/;
ok( $_ eq 'aaaXXXXxb' );
# now for some unoptimized versions of the same.
$_ = 'aaaXXXXbbb';
$x ne $x || s/^a//;
ok( $_ eq 'aaXXXXbbb' );
$_ = 'aaaXXXXbbb';
$x ne $x || s/a//;
ok( $_ eq 'aaXXXXbbb' );
$_ = 'aaaXXXXbbb';
$x ne $x || s/^a/b/;
ok( $_ eq 'baaXXXXbbb' );
$_ = 'aaaXXXXbbb';
$x ne $x || s/a/b/;
ok( $_ eq 'baaXXXXbbb' );
$_ = 'aaaXXXXbbb';
$x ne $x || s/aa//;
ok( $_ eq 'aXXXXbbb' );
$_ = 'aaaXXXXbbb';
$x ne $x || s/aa/b/;
ok( $_ eq 'baXXXXbbb' );
$_ = 'aaaXXXXbbb';
$x ne $x || s/b$//;
ok( $_ eq 'aaaXXXXbb' );
$_ = 'aaaXXXXbbb';
$x ne $x || s/b//;
ok( $_ eq 'aaaXXXXbb' );
$_ = 'aaaXXXXbbb';
$x ne $x || s/bb//;
ok( $_ eq 'aaaXXXXb' );
$_ = 'aaaXXXXbbb';
$x ne $x || s/aX/y/;
ok( $_ eq 'aayXXXbbb' );
$_ = 'aaaXXXXbbb';
$x ne $x || s/Xb/z/;
ok( $_ eq 'aaaXXXzbb' );
$_ = 'aaaXXXXbbb';
$x ne $x || s/aaX.*Xbb//;
ok( $_ eq 'ab' );
$_ = 'aaaXXXXbbb';
$x ne $x || s/bb/x/;
ok( $_ eq 'aaaXXXXxb' );
$_ = 'abc123xyz';
s/(\d+)/$1*2/e; # yields 'abc246xyz'
ok( $_ eq 'abc246xyz' );
s/(\d+)/sprintf("%5d",$1)/e; # yields 'abc 246xyz'
ok( $_ eq 'abc 246xyz' );
s/(\w)/$1 x 2/eg; # yields 'aabbcc 224466xxyyzz'
ok( $_ eq 'aabbcc 224466xxyyzz' );
$_ = "aaaaa";
ok( y/a/b/ == 5 );
ok( y/a/b/ == 0 );
ok( y/b// == 5 );
ok( y/b/c/s == 5 );
ok( y/c// == 1 );
ok( y/c//d == 1 );
ok( $_ eq "" );
$_ = "Now is the %#*! time for all good men...";
ok( ($x=(y/a-zA-Z //cd)) == 7 );
ok( y/ / /s == 8 );
$_ = 'abcdefghijklmnopqrstuvwxyz0123456789';
tr/a-z/A-Z/;
ok( $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' );
# same as tr/A-Z/a-z/;
if (defined $Config{ebcdic} && $Config{ebcdic} eq 'define') { # EBCDIC.
no utf8;
y[\301-\351][\201-\251];
} else { # Ye Olde ASCII. Or something like it.
y[\101-\132][\141-\172];
}
ok( $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' );
SKIP: {
skip("not ASCII",1) unless (ord("+") == ord(",") - 1
&& ord(",") == ord("-") - 1
&& ord("a") == ord("b") - 1
&& ord("b") == ord("c") - 1);
$_ = '+,-';
tr/+--/a-c/;
ok( $_ eq 'abc' );
}
$_ = '+,-';
tr/+\--/a\/c/;
ok( $_ eq 'a,/' );
$_ = '+,-';
tr/-+,/ab\-/;
ok( $_ eq 'b-a' );
# test recursive substitutions
# code based on the recursive expansion of makefile variables
my %MK = (
AAAAA => '$(B)', B=>'$(C)', C => 'D', # long->short
E => '$(F)', F=>'p $(G) q', G => 'HHHHH', # short->long
DIR => '$(UNDEFINEDNAME)/xxx',
);
sub var {
my($var,$level) = @_;
return "\$($var)" unless exists $MK{$var};
return exp_vars($MK{$var}, $level+1); # can recurse
}
sub exp_vars {
my($str,$level) = @_;
$str =~ s/\$\((\w+)\)/var($1, $level+1)/ge; # can recurse
#warn "exp_vars $level = '$str'\n";
$str;
}
ok( exp_vars('$(AAAAA)',0) eq 'D' );
ok( exp_vars('$(E)',0) eq 'p HHHHH q' );
ok( exp_vars('$(DIR)',0) eq '$(UNDEFINEDNAME)/xxx' );
ok( exp_vars('foo $(DIR)/yyy bar',0) eq 'foo $(UNDEFINEDNAME)/xxx/yyy bar' );
$_ = "abcd";
s/(..)/$x = $1, m#.#/eg;
ok( $x eq "cd", 'a match nested in the RHS of a substitution' );
# Subst and lookbehind
$_="ccccc";
$snum = s/(?<!x)c/x/g;
ok( $_ eq "xxxxx" && $snum == 5 );
$_="ccccc";
$snum = s/(?<!x)(c)/x/g;
ok( $_ eq "xxxxx" && $snum == 5 );
$_="foobbarfoobbar";
$snum = s/(?<!r)foobbar/foobar/g;
ok( $_ eq "foobarfoobbar" && $snum == 1 );
$_="foobbarfoobbar";
$snum = s/(?<!ar)(foobbar)/foobar/g;
ok( $_ eq "foobarfoobbar" && $snum == 1 );
$_="foobbarfoobbar";
$snum = s/(?<!ar)foobbar/foobar/g;
ok( $_ eq "foobarfoobbar" && $snum == 1 );
eval 's{foo} # this is a comment, not a delimiter
{bar};';
ok( ! @?, 'parsing of split subst with comment' );
$_="baacbaa";
$snum = tr/a/b/s;
ok( $_ eq "bbcbb" && $snum == 4,
'check if squashing works at the end of string' );
$_ = "ab";
ok( s/a/b/ == 1 );
$_ = <<'EOL';
$url = new URI::URL "http://www/"; die if $url eq "xXx";
EOL
$^R = 'junk';
$foo = ' $@%#lowercase $@%# lowercase UPPERCASE$@%#UPPERCASE' .
' $@%#lowercase$@%#lowercase$@%# lowercase lowercase $@%#lowercase' .
' lowercase $@%#MiXeD$@%# ';
$snum =
s{ \d+ \b [,.;]? (?{ 'digits' })
|
[a-z]+ \b [,.;]? (?{ 'lowercase' })
|
[A-Z]+ \b [,.;]? (?{ 'UPPERCASE' })
|
[A-Z] [a-z]+ \b [,.;]? (?{ 'Capitalized' })
|
[A-Za-z]+ \b [,.;]? (?{ 'MiXeD' })
|
[A-Za-z0-9]+ \b [,.;]? (?{ 'alphanumeric' })
|
\s+ (?{ ' ' })
|
[^A-Za-z0-9\s]+ (?{ '$@%#' })
}{$^R}xg;
ok( $_ eq $foo );
ok( $snum == 31 );
$_ = 'a' x 6;
$snum = s/a(?{})//g;
ok( $_ eq '' && $snum == 6 );
$_ = 'x' x 20;
$snum = s/(\d*|x)/<$1>/g;
$foo = '<>' . ('<x><>' x 20) ;
ok( $_ eq $foo && $snum == 41 );
$t = 'aaaaaaaaa';
$_ = $t;
pos = 6;
$snum = s/\Ga/xx/g;
ok( $_ eq 'aaaaaaxxxxxx' && $snum == 3 );
$_ = $t;
pos = 6;
$snum = s/\Ga/x/g;
ok( $_ eq 'aaaaaaxxx' && $snum == 3 );
$_ = $t;
pos = 6;
s/\Ga/xx/;
ok( $_ eq 'aaaaaaxxaa' );
$_ = $t;
pos = 6;
s/\Ga/x/;
ok( $_ eq 'aaaaaaxaa' );
$_ = $t;
$snum = s/\Ga/xx/g;
ok( $_ eq 'xxxxxxxxxxxxxxxxxx' && $snum == 9 );
$_ = $t;
$snum = s/\Ga/x/g;
ok( $_ eq 'xxxxxxxxx' && $snum == 9 );
$_ = $t;
s/\Ga/xx/;
ok( $_ eq 'xxaaaaaaaa' );
$_ = $t;
s/\Ga/x/;
ok( $_ eq 'xaaaaaaaa' );
$_ = 'aaaa';
$snum = s/\ba/./g;
ok( $_ eq '.aaa' && $snum == 1 );
eval q% s/a/"b"}/e %;
ok( $@ =~ /Bad evalled substitution/ );
eval q% ($_ = "x") =~ s/(.)/"$1 "/e %;
ok( $_ eq "x " and !length $@ );
$x = $x = 'interp';
eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %;
ok( $_ eq '' and !length $@ );
$_ = "C:/";
ok( !s/^([a-z]:)/\u$1/ );
$_ = "Charles Bronson";
$snum = s/\B\w//g;
ok( $_ eq "C B" && $snum == 12 );
{
use utf8;
my $s = "H\303\266he";
my $l = my $r = $s;
$l =~ s/[^\w]//g;
$r =~ s/[^\w\.]//g;
is($l, $r, "use utf8 \\w");
}
my $pv1 = my $pv2 = "Andreas J. K\303\266nig";
$pv1 =~ s/A/\x{100}/;
substr($pv2,0,1) = "\x{100}";
is($pv1, $pv2);
SKIP: {
skip("EBCDIC", 3) if ord("A") == 193;
{
# Gregor Chrupala <gregor.chrupala at star-group.net>
use utf8;
$a = 'España';
$a =~ s/ñ/ñ/;
like($a, qr/ñ/, "use utf8 RHS");
}
{
use utf8;
$a = 'España España';
$a =~ s/ñ/ñ/;
like($a, qr/ñ/, "use utf8 LHS");
}
{
use utf8;
$a = 'España';
$a =~ s/ñ/ñ/;
like($a, qr/ñ/, "use utf8 LHS and RHS");
}
}
{
# SADAHIRO Tomoyuki <bqw10602 at nifty.com>
$a = "\x{100}\x{101}";
$a =~ s/\x{101}/\xFF/;
like($a, qr/\xFF/);
is(length($a), 2, "SADAHIRO utf8 s///");
$a = "\x{100}\x{101}";
$a =~ s/\x{101}/"\xFF"/e;
like($a, qr/\xFF/);
is(length($a), 2);
$a = "\x{100}\x{101}";
$a =~ s/\x{101}/\xFF\xFF\xFF/;
like($a, qr/\xFF\xFF\xFF/);
is(length($a), 4);
$a = "\x{100}\x{101}";
$a =~ s/\x{101}/"\xFF\xFF\xFF"/e;
like($a, qr/\xFF\xFF\xFF/);
is(length($a), 4);
$a = "\xFF\x{101}";
$a =~ s/\xFF/\x{100}/;
like($a, qr/\x{100}/);
is(length($a), 2);
$a = "\xFF\x{101}";
$a =~ s/\xFF/"\x{100}"/e;
like($a, qr/\x{100}/);
is(length($a), 2);
$a = "\xFF";
$a =~ s/\xFF/\x{100}/;
like($a, qr/\x{100}/);
is(length($a), 1);
$a = "\xFF";
$a =~ s/\xFF/"\x{100}"/e;
like($a, qr/\x{100}/);
is(length($a), 1);
}
{
# subst with mixed utf8/non-utf8 type
my($ua, $ub, $uc, $ud) = ("\x{101}", "\x{102}", "\x{103}", "\x{104}");
my($na, $nb) = ("\x{ff}", "\x{fe}");
my $a = "$ua--$ub";
my $b;
($b = $a) =~ s/--/$na/;
is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8");
($b = $a) =~ s/--/--$na--/;
is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8");
($b = $a) =~ s/--/$uc/;
is($b, "$ua$uc$ub", "s///: replace utf8 into utf8");
($b = $a) =~ s/--/--$uc--/;
is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8");
$a = "$na--$nb";
($b = $a) =~ s/--/$ua/;
is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8");
($b = $a) =~ s/--/--$ua--/;
is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8");
# now with utf8 pattern
$a = "$ua--$ub";
($b = $a) =~ s/-($ud)?-/$na/;
is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8 (utf8 pattern)");
($b = $a) =~ s/-($ud)?-/--$na--/;
is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8 (utf8 pattern)");
($b = $a) =~ s/-($ud)?-/$uc/;
is($b, "$ua$uc$ub", "s///: replace utf8 into utf8 (utf8 pattern)");
($b = $a) =~ s/-($ud)?-/--$uc--/;
is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8 (utf8 pattern)");
$a = "$na--$nb";
($b = $a) =~ s/-($ud)?-/$ua/;
is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8 (utf8 pattern)");
($b = $a) =~ s/-($ud)?-/--$ua--/;
is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8 (utf8 pattern)");
($b = $a) =~ s/-($ud)?-/$na/;
is($b, "$na$na$nb", "s///: replace non-utf8 into non-utf8 (utf8 pattern)");
($b = $a) =~ s/-($ud)?-/--$na--/;
is($b, "$na--$na--$nb", "s///: replace long non-utf8 into non-utf8 (utf8 pattern)");
}
$_ = 'aaaa';
$r = 'x';
$s = s/a(?{})/$r/g;
is("<$_> <$s>", "<xxxx> <4>", "[perl #7806]");
$_ = 'aaaa';
$s = s/a(?{})//g;
is("<$_> <$s>", "<> <4>", "[perl #7806]");
# [perl #19048] Coredump in silly replacement
{
local $^W = 0;
$_="abcdef\n";
s!.!!eg;
is($_, "\n", "[perl #19048]");
}
# [perl #17757] interaction between saw_ampersand and study
{
my $f = eval q{ $& };
$f = "xx";
study $f;
$f =~ s/x/y/g;
is($f, "yy", "[perl #17757]");
}
# [perl #20684] returned a zero count
$_ = "1111";
is(s/(??{1})/2/eg, 4, '#20684 s/// with (??{..}) inside');
# [perl #20682] @- not visible in replacement
$_ = "123";
/(2)/; # seed @- with something else
s/(1)(2)(3)/$#- (@-)/;
is($_, "3 (0 0 1 2)", '#20682 @- not visible in replacement');
# [perl #20682] $^N not visible in replacement
$_ = "abc";
/(a)/; s/(b)|(c)/-$^N/g;
is($_,'a-b-c','#20682 $^N not visible in replacement');
# [perl #22351] perl bug with 'e' substitution modifier
my $name = "chris";
{
no warnings 'uninitialized';
$name =~ s/hr//e;
}
is($name, "cis", q[#22351 bug with 'e' substitution modifier]);
# [perl #34171] $1 didn't honour 'use bytes' in s//e
{
my $s="\x{100}";
my $x;
{
use bytes;
$s=~ s/(..)/$x=$1/e
}
is(length($x), 2, '[perl #34171]');
}
--- NEW FILE: chop.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
plan tests => 139;
$_ = 'abc';
$c = do foo();
is ($c . $_, 'cab', 'optimized');
$_ = 'abc';
$c = chop($_);
is ($c . $_ , 'cab', 'unoptimized');
sub foo {
chop;
}
@foo = ("hi \n","there\n","!\n");
@bar = @foo;
chop(@bar);
is (join('', at bar), 'hi there!');
$foo = "\n";
chop($foo, at foo);
is (join('',$foo, at foo), 'hi there!');
$_ = "foo\n\n";
$got = chomp();
ok ($got == 1) or print "# got $got\n";
is ($_, "foo\n");
$_ = "foo\n";
$got = chomp();
ok ($got == 1) or print "# got $got\n";
is ($_, "foo");
$_ = "foo";
$got = chomp();
ok ($got == 0) or print "# got $got\n";
is ($_, "foo");
$_ = "foo";
$/ = "oo";
$got = chomp();
ok ($got == 2) or print "# got $got\n";
is ($_, "f");
$_ = "bar";
$/ = "oo";
$got = chomp();
ok ($got == 0) or print "# got $got\n";
is ($_, "bar");
$_ = "f\n\n\n\n\n";
$/ = "";
$got = chomp();
ok ($got == 5) or print "# got $got\n";
is ($_, "f");
$_ = "f\n\n";
$/ = "";
$got = chomp();
ok ($got == 2) or print "# got $got\n";
is ($_, "f");
$_ = "f\n";
$/ = "";
$got = chomp();
ok ($got == 1) or print "# got $got\n";
is ($_, "f");
$_ = "f";
$/ = "";
$got = chomp();
ok ($got == 0) or print "# got $got\n";
is ($_, "f");
$_ = "xx";
$/ = "xx";
$got = chomp();
ok ($got == 2) or print "# got $got\n";
is ($_, "");
$_ = "axx";
$/ = "xx";
$got = chomp();
ok ($got == 2) or print "# got $got\n";
is ($_, "a");
$_ = "axx";
$/ = "yy";
$got = chomp();
ok ($got == 0) or print "# got $got\n";
is ($_, "axx");
# This case once mistakenly behaved like paragraph mode.
$_ = "ab\n";
$/ = \3;
$got = chomp();
ok ($got == 0) or print "# got $got\n";
is ($_, "ab\n");
# Go Unicode.
$_ = "abc\x{1234}";
chop;
is ($_, "abc", "Go Unicode");
$_ = "abc\x{1234}d";
chop;
is ($_, "abc\x{1234}");
$_ = "\x{1234}\x{2345}";
chop;
is ($_, "\x{1234}");
my @stuff = qw(this that);
is (chop(@stuff[0,1]), 't');
# bug id 20010305.012
@stuff = qw(ab cd ef);
is (chop(@stuff = @stuff), 'f');
@stuff = qw(ab cd ef);
is (chop(@stuff[0, 2]), 'f');
my %stuff = (1..4);
is (chop(@stuff{1, 3}), '4');
# chomp should not stringify references unless it decides to modify them
$_ = [];
$/ = "\n";
$got = chomp();
ok ($got == 0) or print "# got $got\n";
is (ref($_), "ARRAY", "chomp ref (modify)");
$/ = ")"; # the last char of something like "ARRAY(0x80ff6e4)"
$got = chomp();
ok ($got == 1) or print "# got $got\n";
ok (!ref($_), "chomp ref (no modify)");
$/ = "\n";
%chomp = ("One" => "One", "Two\n" => "Two", "" => "");
%chop = ("One" => "On", "Two\n" => "Two", "" => "");
foreach (keys %chomp) {
my $key = $_;
eval {chomp $_};
if ($@) {
my $err = $@;
$err =~ s/\n$//s;
fail ("\$\@ = \"$err\"");
} else {
is ($_, $chomp{$key}, "chomp hash key");
}
}
foreach (keys %chop) {
my $key = $_;
eval {chop $_};
if ($@) {
my $err = $@;
$err =~ s/\n$//s;
fail ("\$\@ = \"$err\"");
} else {
is ($_, $chop{$key}, "chop hash key");
}
}
# chop and chomp can't be lvalues
eval 'chop($x) = 1;';
ok($@ =~ /Can\'t modify.*chop.*in.*assignment/);
eval 'chomp($x) = 1;';
ok($@ =~ /Can\'t modify.*chom?p.*in.*assignment/);
eval 'chop($x, $y) = (1, 2);';
ok($@ =~ /Can\'t modify.*chop.*in.*assignment/);
eval 'chomp($x, $y) = (1, 2);';
ok($@ =~ /Can\'t modify.*chom?p.*in.*assignment/);
my @chars = ("N", "\xd3", substr ("\xd4\x{100}", 0, 1), chr 1296);
foreach my $start (@chars) {
foreach my $end (@chars) {
local $/ = $end;
my $message = "start=" . ord ($start) . " end=" . ord $end;
my $string = $start . $end;
is (chomp ($string), 1, "$message [returns 1]");
is ($string, $start, $message);
my $end_utf8 = $end;
utf8::encode ($end_utf8);
next if $end_utf8 eq $end;
# $end ne $end_utf8, so these should not chomp.
$string = $start . $end_utf8;
my $chomped = $string;
is (chomp ($chomped), 0, "$message (end as bytes) [returns 0]");
is ($chomped, $string, "$message (end as bytes)");
$/ = $end_utf8;
$string = $start . $end;
$chomped = $string;
is (chomp ($chomped), 0, "$message (\$/ as bytes) [returns 0]");
is ($chomped, $string, "$message (\$/ as bytes)");
}
}
{
# returns length in characters, but not in bytes.
$/ = "\x{100}";
$a = "A$/";
$b = chomp $a;
is ($b, 1);
$/ = "\x{100}\x{101}";
$a = "A$/";
$b = chomp $a;
is ($b, 2);
}
{
# [perl #36569] chop fails on decoded string with trailing nul
my $asc = "perl\0";
my $utf = "perl".pack('U',0); # marked as utf8
is(chop($asc), "\0", "chopping ascii NUL");
is(chop($utf), "\0", "chopping utf8 NUL");
is($asc, "perl", "chopped ascii NUL");
is($utf, "perl", "chopped utf8 NUL");
}
{
# Change 26011: Re: A surprising segfault
# to make sure only that these obfuscated sentences will not crash.
map chop(+()), ('')x68;
ok(1, "extend sp in pp_chop");
map chomp(+()), ('')x68;
ok(1, "extend sp in pp_chomp");
}
--- NEW FILE: study.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
$Ok_Level = 0;
my $test = 1;
sub ok ($;$) {
my($ok, $name) = @_;
local $_;
# You have to do it this way or VMS will get confused.
printf "%s $test%s\n", $ok ? 'ok' : 'not ok',
$name ? " - $name" : '';
printf "# Failed test at line %d\n", (caller($Ok_Level))[2] unless $ok;
$test++;
return $ok;
}
sub nok ($;$) {
my($nok, $name) = @_;
local $Ok_Level = 1;
ok( !$nok, $name );
}
use Config;
my $have_alarm = $Config{d_alarm};
sub alarm_ok (&) {
my $test = shift;
local $SIG{ALRM} = sub { die "timeout\n" };
my $match;
eval {
alarm(2) if $have_alarm;
$match = $test->();
alarm(0) if $have_alarm;
};
local $Ok_Level = 1;
ok( !$match && !$@, 'testing studys that used to hang' );
}
print "1..26\n";
$x = "abc\ndef\n";
study($x);
ok($x =~ /^abc/);
ok($x !~ /^def/);
$* = 1;
ok($x =~ /^def/);
$* = 0;
$_ = '123';
study;
ok(/^([0-9][0-9]*)/);
nok($x =~ /^xxx/);
nok($x !~ /^abc/);
ok($x =~ /def/);
nok($x !~ /def/);
study($x);
ok($x !~ /.def/);
nok($x =~ /.def/);
ok($x =~ /\ndef/);
nok($x !~ /\ndef/);
$_ = 'aaabbbccc';
study;
ok(/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc');
ok(/(a+b+c+)/ && $1 eq 'aaabbbccc');
nok(/a+b?c+/);
$_ = 'aaabccc';
study;
ok(/a+b?c+/);
ok(/a*b+c*/);
$_ = 'aaaccc';
study;
ok(/a*b?c*/);
nok(/a*b+c*/);
$_ = 'abcdef';
study;
ok(/bcd|xyz/);
ok(/xyz|bcd/);
ok(m|bc/*d|);
ok(/^$_$/);
$* = 1; # test 3 only tested the optimized version--this one is for real
ok("ab\ncd\n" =~ /^cd/);
if ($^O eq 'os390' or $^O eq 'posix-bc' or $^O eq 'MacOS') {
# Even with the alarm() OS/390 and BS2000 can't manage these tests
# (Perl just goes into a busy loop, luckily an interruptable one)
for (25..26) { print "not ok $_ # TODO compiler bug?\n" }
$test += 2;
} else {
# [ID 20010618.006] tests 25..26 may loop
$_ = 'FGF';
study;
alarm_ok { /G.F$/ };
alarm_ok { /[F]F$/ };
}
--- NEW FILE: pat.t ---
#!./perl
#
# This is a home for regular expression tests that don't fit into
# the format supported by op/regexp.t. If you want to add a test
# that does fit that format, add it to op/re_tests, not here.
$| = 1;
print "1..1187\n";
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
eval 'use Config'; # Defaults assumed if this fails
$x = "abc\ndef\n";
[...3360 lines suppressed...]
ok("\xe9" =~ /$utf8/i, "# TODO latin/utf8");
ok("\xe9" =~ /(abc|$utf8)/i, "# latin/utf8 trie");
ok($latin1 =~ /$utf8/i, "# TODO latin/utf8 runtime");
ok($latin1 =~ /(abc|$utf8)/i, "# latin/utf8 trie runtime");
}
# [perl #37038] Global regular matches generate invalid pointers
{
my $s = "abcd";
$s =~ /(..)(..)/g;
$s = $1;
$s = $2;
ok($s eq 'cd',
"# assigning to original string should not corrupt match vars");
}
# last test 1187
--- NEW FILE: lc_user.t ---
BEGIN {
chdir 't';
@INC = '../lib';
require './test.pl';
}
plan tests => 4;
sub ToUpper {
return <<END;
0061 0063 0041
END
}
is("\Ufoo\x{101}", "foo\x{101}", "no changes on 'foo'");
is("\Ubar\x{101}", "BAr\x{101}", "changing 'ab' on 'bar' ");
sub ToLower {
return <<END;
0041 0061
END
}
is("\LFOO\x{100}", "FOO\x{100}", "no changes on 'FOO'");
is("\LBAR\x{100}", "BaR\x{100}", "changing 'A' on 'BAR' ");
--- NEW FILE: splice.t ---
#!./perl
print "1..18\n";
@a = (1..10);
sub j { join(":", at _) }
print "not " unless j(splice(@a, at a,0,11,12)) eq "" && j(@a) eq j(1..12);
print "ok 1\n";
print "not " unless j(splice(@a,-1)) eq "12" && j(@a) eq j(1..11);
print "ok 2\n";
print "not " unless j(splice(@a,0,1)) eq "1" && j(@a) eq j(2..11);
print "ok 3\n";
print "not " unless j(splice(@a,0,0,0,1)) eq "" && j(@a) eq j(0..11);
print "ok 4\n";
print "not " unless j(splice(@a,5,1,5)) eq "5" && j(@a) eq j(0..11);
print "ok 5\n";
print "not " unless j(splice(@a, @a, 0, 12, 13)) eq "" && j(@a) eq j(0..13);
print "ok 6\n";
print "not " unless j(splice(@a, - at a, @a, 1, 2, 3)) eq j(0..13) && j(@a) eq j(1..3);
print "ok 7\n";
print "not " unless j(splice(@a, 1, -1, 7, 7)) eq "2" && j(@a) eq j(1,7,7,3);
print "ok 8\n";
print "not " unless j(splice(@a,-3,-2,2)) eq j(7) && j(@a) eq j(1,2,7,3);
print "ok 9\n";
# Bug 20000223.001 - no test for splice(@array). Destructive test!
print "not " unless j(splice(@a)) eq j(1,2,7,3) && j(@a) eq '';
print "ok 10\n";
# Tests 11 and 12:
# [ID 20010711.005] in Tie::Array, SPLICE ignores context, breaking SHIFT
my $foo;
@a = ('red', 'green', 'blue');
$foo = splice @a, 1, 2;
print "not " unless $foo eq 'blue';
print "ok 11\n";
@a = ('red', 'green', 'blue');
$foo = shift @a;
print "not " unless $foo eq 'red';
print "ok 12\n";
# Bug [perl #30568] - insertions of deleted elements
@a = (1, 2, 3);
splice( @a, 0, 3, $a[1], $a[0] );
print "not " unless j(@a) eq j(2,1);
print "ok 13\n";
@a = (1, 2, 3);
splice( @a, 0, 3 ,$a[0], $a[1] );
print "not " unless j(@a) eq j(1,2);
print "ok 14\n";
@a = (1, 2, 3);
splice( @a, 0, 3 ,$a[2], $a[1], $a[0] );
print "not " unless j(@a) eq j(3,2,1);
print "ok 15\n";
@a = (1, 2, 3);
splice( @a, 0, 3, $a[0], $a[1], $a[2], $a[0], $a[1], $a[2] );
print "not " unless j(@a) eq j(1,2,3,1,2,3);
print "ok 16\n";
@a = (1, 2, 3);
splice( @a, 1, 2, $a[2], $a[1] );
print "not " unless j(@a) eq j(1,3,2);
print "ok 17\n";
@a = (1, 2, 3);
splice( @a, 1, 2, $a[1], $a[1] );
print "not " unless j(@a) eq j(1,2,2);
print "ok 18\n";
--- NEW FILE: undef.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
print "1..36\n";
print defined($a) ? "not ok 1\n" : "ok 1\n";
$a = 1+1;
print defined($a) ? "ok 2\n" : "not ok 2\n";
undef $a;
print defined($a) ? "not ok 3\n" : "ok 3\n";
$a = "hi";
print defined($a) ? "ok 4\n" : "not ok 4\n";
$a = $b;
print defined($a) ? "not ok 5\n" : "ok 5\n";
@ary = ("1arg");
$a = pop(@ary);
print defined($a) ? "ok 6\n" : "not ok 6\n";
$a = pop(@ary);
print defined($a) ? "not ok 7\n" : "ok 7\n";
@ary = ("1arg");
$a = shift(@ary);
print defined($a) ? "ok 8\n" : "not ok 8\n";
$a = shift(@ary);
print defined($a) ? "not ok 9\n" : "ok 9\n";
$ary{'foo'} = 'hi';
print defined($ary{'foo'}) ? "ok 10\n" : "not ok 10\n";
print defined($ary{'bar'}) ? "not ok 11\n" : "ok 11\n";
undef $ary{'foo'};
print defined($ary{'foo'}) ? "not ok 12\n" : "ok 12\n";
print defined(@ary) ? "ok 13\n" : "not ok 13\n";
print defined(%ary) ? "ok 14\n" : "not ok 14\n";
undef @ary;
print defined(@ary) ? "not ok 15\n" : "ok 15\n";
undef %ary;
print defined(%ary) ? "not ok 16\n" : "ok 16\n";
@ary = (1);
print defined @ary ? "ok 17\n" : "not ok 17\n";
%ary = (1,1);
print defined %ary ? "ok 18\n" : "not ok 18\n";
sub foo { print "ok 19\n"; }
&foo || print "not ok 19\n";
print defined &foo ? "ok 20\n" : "not ok 20\n";
undef &foo;
print defined(&foo) ? "not ok 21\n" : "ok 21\n";
eval { undef $1 };
print $@ =~ /^Modification of a read/ ? "ok 22\n" : "not ok 22\n";
eval { $1 = undef };
print $@ =~ /^Modification of a read/ ? "ok 23\n" : "not ok 23\n";
{
require Tie::Hash;
tie my %foo, 'Tie::StdHash';
print defined %foo ? "ok 24\n" : "not ok 24\n";
%foo = ( a => 1 );
print defined %foo ? "ok 25\n" : "not ok 25\n";
}
{
require Tie::Array;
tie my @foo, 'Tie::StdArray';
print defined @foo ? "ok 26\n" : "not ok 26\n";
@foo = ( a => 1 );
print defined @foo ? "ok 27\n" : "not ok 27\n";
}
{
# [perl #17753] segfault when undef'ing unquoted string constant
eval 'undef tcp';
print $@ =~ /^Can't modify constant item/ ? "ok 28\n" : "not ok 28\n";
}
# bugid 3096
# undefing a hash may free objects with destructors that then try to
# modify the hash. To them, the hash should appear empty.
$test = 29;
%hash = (
key1 => bless({}, 'X'),
key2 => bless({}, 'X'),
);
undef %hash;
sub X::DESTROY {
print "not " if keys %hash; print "ok $test\n"; $test++;
print "not " if values %hash; print "ok $test\n"; $test++;
print "not " if each %hash; print "ok $test\n"; $test++;
print "not " if defined delete $hash{'key2'}; print "ok $test\n"; $test++;
}
--- NEW FILE: qq.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
print q(1..21
);
# This is() function is written to avoid ""
my $test = 1;
sub is {
my($left, $right) = @_;
if ($left eq $right) {
printf 'ok %d
', $test++;
return 1;
}
foreach ($left, $right) {
# Comment out these regexps to map non-printables to ord if the perl under
# test is so broken that it's not helping
s/([^-+A-Za-z_0-9])/sprintf q{'.chr(%d).'}, ord $1/ge;
$_ = sprintf q('%s'), $_;
s/^''\.//;
s/\.''$//;
}
printf q(not ok %d - got %s expected %s
), $test++, $left, $right;
printf q(# Failed test at line %d
), (caller)[2];
return 0;
}
is ("\x53", chr 83);
is ("\x4EE", chr (78) . 'E');
is ("\x4i", chr (4) . 'i'); # This will warn
is ("\xh", chr (0) . 'h'); # This will warn
is ("\xx", chr (0) . 'x'); # This will warn
is ("\xx9", chr (0) . 'x9'); # This will warn. \x9 is tab in EBCDIC too?
is ("\x9_E", chr (9) . '_E'); # This will warn
is ("\x{4E}", chr 78);
is ("\x{6_9}", chr 105);
is ("\x{_6_3}", chr 99);
is ("\x{_6B}", chr 107);
is ("\x{9__0}", chr 9); # multiple underscores not allowed.
is ("\x{77_}", chr 119); # trailing underscore warns.
is ("\x{6FQ}z", chr (111) . 'z');
is ("\x{0x4E}", chr 0);
is ("\x{x4E}", chr 0);
is ("\x{0065}", chr 101);
is ("\x{000000000000000000000000000000000000000000000000000000000000000072}",
chr 114);
is ("\x{0_06_5}", chr 101);
is ("\x{1234}", chr 4660);
is ("\x{10FFFD}", chr 1114109);
--- NEW FILE: tie.t ---
#!./perl
# Add new tests to the end with format:
# ########
#
# # test description
# Test code
# EXPECT
# Warn or die msgs (if any) at - line 1234
#
chdir 't' if -d 't';
@INC = '../lib';
$ENV{PERL5LIB} = "../lib";
$|=1;
undef $/;
@prgs = split /^########\n/m, <DATA>;
require './test.pl';
plan(tests => scalar @prgs);
for (@prgs){
++$i;
my($prog,$expected) = split(/\nEXPECT\n/, $_, 2);
print("not ok $i # bad test format\n"), next
unless defined $expected;
my ($testname) = $prog =~ /^# (.*)\n/m;
$testname ||= '';
$TODO = $testname =~ s/^TODO //;
$results =~ s/\n+$//;
$expected =~ s/\n+$//;
fresh_perl_is($prog, $expected, {}, $testname);
}
__END__
# standard behaviour, without any extra references
use Tie::Hash ;
tie %h, Tie::StdHash;
untie %h;
EXPECT
########
# standard behaviour, without any extra references
use Tie::Hash ;
{package Tie::HashUntie;
use base 'Tie::StdHash';
sub UNTIE
{
warn "Untied\n";
}
}
tie %h, Tie::HashUntie;
untie %h;
EXPECT
Untied
########
# standard behaviour, with 1 extra reference
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
untie %h;
EXPECT
########
# standard behaviour, with 1 extra reference via tied
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
untie %h;
EXPECT
########
# standard behaviour, with 1 extra reference which is destroyed
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
$a = 0 ;
untie %h;
EXPECT
########
# standard behaviour, with 1 extra reference via tied which is destroyed
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
$a = 0 ;
untie %h;
EXPECT
########
# strict behaviour, without any extra references
use warnings 'untie';
use Tie::Hash ;
tie %h, Tie::StdHash;
untie %h;
EXPECT
########
# strict behaviour, with 1 extra references generating an error
use warnings 'untie';
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
untie %h;
EXPECT
untie attempted while 1 inner references still exist at - line 6.
########
# strict behaviour, with 1 extra references via tied generating an error
use warnings 'untie';
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
untie %h;
EXPECT
untie attempted while 1 inner references still exist at - line 7.
########
# strict behaviour, with 1 extra references which are destroyed
use warnings 'untie';
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
$a = 0 ;
untie %h;
EXPECT
########
# strict behaviour, with extra 1 references via tied which are destroyed
use warnings 'untie';
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
$a = 0 ;
untie %h;
EXPECT
########
# strict error behaviour, with 2 extra references
use warnings 'untie';
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
$b = tied %h ;
untie %h;
EXPECT
untie attempted while 2 inner references still exist at - line 7.
########
# strict behaviour, check scope of strictness.
no warnings 'untie';
use Tie::Hash ;
$A = tie %H, Tie::StdHash;
$C = $B = tied %H ;
{
use warnings 'untie';
use Tie::Hash ;
tie %h, Tie::StdHash;
untie %h;
}
untie %H;
EXPECT
########
# Forbidden aggregate self-ties
sub Self::TIEHASH { bless $_[1], $_[0] }
{
my %c;
tie %c, 'Self', \%c;
}
EXPECT
Self-ties of arrays and hashes are not supported at - line 6.
########
# Allowed scalar self-ties
my $destroyed = 0;
sub Self::TIESCALAR { bless $_[1], $_[0] }
sub Self::DESTROY { $destroyed = 1; }
{
my $c = 42;
tie $c, 'Self', \$c;
}
die "self-tied scalar not DESTROYed" unless $destroyed == 1;
EXPECT
########
# Allowed glob self-ties
my $destroyed = 0;
my $printed = 0;
sub Self2::TIEHANDLE { bless $_[1], $_[0] }
sub Self2::DESTROY { $destroyed = 1; }
sub Self2::PRINT { $printed = 1; }
{
use Symbol;
my $c = gensym;
tie *$c, 'Self2', $c;
print $c 'Hello';
}
die "self-tied glob not PRINTed" unless $printed == 1;
die "self-tied glob not DESTROYed" unless $destroyed == 1;
EXPECT
########
# Allowed IO self-ties
my $destroyed = 0;
sub Self3::TIEHANDLE { bless $_[1], $_[0] }
sub Self3::DESTROY { $destroyed = 1; }
sub Self3::PRINT { $printed = 1; }
{
use Symbol 'geniosym';
my $c = geniosym;
tie *$c, 'Self3', $c;
print $c 'Hello';
}
die "self-tied IO not PRINTed" unless $printed == 1;
die "self-tied IO not DESTROYed" unless $destroyed == 1;
EXPECT
########
# TODO IO "self-tie" via TEMP glob
my $destroyed = 0;
sub Self3::TIEHANDLE { bless $_[1], $_[0] }
sub Self3::DESTROY { $destroyed = 1; }
sub Self3::PRINT { $printed = 1; }
{
use Symbol 'geniosym';
my $c = geniosym;
tie *$c, 'Self3', \*$c;
print $c 'Hello';
}
die "IO tied to TEMP glob not PRINTed" unless $printed == 1;
die "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1;
EXPECT
########
# Interaction of tie and vec
my ($a, $b);
use Tie::Scalar;
tie $a,Tie::StdScalar or die;
vec($b,1,1)=1;
$a = $b;
vec($a,1,1)=0;
vec($b,1,1)=0;
die unless $a eq $b;
EXPECT
########
# correct unlocalisation of tied hashes (patch #16431)
use Tie::Hash ;
tie %tied, Tie::StdHash;
{ local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'};
{ local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'};
{ local $ENV{'foo'} } warn "%ENV bad unlocalize" if exists $ENV{'foo'};
EXPECT
########
# An attempt at lvalueable barewords broke this
tie FH, 'main';
EXPECT
Can't modify constant item in tie at - line 3, near "'main';"
Execution of - aborted due to compilation errors.
########
# localizing tied hash slices
$ENV{FooA} = 1;
$ENV{FooB} = 2;
print exists $ENV{FooA} ? 1 : 0, "\n";
print exists $ENV{FooB} ? 2 : 0, "\n";
print exists $ENV{FooC} ? 3 : 0, "\n";
{
local @ENV{qw(FooA FooC)};
print exists $ENV{FooA} ? 4 : 0, "\n";
print exists $ENV{FooB} ? 5 : 0, "\n";
print exists $ENV{FooC} ? 6 : 0, "\n";
}
print exists $ENV{FooA} ? 7 : 0, "\n";
print exists $ENV{FooB} ? 8 : 0, "\n";
print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist
EXPECT
1
2
0
4
5
6
7
8
0
########
#
# FETCH freeing tie'd SV
sub TIESCALAR { bless [] }
sub FETCH { *a = \1; 1 }
tie $a, 'main';
print $a;
EXPECT
########
# [20020716.007] - nested FETCHES
sub F1::TIEARRAY { bless [], 'F1' }
sub F1::FETCH { 1 }
my @f1;
tie @f1, 'F1';
sub F2::TIEARRAY { bless [2], 'F2' }
sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self }
my @f2;
tie @f2, 'F2';
print $f2[4][0],"\n";
sub F3::TIEHASH { bless [], 'F3' }
sub F3::FETCH { 1 }
my %f3;
tie %f3, 'F3';
sub F4::TIEHASH { bless [3], 'F4' }
sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self }
my %f4;
tie %f4, 'F4';
print $f4{'foo'}[0],"\n";
EXPECT
2
3
########
# test untie() from within FETCH
package Foo;
sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; }
sub FETCH {
my $self = shift;
my ($obj, $field) = @$self;
untie $obj->{$field};
$obj->{$field} = "Bar";
}
package main;
tie $a->{foo}, "Foo", $a, "foo";
$a->{foo}; # access once
# the hash element should not be tied anymore
print defined tied $a->{foo} ? "not ok" : "ok";
EXPECT
ok
########
# the tmps returned by FETCH should appear to be SCALAR
# (even though they are now implemented using PVLVs.)
package X;
sub TIEHASH { bless {} }
sub TIEARRAY { bless {} }
sub FETCH {1}
my (%h, @a);
tie %h, 'X';
tie @a, 'X';
my $r1 = \$h{1};
my $r2 = \$a[0];
my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2);
$s=~ s/\(0x\w+\)//g;
print $s, "\n";
EXPECT
SCALAR SCALAR SCALAR SCALAR
########
# [perl #23287] segfault in untie
sub TIESCALAR { bless $_[1], $_[0] }
my $var;
tie $var, 'main', \$var;
untie $var;
EXPECT
########
# Test case from perlmonks by runrig
# http://www.perlmonks.org/index.pl?node_id=273490
# "Here is what I tried. I think its similar to what you've tried
# above. Its odd but convienient that after untie'ing you are left with
# a variable that has the same value as was last returned from
# FETCH. (At least on my perl v5.6.1). So you don't need to pass a
# reference to the variable in order to set it after the untie (here it
# is accessed through a closure)."
use strict;
use warnings;
package MyTied;
sub TIESCALAR {
my ($class,$code) = @_;
bless $code, $class;
}
sub FETCH {
my $self = shift;
print "Untie\n";
$self->();
}
package main;
my $var;
tie $var, 'MyTied', sub { untie $var; 4 };
print "One\n";
print "$var\n";
print "Two\n";
print "$var\n";
print "Three\n";
print "$var\n";
EXPECT
One
Untie
4
Two
4
Three
4
########
# [perl #22297] cannot untie scalar from within tied FETCH
my $counter = 0;
my $x = 7;
my $ref = \$x;
tie $x, 'Overlay', $ref, $x;
my $y;
$y = $x;
$y = $x;
$y = $x;
$y = $x;
#print "WILL EXTERNAL UNTIE $ref\n";
untie $$ref;
$y = $x;
$y = $x;
$y = $x;
$y = $x;
#print "counter = $counter\n";
print (($counter == 1) ? "ok\n" : "not ok\n");
package Overlay;
sub TIESCALAR
{
my $pkg = shift;
my ($ref, $val) = @_;
return bless [ $ref, $val ], $pkg;
}
sub FETCH
{
my $self = shift;
my ($ref, $val) = @$self;
#print "WILL INTERNAL UNITE $ref\n";
$counter++;
untie $$ref;
return $val;
}
EXPECT
ok
########
# test SCALAR method
package TieScalar;
sub TIEHASH {
my $pkg = shift;
bless { } => $pkg;
}
sub STORE {
$_[0]->{$_[1]} = $_[2];
}
sub FETCH {
$_[0]->{$_[1]}
}
sub CLEAR {
%{ $_[0] } = ();
}
sub SCALAR {
print "SCALAR\n";
return 0 if ! keys %{$_[0]};
sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]};
}
package main;
tie my %h => "TieScalar";
$h{key1} = "val1";
$h{key2} = "val2";
print scalar %h, "\n";
%h = ();
print scalar %h, "\n";
EXPECT
SCALAR
2/2
SCALAR
0
########
# test scalar on tied hash when no SCALAR method has been given
package TieScalar;
sub TIEHASH {
my $pkg = shift;
bless { } => $pkg;
}
sub STORE {
$_[0]->{$_[1]} = $_[2];
}
sub FETCH {
$_[0]->{$_[1]}
}
sub CLEAR {
%{ $_[0] } = ();
}
sub FIRSTKEY {
my $a = keys %{ $_[0] };
print "FIRSTKEY\n";
each %{ $_[0] };
}
package main;
tie my %h => "TieScalar";
if (!%h) {
print "empty\n";
} else {
print "not empty\n";
}
$h{key1} = "val1";
print "not empty\n" if %h;
print "not empty\n" if %h;
print "-->\n";
my ($k,$v) = each %h;
print "<--\n";
print "not empty\n" if %h;
%h = ();
print "empty\n" if ! %h;
EXPECT
FIRSTKEY
empty
FIRSTKEY
not empty
FIRSTKEY
not empty
-->
FIRSTKEY
<--
not empty
FIRSTKEY
empty
########
sub TIESCALAR { bless {} }
sub FETCH { my $x = 3.3; 1 if 0+$x; $x }
tie $h, "main";
print $h,"\n";
EXPECT
3.3
--- NEW FILE: anonsub.t ---
#!./perl
# Note : we're not using t/test.pl here, because we would need
# fresh_perl_is, and fresh_perl_is uses a closure -- a special
# case of what this program tests for.
chdir 't' if -d 't';
@INC = '../lib';
$Is_VMS = $^O eq 'VMS';
$Is_MSWin32 = $^O eq 'MSWin32';
$Is_MacOS = $^O eq 'MacOS';
$Is_NetWare = $^O eq 'NetWare';
$ENV{PERL5LIB} = "../lib" unless $Is_VMS;
$|=1;
undef $/;
@prgs = split "\n########\n", <DATA>;
print "1..", 6 + scalar @prgs, "\n";
$tmpfile = "asubtmp000";
1 while -f ++$tmpfile;
END { if ($tmpfile) { 1 while unlink $tmpfile; } }
for (@prgs){
my $switch = "";
if (s/^\s*(-\w+)//){
$switch = $1;
}
my($prog,$expected) = split(/\nEXPECT\n/, $_);
open TEST, ">$tmpfile";
print TEST "$prog\n";
close TEST or die "Could not close: $!";
my $results = $Is_VMS ?
`MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
$Is_MSWin32 ?
`.\\perl -I../lib $switch $tmpfile 2>&1` :
$Is_MacOS ?
`$^X -I::lib $switch $tmpfile` :
$Is_NetWare ?
`perl -I../lib $switch $tmpfile 2>&1` :
`./perl $switch $tmpfile 2>&1`;
my $status = $?;
$results =~ s/\n+$//;
# allow expected output to be written as if $prog is on STDIN
$results =~ s/runltmp\d+/-/g;
$results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg
$expected =~ s/\n+$//;
if ($results ne $expected) {
print STDERR "PROG: $switch\n$prog\n";
print STDERR "EXPECTED:\n$expected\n";
print STDERR "GOT:\n$results\n";
print "not ";
}
print "ok ", ++$i, "\n";
}
sub test_invalid_decl {
my ($code,$todo) = @_;
$todo = '' unless defined $todo;
eval $code;
if ($@ =~ /^Illegal declaration of anonymous subroutine at/) {
print "ok ", ++$i, " - '$code' is illegal$todo\n";
} else {
print "not ok ", ++$i, " - '$code' is illegal$todo\n# GOT: $@";
}
}
test_invalid_decl('sub;');
test_invalid_decl('sub ($) ;');
test_invalid_decl('{ $x = sub }');
test_invalid_decl('sub ($) && 1');
test_invalid_decl('sub ($) : lvalue;',' # TODO');
eval "sub #foo\n{print 1}";
if ($@ eq '') {
print "ok ", ++$i, "\n";
} else {
print "not ok ", ++$i, "\n# GOT: $@";
}
__END__
sub X {
my $n = "ok 1\n";
sub { print $n };
}
my $x = X();
undef &X;
$x->();
EXPECT
ok 1
########
sub X {
my $n = "ok 1\n";
sub {
my $dummy = $n; # eval can't close on $n without internal reference
eval 'print $n';
die $@ if $@;
};
}
my $x = X();
undef &X;
$x->();
EXPECT
ok 1
########
sub X {
my $n = "ok 1\n";
eval 'sub { print $n }';
}
my $x = X();
die $@ if $@;
undef &X;
$x->();
EXPECT
ok 1
########
sub X;
sub X {
my $n = "ok 1\n";
eval 'sub Y { my $p = shift; $p->() }';
die $@ if $@;
Y(sub { print $n });
}
X();
EXPECT
ok 1
########
package;
print sub { return "ok 1\n" } -> ();
EXPECT
ok 1
--- NEW FILE: grent.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
eval {my @n = getgrgid 0};
if ($@ =~ /(The \w+ function is unimplemented)/) {
skip_all "getgrgid unimplemented";
}
eval { require Config; import Config; };
my $reason;
if ($Config{'i_grp'} ne 'define') {
$reason = '$Config{i_grp} not defined';
}
elsif (not -f "/etc/group" ) { # Play safe.
$reason = 'no /etc/group file';
}
if (not defined $where) { # Try NIS.
foreach my $ypcat (qw(/usr/bin/ypcat /bin/ypcat /etc/ypcat)) {
if (-x $ypcat &&
open(GR, "$ypcat group 2>/dev/null |") &&
defined(<GR>))
{
print "# `ypcat group` worked\n";
# Check to make sure we're really using NIS.
if( open(NSSW, "/etc/nsswitch.conf" ) ) {
my($group) = grep /^\s*group:/, <NSSW>;
# If there's no group line, assume it default to compat.
if( !$group || $group !~ /(nis|compat)/ ) {
print "# Doesn't look like you're using NIS in ".
"/etc/nsswitch.conf\n";
last;
}
}
$where = "NIS group - $ypcat";
undef $reason;
last;
}
}
}
if (not defined $where) { # Try NetInfo.
foreach my $nidump (qw(/usr/bin/nidump)) {
if (-x $nidump &&
open(GR, "$nidump group . 2>/dev/null |") &&
defined(<GR>))
{
$where = "NetInfo group - $nidump";
undef $reason;
last;
}
}
}
if (not defined $where) { # Try local.
my $GR = "/etc/group";
if (-f $GR && open(GR, $GR) && defined(<GR>)) {
undef $reason;
$where = "local $GR";
}
}
if ($reason) {
skip_all $reason;
}
# By now the GR filehandle should be open and full of juicy group entries.
plan tests => 3;
# Go through at most this many groups.
# (note that the first entry has been read away by now)
my $max = 25;
my $n = 0;
my $tst = 1;
my %perfect;
my %seen;
print "# where $where\n";
ok( setgrent(), 'setgrent' ) || print "# $!\n";
while (<GR>) {
chomp;
# LIMIT -1 so that groups with no users don't fall off
my @s = split /:/, $_, -1;
my ($name_s,$passwd_s,$gid_s,$members_s) = @s;
if (@s) {
push @{ $seen{$name_s} }, $.;
} else {
warn "# Your $where line $. is empty.\n";
next;
}
if ($n == $max) {
local $/;
my $junk = <GR>;
last;
}
# In principle we could whine if @s != 4 but do we know enough
# of group file formats everywhere?
if (@s == 4) {
$members_s =~ s/\s*,\s*/,/g;
$members_s =~ s/\s+$//;
$members_s =~ s/^\s+//;
@n = getgrgid($gid_s);
# 'nogroup' et al.
next unless @n;
my ($name,$passwd,$gid,$members) = @n;
# Protect against one-to-many and many-to-one mappings.
if ($name_s ne $name) {
@n = getgrnam($name_s);
($name,$passwd,$gid,$members) = @n;
next if $name_s ne $name;
}
# NOTE: group names *CAN* contain whitespace.
$members =~ s/\s+/,/g;
# what about different orders of members?
$perfect{$name_s}++
if $name eq $name_s and
# Do not compare passwords: think shadow passwords.
# Not that group passwords are used much but better not assume anything.
$gid eq $gid_s and
$members eq $members_s;
}
$n++;
}
endgrent();
print "# max = $max, n = $n, perfect = ", scalar keys %perfect, "\n";
if (keys %perfect == 0 && $n) {
$max++;
print <<EOEX;
#
# The failure of op/grent test is not necessarily serious.
# It may fail due to local group administration conventions.
# If you are for example using both NIS and local groups,
# test failure is possible. Any distributed group scheme
# can cause such failures.
#
# What the grent test is doing is that it compares the $max first
# entries of $where
# with the results of getgrgid() and getgrnam() call. If it finds no
# matches at all, it suspects something is wrong.
#
EOEX
fail();
print "#\t (not necessarily serious: run t/op/grent.t by itself)\n";
} else {
pass();
}
# Test both the scalar and list contexts.
my @gr1;
setgrent();
for (1..$max) {
my $gr = scalar getgrent();
last unless defined $gr;
push @gr1, $gr;
}
endgrent();
my @gr2;
setgrent();
for (1..$max) {
my ($gr) = (getgrent());
last unless defined $gr;
push @gr2, $gr;
}
endgrent();
is("@gr1", "@gr2");
close(GR);
--- NEW FILE: pos.t ---
#!./perl
print "1..4\n";
$x='banana';
$x=~/.a/g;
if (pos($x)==2) {print "ok 1\n"} else {print "not ok 1\n";}
$x=~/.z/gc;
if (pos($x)==2) {print "ok 2\n"} else {print "not ok 2\n";}
sub f { my $p=$_[0]; return $p }
$x=~/.a/g;
if (f(pos($x))==4) {print "ok 3\n"} else {print "not ok 3\n";}
# Is pos() set inside //g? (bug id 19990615.008)
$x = "test string?"; $x =~ s/\w/pos($x)/eg;
print "not " unless $x eq "0123 5678910?";
print "ok 4\n";
--- NEW FILE: grep.t ---
#!./perl
#
# grep() and map() tests
#
print "1..38\n";
$test = 1;
sub ok {
my ($got,$expect) = @_;
print "# expected [$expect], got [$got]\nnot " if $got ne $expect;
print "ok $test\n";
}
{
my @lol = ([qw(a b c)], [], [qw(1 2 3)]);
my @mapped = map {scalar @$_} @lol;
ok "@mapped", "3 0 3";
$test++;
my @grepped = grep {scalar @$_} @lol;
ok "@grepped", "$lol[0] $lol[2]";
$test++;
@grepped = grep { $_ } @mapped;
ok "@grepped", "3 3";
$test++;
}
{
print map({$_} ("ok $test\n"));
$test++;
print map
({$_} ("ok $test\n"));
$test++;
print((map({a => $_}, ("ok $test\n")))[0]->{a});
$test++;
print((map
({a=>$_},
("ok $test\n")))[0]->{a});
$test++;
print map { $_ } ("ok $test\n");
$test++;
print map
{ $_ } ("ok $test\n");
$test++;
print((map {a => $_}, ("ok $test\n"))[0]->{a});
$test++;
print((map
{a=>$_},
("ok $test\n"))[0]->{a});
$test++;
my $x = "ok \xFF\xFF\n";
print map($_&$x,("ok $test\n"));
$test++;
print map
($_ & $x, ("ok $test\n"));
$test++;
print map { $_ & $x } ("ok $test\n");
$test++;
print map
{ $_&$x } ("ok $test\n");
$test++;
print grep({$_} ("ok $test\n"));
$test++;
print grep
({$_} ("ok $test\n"));
$test++;
print grep({a => $_}->{a}, ("ok $test\n"));
$test++;
print grep
({a => $_}->{a},
("ok $test\n"));
$test++;
print grep { $_ } ("ok $test\n");
$test++;
print grep
{ $_ } ("ok $test\n");
$test++;
print grep {a => $_}->{a}, ("ok $test\n");
$test++;
print grep
{a => $_}->{a},
("ok $test\n");
$test++;
print grep($_&"X",("ok $test\n"));
$test++;
print grep
($_&"X", ("ok $test\n"));
$test++;
print grep { $_ & "X" } ("ok $test\n");
$test++;
print grep
{ $_ & "X" } ("ok $test\n");
$test++;
}
# Tests for "for" in "map" and "grep"
# Used to dump core, bug [perl #17771]
{
my @x;
my $y = '';
@x = map { $y .= $_ for 1..2; 1 } 3..4;
print "# @x,$y\n";
print "@x,$y" eq "1 1,1212" ? "ok $test\n" : "not ok $test\n";
$test++;
$y = '';
@x = map { $y .= $_ for 1..2; $y .= $_ } 3..4;
print "# @x,$y\n";
print "@x,$y" eq "123 123124,123124" ? "ok $test\n" : "not ok $test\n";
$test++;
$y = '';
@x = map { for (1..2) { $y .= $_ } $y .= $_ } 3..4;
print "# @x,$y\n";
print "@x,$y" eq "123 123124,123124" ? "ok $test\n" : "not ok $test\n";
$test++;
$y = '';
@x = grep { $y .= $_ for 1..2; 1 } 3..4;
print "# @x,$y\n";
print "@x,$y" eq "3 4,1212" ? "ok $test\n" : "not ok $test\n";
$test++;
$y = '';
@x = grep { for (1..2) { $y .= $_ } 1 } 3..4;
print "# @x,$y\n";
print "@x,$y" eq "3 4,1212" ? "ok $test\n" : "not ok $test\n";
$test++;
# Add also a sample test from [perl #18153]. (The same bug).
$a = 1; map {if ($a){}} (2);
print "ok $test\n"; # no core dump is all we need
$test++;
}
{
sub add_an_x(@){
map {"${_}x"} @_;
};
ok join("-",add_an_x(1,2,3,4)), "1x-2x-3x-4x";
$test++;
}
{
my $gimme;
sub gimme {
my $want = wantarray();
if (defined $want) {
$gimme = $want ? 'list' : 'scalar';
} else {
$gimme = 'void';
}
}
my @list = 0..9;
undef $gimme; gimme for @list; ok($gimme, 'void'); $test++;
undef $gimme; grep { gimme } @list; ok($gimme, 'scalar'); $test++;
undef $gimme; map { gimme } @list; ok($gimme, 'list'); $test++;
}
{
# This shouldn't loop indefinitively.
my @empty = map { while (1) {} } ();
ok("@empty", '');
}
--- NEW FILE: sub.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
plan( tests => 4 );
sub empty_sub {}
is(empty_sub,undef,"Is empty");
is(empty_sub(1,2,3),undef,"Is still empty");
@test = empty_sub();
is(scalar(@test), 0, 'Didnt return anything');
@test = empty_sub(1,2,3);
is(scalar(@test), 0, 'Didnt return anything');
--- NEW FILE: rand.t ---
#!./perl
# From Tom Phoenix <rootbeer at teleport.com> 22 Feb 1997
# Based upon a test script by kgb at ast.cam.ac.uk (Karl Glazebrook)
# Looking for the hints? You're in the right place.
# The hints are near each test, so search for "TEST #", where
# the pound sign is replaced by the number of the test.
# I'd like to include some more robust tests, but anything
# too subtle to be detected here would require a time-consuming
# test. Also, of course, we're here to detect only flaws in Perl;
# if there are flaws in the underlying system rand, that's not
# our responsibility. But if you want better tests, see
# The Art of Computer Programming, Donald E. Knuth, volume 2,
# chapter 3. ISBN 0-201-03822-6 (v. 2)
BEGIN {
chdir "t" if -d "t";
@INC = qw(. ../lib);
}
use strict;
use Config;
require "test.pl";
plan(tests => 8);
my $reps = 15000; # How many times to try rand each time.
# May be changed, but should be over 500.
# The more the better! (But slower.)
sub bits ($) {
# Takes a small integer and returns the number of one-bits in it.
my $total;
my $bits = sprintf "%o", $_[0];
while (length $bits) {
$total += (0,1,1,2,1,2,2,3)[chop $bits]; # Oct to bits
}
$total;
}
# First, let's see whether randbits is set right
{
my($max, $min, $sum); # Characteristics of rand
my($off, $shouldbe); # Problems with randbits
my($dev, $bits); # Number of one bits
my $randbits = $Config{randbits};
$max = $min = rand(1);
for (1..$reps) {
my $n = rand(1);
if ($n < 0.0 or $n >= 1.0) {
print <<EOM;
# WHOA THERE! \$Config{drand01} is set to '$Config{drand01}',
# but that apparently produces values < 0.0 or >= 1.0.
# Make sure \$Config{drand01} is a valid expression in the
# C-language, and produces values in the range [0.0,1.0).
#
# I give up.
EOM
exit;
}
$sum += $n;
$bits += bits($n * 256); # Don't be greedy; 8 is enough
# It's too many if randbits is less than 8!
# But that should never be the case... I hope.
# Note: If you change this, you must adapt the
# formula for absolute standard deviation, below.
$max = $n if $n > $max;
$min = $n if $n < $min;
}
# This test checks for one of Perl's most frequent
# mis-configurations. Your system's documentation
# for rand(2) should tell you what value you need
# for randbits. Usually the diagnostic message
# has the right value as well. Just fix it and
# recompile, and you'll usually be fine. (The main
# reason that the diagnostic message might get the
# wrong value is that Config.pm is incorrect.)
#
unless (ok( !$max <= 0 or $max >= (2 ** $randbits))) {# Just in case...
print <<DIAG;
# max=[$max] min=[$min]
# This perl was compiled with randbits=$randbits
# which is _way_ off. Or maybe your system rand is broken,
# or your C compiler can't multiply, or maybe Martians
# have taken over your computer. For starters, see about
# trying a better value for randbits, probably smaller.
DIAG
# If that isn't the problem, we'll have
# to put d_martians into Config.pm
print "# Skipping remaining tests until randbits is fixed.\n";
exit;
}
$off = log($max) / log(2); # log2
$off = int($off) + ($off > 0); # Next more positive int
unless (is( $off, 0 )) {
$shouldbe = $Config{randbits} + $off;
print "# max=[$max] min=[$min]\n";
print "# This perl was compiled with randbits=$randbits on $^O.\n";
print "# Consider using randbits=$shouldbe instead.\n";
# And skip the remaining tests; they would be pointless now.
print "# Skipping remaining tests until randbits is fixed.\n";
exit;
}
# This should always be true: 0 <= rand(1) < 1
# If this test is failing, something is seriously wrong,
# either in perl or your system's rand function.
#
unless (ok( !($min < 0 or $max >= 1) )) { # Slightly redundant...
print "# min too low\n" if $min < 0;
print "# max too high\n" if $max >= 1;
}
# This is just a crude test. The average number produced
# by rand should be about one-half. But once in a while
# it will be relatively far away. Note: This test will
# occasionally fail on a perfectly good system!
# See the hints for test 4 to see why.
#
$sum /= $reps;
unless (ok( !($sum < 0.4 or $sum > 0.6) )) {
print "# Average random number is far from 0.5\n";
}
# NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
# This test will fail .1% of the time on a normal system.
# also
# This test asks you to see these hints 100% of the time!
# NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
#
# There is probably no reason to be alarmed that
# something is wrong with your rand function. But,
# if you're curious or if you can't help being
# alarmed, keep reading.
#
# This is a less-crude test than test 3. But it has
# the same basic flaw: Unusually distributed random
# values should occasionally appear in every good
# random number sequence. (If you flip a fair coin
# twenty times every day, you'll see it land all
# heads about one time in a million days, on the
# average. That might alarm you if you saw it happen
# on the first day!)
#
# So, if this test failed on you once, run it a dozen
# times. If it keeps failing, it's likely that your
# rand is bogus. If it keeps passing, it's likely
# that the one failure was bogus. If it's a mix,
# read on to see about how to interpret the tests.
#
# The number printed in square brackets is the
# standard deviation, a statistical measure
# of how unusual rand's behavior seemed. It should
# fall in these ranges with these *approximate*
# probabilities:
#
# under 1 68.26% of the time
# 1-2 27.18% of the time
# 2-3 4.30% of the time
# over 3 0.26% of the time
#
# If the numbers you see are not scattered approximately
# (not exactly!) like that table, check with your vendor
# to find out what's wrong with your rand. Or with this
# algorithm. :-)
#
# Calculating absoulute standard deviation for number of bits set
# (eight bits per rep)
$dev = abs ($bits - $reps * 4) / sqrt($reps * 2);
ok( $dev < 3.3 );
if ($dev < 1.96) {
print "# Your rand seems fine. If this test failed\n";
print "# previously, you may want to run it again.\n";
} elsif ($dev < 2.575) {
print "# This is ok, but suspicious. But it will happen\n";
print "# one time out of 25, more or less.\n";
print "# You should run this test again to be sure.\n";
} elsif ($dev < 3.3) {
print "# This is very suspicious. It will happen only\n";
print "# about one time out of 100, more or less.\n";
print "# You should run this test again to be sure.\n";
} elsif ($dev < 3.9) {
print "# This is VERY suspicious. It will happen only\n";
print "# about one time out of 1000, more or less.\n";
print "# You should run this test again to be sure.\n";
} else {
print "# This is VERY VERY suspicious.\n";
print "# Your rand seems to be bogus.\n";
}
print "#\n# If you are having random number troubles,\n";
print "# see the hints within the test script for more\n";
printf "# information on why this might fail. [ %.3f ]\n", $dev;
}
# Now, let's see whether rand accepts its argument
{
my($max, $min);
$max = $min = rand(100);
for (1..$reps) {
my $n = rand(100);
$max = $n if $n > $max;
$min = $n if $n < $min;
}
# This test checks to see that rand(100) really falls
# within the range 0 - 100, and that the numbers produced
# have a reasonably-large range among them.
#
unless ( ok( !($min < 0 or $max >= 100 or ($max - $min) < 65) ) ) {
print "# min too low\n" if $min < 0;
print "# max too high\n" if $max >= 100;
print "# range too narrow\n" if ($max - $min) < 65;
}
# This test checks that rand without an argument
# is equivalent to rand(1).
#
$_ = 12345; # Just for fun.
srand 12345;
my $r = rand;
srand 12345;
is(rand(1), $r, 'rand() without args is rand(1)');
# This checks that rand without an argument is not
# rand($_). (In case somebody got overzealous.)
#
ok($r < 1, 'rand() without args is under 1');
}
--- NEW FILE: groups.t ---
#!./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 <<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
}
last GROUPS;
}
# Okay, not today.
quit();
}
chomp($groups);
print "# groups = $groups\n";
# Remember that group names can contain whitespace, '-', et cetera.
# That is: do not \w, do not \S.
if ($groups =~ /groups=(.+)( [ug]id=|$)/) {
my $gr = $1;
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";
$groups = "@g1";
}
print "1..2\n";
$pwgid = $( + 0;
($pwgnam) = getgrgid($pwgid);
$seen{$pwgid}++;
print "# pwgid = $pwgid, pwgnam = $pwgnam\n";
for (split(' ', $()) {
($group) = getgrgid($_);
next if (! defined $group or ! grep { $_ eq $group } @gr) and $seen{$_}++;
if (defined $group) {
push(@gr, $group);
}
else {
push(@gr, $_);
}
}
print "# gr = @gr\n";
my %did;
if ($^O =~ /^(?:uwin|cygwin|interix|solaris)$/) {
# Or anybody else who can have spaces in group names.
$gr1 = join(' ', grep(!$did{$_}++, sort split(' ', join(' ', @gr))));
} else {
# Don't assume that there aren't duplicate groups
$gr1 = join(' ', sort grep defined $_ && !$did{$_}++, @gr);
}
if ($Config{myuname} =~ /^cygwin_nt/i) { # basegroup on CYGWIN_NT has id = 0.
@basegroup{$pwgid,$pwgnam} = (0,0);
} else {
@basegroup{$pwgid,$pwgnam} = (1,1);
}
$gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups)));
my $ok1 = 0;
if ($gr1 eq $gr2 || ($gr1 eq '' && $gr2 eq $pwgid)) {
print "ok 1\n";
$ok1++;
}
elsif ($Config{myuname} =~ /^cygwin_nt/i) { # basegroup on CYGWIN_NT has id = 0.
# Retry in default unix mode
%basegroup = ( $pwgid => 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";
}
--- NEW FILE: tr.t ---
# tr.t
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
plan tests => 100;
my $Is_EBCDIC = (ord('i') == 0x89 & ord('J') == 0xd1);
$_ = "abcdefghijklmnopqrstuvwxyz";
tr/a-z/A-Z/;
is($_, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", 'uc');
tr/A-Z/a-z/;
is($_, "abcdefghijklmnopqrstuvwxyz", 'lc');
tr/b-y/B-Y/;
is($_, "aBCDEFGHIJKLMNOPQRSTUVWXYz", 'partial uc');
# In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91.
# Yes, discontinuities. Regardless, the \xca in the below should stay
# untouched (and not became \x8a).
{
no utf8;
$_ = "I\xcaJ";
tr/I-J/i-j/;
is($_, "i\xcaj", 'EBCDIC discontinuity');
}
#
($x = 12) =~ tr/1/3/;
(my $y = 12) =~ tr/1/3/;
($f = 1.5) =~ tr/1/3/;
(my $g = 1.5) =~ tr/1/3/;
is($x + $y + $f + $g, 71, 'tr cancels IOK and NOK');
# perlbug [ID 20000511.005]
$_ = 'fred';
/([a-z]{2})/;
$1 =~ tr/A-Z//;
s/^(\s*)f/$1F/;
is($_, 'Fred', 'harmless if explicitly not updating');
# A variant of the above, added in 5.7.2
$_ = 'fred';
/([a-z]{2})/;
eval '$1 =~ tr/A-Z/A-Z/;';
s/^(\s*)f/$1F/;
is($_, 'Fred', 'harmless if implicitly not updating');
is($@, '', ' no error');
# check tr handles UTF8 correctly
($x = 256.65.258) =~ tr/a/b/;
is($x, 256.65.258, 'handles UTF8');
is(length $x, 3);
$x =~ tr/A/B/;
is(length $x, 3);
if (ord("\t") == 9) { # ASCII
is($x, 256.66.258);
}
else {
is($x, 256.65.258);
}
# EBCDIC variants of the above tests
($x = 256.193.258) =~ tr/a/b/;
is(length $x, 3);
is($x, 256.193.258);
$x =~ tr/A/B/;
is(length $x, 3);
if (ord("\t") == 9) { # ASCII
is($x, 256.193.258);
}
else {
is($x, 256.194.258);
}
{
my $l = chr(300); my $r = chr(400);
$x = 200.300.400;
$x =~ tr/\x{12c}/\x{190}/;
is($x, 200.400.400,
'changing UTF8 chars in a UTF8 string, same length');
is(length $x, 3);
$x = 200.300.400;
$x =~ tr/\x{12c}/\x{be8}/;
is($x, 200.3048.400, ' more bytes');
is(length $x, 3);
$x = 100.125.60;
$x =~ tr/\x{64}/\x{190}/;
is($x, 400.125.60, 'Putting UT8 chars into a non-UTF8 string');
is(length $x, 3);
$x = 400.125.60;
$x =~ tr/\x{190}/\x{64}/;
is($x, 100.125.60, 'Removing UTF8 chars from UTF8 string');
is(length $x, 3);
$x = 400.125.60.400;
$y = $x =~ tr/\x{190}/\x{190}/;
is($y, 2, 'Counting UTF8 chars in UTF8 string');
$x = 60.400.125.60.400;
$y = $x =~ tr/\x{3c}/\x{3c}/;
is($y, 2, ' non-UTF8 chars in UTF8 string');
# 17 - counting UTF8 chars in non-UTF8 string
$x = 200.125.60;
$y = $x =~ tr/\x{190}/\x{190}/;
is($y, 0, ' UTF8 chars in non-UTFs string');
}
$_ = "abcdefghijklmnopqrstuvwxyz";
eval 'tr/a-z-9/ /';
like($@, qr/^Ambiguous range in transliteration operator/, 'tr/a-z-9//');
# 19-21: Make sure leading and trailing hyphens still work
$_ = "car-rot9";
tr/-a-m/./;
is($_, '..r.rot9', 'hyphens, leading');
$_ = "car-rot9";
tr/a-m-/./;
is($_, '..r.rot9', ' trailing');
$_ = "car-rot9";
tr/-a-m-/./;
is($_, '..r.rot9', ' both');
$_ = "abcdefghijklmnop";
tr/ae-hn/./;
is($_, '.bcd....ijklm.op');
$_ = "abcdefghijklmnop";
tr/a-cf-kn-p/./;
is($_, '...de......lm...');
$_ = "abcdefghijklmnop";
tr/a-ceg-ikm-o/./;
is($_, '...d.f...j.l...p');
# 20000705 MJD
eval "tr/m-d/ /";
like($@, qr/^Invalid range "m-d" in transliteration operator/,
'reversed range check');
eval '$1 =~ tr/x/y/';
like($@, qr/^Modification of a read-only value attempted/,
'cannot update read-only var');
'abcdef' =~ /(bcd)/;
is(eval '$1 =~ tr/abcd//', 3, 'explicit read-only count');
is($@, '', ' no error');
'abcdef' =~ /(bcd)/;
is(eval '$1 =~ tr/abcd/abcd/', 3, 'implicit read-only count');
is($@, '', ' no error');
is(eval '"123" =~ tr/12//', 2, 'LHS of non-updating tr');
eval '"123" =~ tr/1/2/';
like($@, qr|^Can't modify constant item in transliteration \(tr///\)|,
'LHS bad on updating tr');
# v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac)
# v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90)
# Transliterate a byte to a byte, all four ways.
($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/;
is($a, v300.197.172.300.197.172, 'byte2byte transliteration');
($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/;
is($a, v300.197.172.300.197.172);
($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/;
is($a, v300.197.172.300.197.172);
($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/;
is($a, v300.197.172.300.197.172);
($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/;
is($a, v300.301.172.300.301.172, 'byte2wide transliteration');
($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/;
is($a, v195.196.172.195.196.172, ' wide2byte');
($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/;
is($a, v301.196.172.301.196.172, ' wide2wide');
($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/;
is($a, v195.301.172.195.301.172, 'byte2wide & wide2byte');
($a = v300.196.172.300.196.172.400.198.144) =~
tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/;
is($a, v197.301.173.197.301.173.401.198.144, 'all together now!');
is((($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/), 2,
'transliterate and count');
is((($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/), 2);
($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c;
is($a, v301.196.301.301.196.301, 'translit w/complement');
($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c;
is($a, v300.197.197.300.197.197);
($a = v300.196.172.300.196.172) =~ tr/\xc4//d;
is($a, v300.172.300.172, 'translit w/deletion');
($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d;
is($a, v196.172.196.172);
($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s;
is($a, v197.172.300.300.197.172, 'translit w/squeeze');
($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s;
is($a, v196.172.301.196.172.172);
# Tricky cases (When Simon Cozens Attacks)
($a = v196.172.200) =~ tr/\x{12c}/a/;
is(sprintf("%vd", $a), '196.172.200');
($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/;
is(sprintf("%vd", $a), '196.172.200');
($a = v196.172.200) =~ tr/\x{12c}//d;
is(sprintf("%vd", $a), '196.172.200');
# UTF8 range tests from Inaba Hiroto
# Not working in EBCDIC as of 12674.
($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/;
is($a, v192.196.172.194.197.172, 'UTF range');
($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/;
is($a, v300.300.172.302.301.172);
# UTF8 range tests from Karsten Sperling (patch #9008 required)
($a = "\x{0100}") =~ tr/\x00-\x{100}/X/;
is($a, "X");
($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}/X/c;
is($a, "X");
($a = "\x{0100}") =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
is($a, "X");
($a = v256) =~ tr/\x{0000}-\x{00ff}\x{0101}/X/c;
is($a, "X");
# UTF8 range tests from Inaba Hiroto
($a = "\x{200}") =~ tr/\x00-\x{100}/X/c;
is($a, "X");
($a = "\x{200}") =~ tr/\x00-\x{100}/X/cs;
is($a, "X");
# Tricky on EBCDIC: while [a-z] [A-Z] must not match the gap characters,
# (i-j, r-s, I-J, R-S), [\x89-\x91] [\xc9-\xd1] has to match them,
# from Karsten Sperling.
$c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/\x89-\x91/X/;
is($c, 8);
is($a, "XXXXXXXX");
$c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/\xc9-\xd1/X/;
is($c, 8);
is($a, "XXXXXXXX");
SKIP: {
skip "not EBCDIC", 4 unless $Is_EBCDIC;
$c = ($a = "\x89\x8a\x8b\x8c\x8d\x8f\x90\x91") =~ tr/i-j/X/;
is($c, 2);
is($a, "X\x8a\x8b\x8c\x8d\x8f\x90X");
$c = ($a = "\xc9\xca\xcb\xcc\xcd\xcf\xd0\xd1") =~ tr/I-J/X/;
is($c, 2);
is($a, "X\xca\xcb\xcc\xcd\xcf\xd0X");
}
($a = "\x{100}") =~ tr/\x00-\xff/X/c;
is(ord($a), ord("X"));
($a = "\x{100}") =~ tr/\x00-\xff/X/cs;
is(ord($a), ord("X"));
($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//c;
is($a, "\x{100}\x{100}");
($a = "\x{100}\x{100}") =~ tr/\x{101}-\x{200}//cs;
is($a, "\x{100}");
$a = "\xfe\xff"; $a =~ tr/\xfe\xff/\x{1ff}\x{1fe}/;
is($a, "\x{1ff}\x{1fe}");
# From David Dyck
($a = "R0_001") =~ tr/R_//d;
is(hex($a), 1);
# From Inaba Hiroto
@a = (1,2); map { y/1/./ for $_ } @a;
is("@a", ". 2");
@a = (1,2); map { y/1/./ for $_.'' } @a;
is("@a", "1 2");
# Additional test for Inaba Hiroto patch (robin at kitsite.com)
($a = "\x{100}\x{102}\x{101}") =~ tr/\x00-\377/XYZ/c;
is($a, "XZY");
# Used to fail with "Modification of a read-only value attempted"
%a = (N=>1);
foreach (keys %a) {
eval 'tr/N/n/';
is($_, 'n', 'pp_trans needs to unshare shared hash keys');
is($@, '', ' no error');
}
$x = eval '"1213" =~ tr/1/1/';
is($x, 2, 'implicit count on constant');
is($@, '', ' no error');
my @foo = ();
eval '$foo[-1] =~ tr/N/N/';
is( $@, '', 'implicit count outside array bounds, index negative' );
is( scalar @foo, 0, " doesn't extend the array");
eval '$foo[1] =~ tr/N/N/';
is( $@, '', 'implicit count outside array bounds, index positive' );
is( scalar @foo, 0, " doesn't extend the array");
my %foo = ();
eval '$foo{bar} =~ tr/N/N/';
is( $@, '', 'implicit count outside hash bounds' );
is( scalar keys %foo, 0, " doesn't extend the hash");
$x = \"foo";
is( $x =~ tr/A/A/, 2, 'non-modifying tr/// on a scalar ref' );
is( ref $x, 'SCALAR', " doesn't stringify its argument" );
# rt.perl.org 36622. Perl didn't like a y/// at end of file. No trailing
# newline allowed.
fresh_perl_is(q[$_ = "foo"; y/A-Z/a-z/], '');
--- NEW FILE: pwent.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
eval {my @n = getpwuid 0; setpwent()};
if ($@ && $@ =~ /(The \w+ function is unimplemented)/) {
print "1..0 # Skip: $1\n";
exit 0;
}
eval { require Config; import Config; };
my $reason;
if ($Config{'i_pwd'} ne 'define') {
$reason = '$Config{i_pwd} undefined';
}
elsif (not -f "/etc/passwd" ) { # Play safe.
$reason = 'no /etc/passwd file';
}
if (not defined $where) { # Try NIS.
foreach my $ypcat (qw(/usr/bin/ypcat /bin/ypcat /etc/ypcat)) {
if (-x $ypcat &&
open(PW, "$ypcat passwd 2>/dev/null |") &&
defined(<PW>)) {
$where = "NIS passwd";
undef $reason;
last;
}
}
}
if (not defined $where) { # Try NetInfo.
foreach my $nidump (qw(/usr/bin/nidump)) {
if (-x $nidump &&
open(PW, "$nidump passwd . 2>/dev/null |") &&
defined(<PW>)) {
$where = "NetInfo passwd";
undef $reason;
last;
}
}
}
if (not defined $where) { # Try local.
my $PW = "/etc/passwd";
if (-f $PW && open(PW, $PW) && defined(<PW>)) {
$where = $PW;
undef $reason;
}
}
if (not defined $where) { # Try NIS+
foreach my $niscat (qw(/bin/niscat)) {
if (-x $niscat &&
open(PW, "$niscat passwd.org_dir 2>/dev/null |") &&
defined(<PW>)) {
$where = "NIS+ $niscat passwd.org_dir";
undef $reason;
last;
}
}
}
if ($reason) { # Give up.
print "1..0 # Skip: $reason\n";
exit 0;
}
}
# By now the PW filehandle should be open and full of juicy password entries.
print "1..2\n";
# Go through at most this many users.
# (note that the first entry has been read away by now)
my $max = 25;
my $n = 0;
my $tst = 1;
my %perfect;
my %seen;
print "# where $where\n";
setpwent();
while (<PW>) {
chomp;
# LIMIT -1 so that users with empty shells don't fall off
my @s = split /:/, $_, -1;
my ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s);
if ($^O eq 'darwin') {
($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s[0,1,2,3,7,8,9];
} else {
($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s;
}
next if /^\+/; # ignore NIS includes
if (@s) {
push @{ $seen{$name_s} }, $.;
} else {
warn "# Your $where line $. is empty.\n";
next;
}
if ($n == $max) {
local $/;
my $junk = <PW>;
last;
}
# In principle we could whine if @s != 7 but do we know enough
# of passwd file formats everywhere?
if (@s == 7 || ($^O eq 'darwin' && @s == 10)) {
@n = getpwuid($uid_s);
# 'nobody' et al.
next unless @n;
my ($name,$passwd,$uid,$gid,$quota,$comment,$gcos,$home,$shell) = @n;
# Protect against one-to-many and many-to-one mappings.
if ($name_s ne $name) {
@n = getpwnam($name_s);
($name,$passwd,$uid,$gid,$quota,$comment,$gcos,$home,$shell) = @n;
next if $name_s ne $name;
}
$perfect{$name_s}++
if $name eq $name_s and
$uid eq $uid_s and
# Do not compare passwords: think shadow passwords.
$gid eq $gid_s and
$gcos eq $gcos_s and
$home eq $home_s and
$shell eq $shell_s;
}
$n++;
}
endpwent();
print "# max = $max, n = $n, perfect = ", scalar keys %perfect, "\n";
if (keys %perfect == 0 && $n) {
$max++;
print <<EOEX;
#
# The failure of op/pwent test is not necessarily serious.
# It may fail due to local password administration conventions.
# If you are for example using both NIS and local passwords,
# test failure is possible. Any distributed password scheme
# can cause such failures.
#
# What the pwent test is doing is that it compares the $max first
# entries of $where
# with the results of getpwuid() and getpwnam() call. If it finds no
# matches at all, it suspects something is wrong.
#
EOEX
print "not ";
$not = 1;
} else {
$not = 0;
}
print "ok ", $tst++;
print "\t# (not necessarily serious: run t/op/pwent.t by itself)" if $not;
print "\n";
# Test both the scalar and list contexts.
my @pw1;
setpwent();
for (1..$max) {
my $pw = scalar getpwent();
last unless defined $pw;
push @pw1, $pw;
}
endpwent();
my @pw2;
setpwent();
for (1..$max) {
my ($pw) = (getpwent());
last unless defined $pw;
push @pw2, $pw;
}
endpwent();
print "not " unless "@pw1" eq "@pw2";
print "ok ", $tst++, "\n";
close(PW);
--- NEW FILE: cond.t ---
#!./perl
# $RCSfile: cond.t,v $$Revision: 1.2 $$Date: 2006-12-04 17:02:00 $
print "1..4\n";
print 1 ? "ok 1\n" : "not ok 1\n"; # compile time
print 0 ? "not ok 2\n" : "ok 2\n";
$x = 1;
print $x ? "ok 3\n" : "not ok 3\n"; # run time
print !$x ? "not ok 4\n" : "ok 4\n";
--- NEW FILE: closure.t ---
#!./perl
# -*- Mode: Perl -*-
# closure.t:
# Original written by Ulrich Pfeifer on 2 Jan 1997.
# Greatly extended by Tom Phoenix <rootbeer at teleport.com> on 28 Jan 1997.
#
# Run with -debug for debugging output.
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use Config;
require './test.pl'; # for runperl()
print "1..187\n";
my $test = 1;
sub test (&) {
my $ok = &{$_[0]};
print $ok ? "ok $test\n" : "not ok $test\n";
printf "# Failed at line %d\n", (caller)[2] unless $ok;
$test++;
}
my $i = 1;
sub foo { $i = shift if @_; $i }
# no closure
test { foo == 1 };
foo(2);
test { foo == 2 };
# closure: lexical outside sub
my $foo = sub {$i = shift if @_; $i };
my $bar = sub {$i = shift if @_; $i };
test {&$foo() == 2 };
&$foo(3);
test {&$foo() == 3 };
# did the lexical change?
test { foo == 3 and $i == 3};
# did the second closure notice?
test {&$bar() == 3 };
# closure: lexical inside sub
sub bar {
my $i = shift;
sub { $i = shift if @_; $i }
}
$foo = bar(4);
$bar = bar(5);
test {&$foo() == 4 };
&$foo(6);
test {&$foo() == 6 };
test {&$bar() == 5 };
# nested closures
sub bizz {
my $i = 7;
if (@_) {
my $i = shift;
sub {$i = shift if @_; $i };
} else {
my $i = $i;
sub {$i = shift if @_; $i };
}
}
$foo = bizz();
$bar = bizz();
test {&$foo() == 7 };
&$foo(8);
test {&$foo() == 8 };
test {&$bar() == 7 };
$foo = bizz(9);
$bar = bizz(10);
test {&$foo(11)-1 == &$bar()};
my @foo;
for (qw(0 1 2 3 4)) {
my $i = $_;
$foo[$_] = sub {$i = shift if @_; $i };
}
test {
&{$foo[0]}() == 0 and
&{$foo[1]}() == 1 and
&{$foo[2]}() == 2 and
&{$foo[3]}() == 3 and
&{$foo[4]}() == 4
};
for (0 .. 4) {
&{$foo[$_]}(4-$_);
}
test {
&{$foo[0]}() == 4 and
&{$foo[1]}() == 3 and
&{$foo[2]}() == 2 and
&{$foo[3]}() == 1 and
&{$foo[4]}() == 0
};
sub barf {
my @foo;
for (qw(0 1 2 3 4)) {
my $i = $_;
$foo[$_] = sub {$i = shift if @_; $i };
}
@foo;
}
@foo = barf();
test {
&{$foo[0]}() == 0 and
&{$foo[1]}() == 1 and
&{$foo[2]}() == 2 and
&{$foo[3]}() == 3 and
&{$foo[4]}() == 4
};
for (0 .. 4) {
&{$foo[$_]}(4-$_);
}
test {
&{$foo[0]}() == 4 and
&{$foo[1]}() == 3 and
&{$foo[2]}() == 2 and
&{$foo[3]}() == 1 and
&{$foo[4]}() == 0
};
# test if closures get created in optimized for loops
my %foo;
for my $n ('A'..'E') {
$foo{$n} = sub { $n eq $_[0] };
}
test {
&{$foo{A}}('A') and
&{$foo{B}}('B') and
&{$foo{C}}('C') and
&{$foo{D}}('D') and
&{$foo{E}}('E')
};
for my $n (0..4) {
$foo[$n] = sub { $n == $_[0] };
}
test {
&{$foo[0]}(0) and
&{$foo[1]}(1) and
&{$foo[2]}(2) and
&{$foo[3]}(3) and
&{$foo[4]}(4)
};
for my $n (0..4) {
$foo[$n] = sub {
# no intervening reference to $n here
sub { $n == $_[0] }
};
}
test {
$foo[0]->()->(0) and
$foo[1]->()->(1) and
$foo[2]->()->(2) and
$foo[3]->()->(3) and
$foo[4]->()->(4)
};
{
my $w;
$w = sub {
my ($i) = @_;
test { $i == 10 };
sub { $w };
};
$w->(10);
}
# Additional tests by Tom Phoenix <rootbeer at teleport.com>.
{
use strict;
use vars qw!$test!;
my($debugging, %expected, $inner_type, $where_declared, $within);
my($nc_attempt, $call_outer, $call_inner, $undef_outer);
my($code, $inner_sub_test, $expected, $line, $errors, $output);
my(@inners, $sub_test, $pid);
$debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug';
# The expected values for these tests
%expected = (
'global_scalar' => 1001,
'global_array' => 2101,
'global_hash' => 3004,
'fs_scalar' => 4001,
'fs_array' => 5101,
'fs_hash' => 6004,
'sub_scalar' => 7001,
'sub_array' => 8101,
'sub_hash' => 9004,
'foreach' => 10011,
);
# Our innermost sub is either named or anonymous
for $inner_type (qw!named anon!) {
# And it may be declared at filescope, within a named
# sub, or within an anon sub
for $where_declared (qw!filescope in_named in_anon!) {
# And that, in turn, may be within a foreach loop,
# a naked block, or another named sub
for $within (qw!foreach naked other_sub!) {
# Here are a number of variables which show what's
# going on, in a way.
$nc_attempt = 0+ # Named closure attempted
( ($inner_type eq 'named') ||
($within eq 'other_sub') ) ;
$call_inner = 0+ # Need to call &inner
( ($inner_type eq 'anon') &&
($within eq 'other_sub') ) ;
$call_outer = 0+ # Need to call &outer or &$outer
( ($inner_type eq 'anon') &&
($within ne 'other_sub') ) ;
$undef_outer = 0+ # $outer is created but unused
( ($where_declared eq 'in_anon') &&
(not $call_outer) ) ;
$code = "# This is a test script built by t/op/closure.t\n\n";
print <<"DEBUG_INFO" if $debugging;
# inner_type: $inner_type
# where_declared: $where_declared
# within: $within
# nc_attempt: $nc_attempt
# call_inner: $call_inner
# call_outer: $call_outer
# undef_outer: $undef_outer
DEBUG_INFO
$code .= <<"END_MARK_ONE";
BEGIN { \$SIG{__WARN__} = sub {
my \$msg = \$_[0];
END_MARK_ONE
$code .= <<"END_MARK_TWO" if $nc_attempt;
return if index(\$msg, 'will not stay shared') != -1;
return if index(\$msg, 'may be unavailable') != -1;
END_MARK_TWO
$code .= <<"END_MARK_THREE"; # Backwhack a lot!
print "not ok: got unexpected warning \$msg\\n";
} }
{
my \$test = $test;
sub test (&) {
my \$ok = &{\$_[0]};
print \$ok ? "ok \$test\n" : "not ok \$test\n";
printf "# Failed at line %d\n", (caller)[2] unless \$ok;
\$test++;
}
}
# some of the variables which the closure will access
\$global_scalar = 1000;
\@global_array = (2000, 2100, 2200, 2300);
%global_hash = 3000..3009;
my \$fs_scalar = 4000;
my \@fs_array = (5000, 5100, 5200, 5300);
my %fs_hash = 6000..6009;
END_MARK_THREE
if ($where_declared eq 'filescope') {
# Nothing here
} elsif ($where_declared eq 'in_named') {
$code .= <<'END';
sub outer {
my $sub_scalar = 7000;
my @sub_array = (8000, 8100, 8200, 8300);
my %sub_hash = 9000..9009;
END
# }
} elsif ($where_declared eq 'in_anon') {
$code .= <<'END';
$outer = sub {
my $sub_scalar = 7000;
my @sub_array = (8000, 8100, 8200, 8300);
my %sub_hash = 9000..9009;
END
# }
} else {
die "What was $where_declared?"
}
if ($within eq 'foreach') {
$code .= "
my \$foreach = 12000;
my \@list = (10000, 10010);
foreach \$foreach (\@list) {
" # }
} elsif ($within eq 'naked') {
$code .= " { # naked block\n" # }
} elsif ($within eq 'other_sub') {
$code .= " sub inner_sub {\n" # }
} else {
die "What was $within?"
}
$sub_test = $test;
@inners = ( qw!global_scalar global_array global_hash! ,
qw!fs_scalar fs_array fs_hash! );
push @inners, 'foreach' if $within eq 'foreach';
if ($where_declared ne 'filescope') {
push @inners, qw!sub_scalar sub_array sub_hash!;
}
for $inner_sub_test (@inners) {
if ($inner_type eq 'named') {
$code .= " sub named_$sub_test "
} elsif ($inner_type eq 'anon') {
$code .= " \$anon_$sub_test = sub "
} else {
die "What was $inner_type?"
}
# Now to write the body of the test sub
if ($inner_sub_test eq 'global_scalar') {
$code .= '{ ++$global_scalar }'
} elsif ($inner_sub_test eq 'fs_scalar') {
$code .= '{ ++$fs_scalar }'
} elsif ($inner_sub_test eq 'sub_scalar') {
$code .= '{ ++$sub_scalar }'
} elsif ($inner_sub_test eq 'global_array') {
$code .= '{ ++$global_array[1] }'
} elsif ($inner_sub_test eq 'fs_array') {
$code .= '{ ++$fs_array[1] }'
} elsif ($inner_sub_test eq 'sub_array') {
$code .= '{ ++$sub_array[1] }'
} elsif ($inner_sub_test eq 'global_hash') {
$code .= '{ ++$global_hash{3002} }'
} elsif ($inner_sub_test eq 'fs_hash') {
$code .= '{ ++$fs_hash{6002} }'
} elsif ($inner_sub_test eq 'sub_hash') {
$code .= '{ ++$sub_hash{9002} }'
} elsif ($inner_sub_test eq 'foreach') {
$code .= '{ ++$foreach }'
} else {
die "What was $inner_sub_test?"
}
# Close up
if ($inner_type eq 'anon') {
$code .= ';'
}
$code .= "\n";
$sub_test++; # sub name sequence number
} # End of foreach $inner_sub_test
# Close up $within block # {
$code .= " }\n\n";
# Close up $where_declared block
if ($where_declared eq 'in_named') { # {
$code .= "}\n\n";
} elsif ($where_declared eq 'in_anon') { # {
$code .= "};\n\n";
}
# We may need to do something with the sub we just made...
$code .= "undef \$outer;\n" if $undef_outer;
$code .= "&inner_sub;\n" if $call_inner;
if ($call_outer) {
if ($where_declared eq 'in_named') {
$code .= "&outer;\n\n";
} elsif ($where_declared eq 'in_anon') {
$code .= "&\$outer;\n\n"
}
}
# Now, we can actually prep to run the tests.
for $inner_sub_test (@inners) {
$expected = $expected{$inner_sub_test} or
die "expected $inner_sub_test missing";
# Named closures won't access the expected vars
if ( $nc_attempt and
substr($inner_sub_test, 0, 4) eq "sub_" ) {
$expected = 1;
}
# If you make a sub within a foreach loop,
# what happens if it tries to access the
# foreach index variable? If it's a named
# sub, it gets the var from "outside" the loop,
# but if it's anon, it gets the value to which
# the index variable is aliased.
#
# Of course, if the value was set only
# within another sub which was never called,
# the value has not been set yet.
#
if ($inner_sub_test eq 'foreach') {
if ($inner_type eq 'named') {
if ($call_outer || ($where_declared eq 'filescope')) {
$expected = 12001
} else {
$expected = 1
}
}
}
# Here's the test:
if ($inner_type eq 'anon') {
$code .= "test { &\$anon_$test == $expected };\n"
} else {
$code .= "test { &named_$test == $expected };\n"
}
$test++;
}
if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32' and $^O ne 'NetWare') {
# Fork off a new perl to run the tests.
# (This is so we can catch spurious warnings.)
$| = 1; print ""; $| = 0; # flush output before forking
pipe READ, WRITE or die "Can't make pipe: $!";
pipe READ2, WRITE2 or die "Can't make second pipe: $!";
die "Can't fork: $!" unless defined($pid = open PERL, "|-");
unless ($pid) {
# Child process here. We're going to send errors back
# through the extra pipe.
close READ;
close READ2;
open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!";
open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!";
exec which_perl(), '-w', '-'
or die "Can't exec perl: $!";
} else {
# Parent process here.
close WRITE;
close WRITE2;
print PERL $code;
close PERL;
{ local $/;
$output = join '', <READ>;
$errors = join '', <READ2>; }
close READ;
close READ2;
}
} else {
# No fork(). Do it the hard way.
my $cmdfile = "tcmd$$"; $cmdfile++ while -e $cmdfile;
my $errfile = "terr$$"; $errfile++ while -e $errfile;
my @tmpfiles = ($cmdfile, $errfile);
open CMD, ">$cmdfile"; print CMD $code; close CMD;
my $cmd = which_perl();
$cmd .= " -w $cmdfile 2>$errfile";
if ($^O eq 'VMS' or $^O eq 'MSWin32' or $^O eq 'NetWare') {
# Use pipe instead of system so we don't inherit STD* from
# this process, and then foul our pipe back to parent by
# redirecting output in the child.
open PERL,"$cmd |" or die "Can't open pipe: $!\n";
{ local $/; $output = join '', <PERL> }
close PERL;
} else {
my $outfile = "tout$$"; $outfile++ while -e $outfile;
push @tmpfiles, $outfile;
system "$cmd >$outfile";
{ local $/; open IN, $outfile; $output = <IN>; close IN }
}
if ($?) {
printf "not ok: exited with error code %04X\n", $?;
$debugging or do { 1 while unlink @tmpfiles };
exit;
}
{ local $/; open IN, $errfile; $errors = <IN>; close IN }
1 while unlink @tmpfiles;
}
print $output;
print STDERR $errors;
if ($debugging && ($errors || $? || ($output =~ /not ok/))) {
my $lnum = 0;
for $line (split '\n', $code) {
printf "%3d: %s\n", ++$lnum, $line;
}
}
printf "not ok: exited with error code %04X\n", $? if $?;
print '#', "-" x 30, "\n" if $debugging;
} # End of foreach $within
} # End of foreach $where_declared
} # End of foreach $inner_type
}
# The following dumps core with perl <= 5.8.0 (bugid 9535) ...
BEGIN { $vanishing_pad = sub { eval $_[0] } }
$some_var = 123;
test { $vanishing_pad->( '$some_var' ) == 123 };
# ... and here's another coredump variant - this time we explicitly
# delete the sub rather than using a BEGIN ...
sub deleteme { $a = sub { eval '$newvar' } }
deleteme();
*deleteme = sub {}; # delete the sub
$newvar = 123; # realloc the SV of the freed CV
test { $a->() == 123 };
# ... and a further coredump variant - the fixup of the anon sub's
# CvOUTSIDE pointer when the middle eval is freed, wasn't good enough to
# survive the outer eval also being freed.
$x = 123;
$a = eval q(
eval q[
sub { eval '$x' }
]
);
@a = ('\1\1\1\1\1\1\1') x 100; # realloc recently-freed CVs
test { $a->() == 123 };
# this coredumped on <= 5.8.0 because evaling the closure caused
# an SvFAKE to be added to the outer anon's pad, which was then grown.
my $outer;
sub {
my $x;
$x = eval 'sub { $outer }';
$x->();
$a = [ 99 ];
$x->();
}->();
test {1};
# [perl #17605] found that an empty block called in scalar context
# can lead to stack corruption
{
my $x = "foooobar";
$x =~ s/o//eg;
test { $x eq 'fbar' }
}
# DAPM 24-Nov-02
# SvFAKE lexicals should be visible thoughout a function.
# On <= 5.8.0, the third test failed, eg bugid #18286
{
my $x = 1;
sub fake {
test { sub {eval'$x'}->() == 1 };
{ $x; test { sub {eval'$x'}->() == 1 } }
test { sub {eval'$x'}->() == 1 };
}
}
fake();
# undefining a sub shouldn't alter visibility of outer lexicals
{
$x = 1;
my $x = 2;
sub tmp { sub { eval '$x' } }
my $a = tmp();
undef &tmp;
test { $a->() == 2 };
}
# handy class: $x = Watch->new(\$foo,'bar')
# causes 'bar' to be appended to $foo when $x is destroyed
sub Watch::new { bless [ $_[1], $_[2] ], $_[0] }
sub Watch::DESTROY { ${$_[0][0]} .= $_[0][1] }
# bugid 1028:
# nested anon subs (and associated lexicals) not freed early enough
sub linger {
my $x = Watch->new($_[0], '2');
sub {
$x;
my $y;
sub { $y; };
};
}
{
my $watch = '1';
linger(\$watch);
test { $watch eq '12' }
}
require "./test.pl";
curr_test(182);
# Because change #19637 was not applied to 5.8.1.
SKIP: { skip("tests not in 5.8.", 3) }
$test= 185;
{
# bugid #23265 - this used to coredump during destruction of PL_maincv
# and its children
my $progfile = "b23265.pl";
open(T, ">$progfile") or die "$0: $!\n";
print T << '__EOF__';
print
sub {$_[0]->(@_)} -> (
sub {
$_[1]
? $_[0]->($_[0], $_[1] - 1) . sub {"x"}->()
: "y"
},
2
)
, "\n"
;
__EOF__
close T;
my $got = runperl(progfile => $progfile);
test { chomp $got; $got eq "yxx" };
END { 1 while unlink $progfile }
}
{
# bugid #24914 = used to coredump restoring PL_comppad in the
# savestack, due to the early freeing of the anon closure
my $got = runperl(stderr => 1, prog =>
'sub d {die} my $f; $f = sub {my $x=1; $f = 0; d}; eval{$f->()}; print qq(ok\n)'
);
test { $got eq "ok\n" };
}
# After newsub is redefined outside the BEGIN, it's CvOUTSIDE should point
# to main rather than BEGIN, and BEGIN should be freed.
{
my $flag = 0;
sub X::DESTROY { $flag = 1 }
{
my $x;
BEGIN {$x = \&newsub }
sub newsub {};
$x = bless {}, 'X';
}
test { $flag == 1 };
}
--- NEW FILE: array.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '.', '../lib';
}
require 'test.pl';
plan (91);
#
# @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
#
@ary = (1,2,3,4,5);
is(join('', at ary), '12345');
$tmp = $ary[$#ary]; --$#ary;
is($tmp, 5);
is($#ary, 3);
is(join('', at ary), '1234');
$[ = 1;
@ary = (1,2,3,4,5);
is(join('', at ary), '12345');
$tmp = $ary[$#ary]; --$#ary;
is($tmp, 5);
# Must do == here beacuse $[ isn't 0
ok($#ary == 4);
is(join('', at ary), '1234');
is($ary[5], undef);
$#ary += 1; # see if element 5 gone for good
ok($#ary == 5);
ok(!defined $ary[5]);
$[ = 0;
@foo = ();
$r = join(',', $#foo, @foo);
is($r, "-1");
$foo[0] = '0';
$r = join(',', $#foo, @foo);
is($r, "0,0");
$foo[2] = '2';
$r = join(',', $#foo, @foo);
is($r, "2,0,,2");
@bar = ();
$bar[0] = '0';
$bar[1] = '1';
$r = join(',', $#bar, @bar);
is($r, "1,0,1");
@bar = ();
$r = join(',', $#bar, @bar);
is($r, "-1");
$bar[0] = '0';
$r = join(',', $#bar, @bar);
is($r, "0,0");
$bar[2] = '2';
$r = join(',', $#bar, @bar);
is($r, "2,0,,2");
reset 'b' if $^O ne 'VMS';
@bar = ();
$bar[0] = '0';
$r = join(',', $#bar, @bar);
is($r, "0,0");
$bar[2] = '2';
$r = join(',', $#bar, @bar);
is($r, "2,0,,2");
$foo = 'now is the time';
ok(scalar (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)));
is($F1, 'now');
is($F2, 'is');
is($Etc, 'the time');
$foo = 'lskjdf';
ok(!($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))))
or diag("$cnt $F1:$F2:$Etc");
%foo = ('blurfl','dyick','foo','bar','etc.','etc.');
%bar = %foo;
is($bar{'foo'}, 'bar');
%bar = ();
is($bar{'foo'}, undef);
(%bar,$a,$b) = (%foo,'how','now');
is($bar{'foo'}, 'bar');
is($bar{'how'}, 'now');
@bar{keys %foo} = values %foo;
is($bar{'foo'}, 'bar');
is($bar{'how'}, 'now');
@foo = grep(/e/,split(' ','now is the time for all good men to come to'));
is(join(' ', at foo), 'the time men come');
@foo = grep(!/e/,split(' ','now is the time for all good men to come to'));
is(join(' ', at foo), 'now is for all good to to');
$foo = join('',('a','b','c','d','e','f')[0..5]);
is($foo, 'abcdef');
$foo = join('',('a','b','c','d','e','f')[0..1]);
is($foo, 'ab');
$foo = join('',('a','b','c','d','e','f')[6]);
is($foo, '');
@foo = ('a','b','c','d','e','f')[0,2,4];
@bar = ('a','b','c','d','e','f')[1,3,5];
$foo = join('',(@foo, at bar)[0..5]);
is($foo, 'acebdf');
$foo = ('a','b','c','d','e','f')[0,2,4];
is($foo, 'e');
$foo = ('a','b','c','d','e','f')[1];
is($foo, 'b');
@foo = ( 'foo', 'bar', 'burbl');
push(foo, 'blah');
is($#foo, 3);
# various AASSIGN_COMMON checks (see newASSIGNOP() in op.c)
#curr_test(38);
@foo = @foo;
is("@foo", "foo bar burbl blah"); # 38
(undef, at foo) = @foo;
is("@foo", "bar burbl blah"); # 39
@foo = ('XXX', at foo, 'YYY');
is("@foo", "XXX bar burbl blah YYY"); # 40
@foo = @foo = qw(foo b\a\r bu\\rbl blah);
is("@foo", 'foo b\a\r bu\\rbl blah'); # 41
@bar = @foo = qw(foo bar); # 42
is("@foo", "foo bar");
is("@bar", "foo bar"); # 43
# try the same with local
# XXX tie-stdarray fails the tests involving local, so we use
# different variable names to escape the 'tie'
@bee = ( 'foo', 'bar', 'burbl', 'blah');
{
local @bee = @bee;
is("@bee", "foo bar burbl blah"); # 44
{
local (undef, at bee) = @bee;
is("@bee", "bar burbl blah"); # 45
{
local @bee = ('XXX', at bee,'YYY');
is("@bee", "XXX bar burbl blah YYY"); # 46
{
local @bee = local(@bee) = qw(foo bar burbl blah);
is("@bee", "foo bar burbl blah"); # 47
{
local (@bim) = local(@bee) = qw(foo bar);
is("@bee", "foo bar"); # 48
is("@bim", "foo bar"); # 49
}
is("@bee", "foo bar burbl blah"); # 50
}
is("@bee", "XXX bar burbl blah YYY"); # 51
}
is("@bee", "bar burbl blah"); # 52
}
is("@bee", "foo bar burbl blah"); # 53
}
# try the same with my
{
my @bee = @bee;
is("@bee", "foo bar burbl blah"); # 54
{
my (undef, at bee) = @bee;
is("@bee", "bar burbl blah"); # 55
{
my @bee = ('XXX', at bee,'YYY');
is("@bee", "XXX bar burbl blah YYY"); # 56
{
my @bee = my @bee = qw(foo bar burbl blah);
is("@bee", "foo bar burbl blah"); # 57
{
my (@bim) = my(@bee) = qw(foo bar);
is("@bee", "foo bar"); # 58
is("@bim", "foo bar"); # 59
}
is("@bee", "foo bar burbl blah"); # 60
}
is("@bee", "XXX bar burbl blah YYY"); # 61
}
is("@bee", "bar burbl blah"); # 62
}
is("@bee", "foo bar burbl blah"); # 63
}
# make sure reification behaves
my $t = curr_test();
sub reify { $_[1] = $t++; print "@_\n"; }
reify('ok');
reify('ok');
curr_test($t);
# qw() is no longer a runtime split, it's compiletime.
is (qw(foo bar snorfle)[2], 'snorfle');
@ary = (12,23,34,45,56);
is(shift(@ary), 12);
is(pop(@ary), 56);
is(push(@ary,56), 4);
is(unshift(@ary,12), 5);
sub foo { "a" }
@foo=(foo())[0,0];
is ($foo[1], "a");
# $[ should have the same effect regardless of whether the aelem
# op is optimized to aelemfast.
sub tary {
local $[ = 10;
my $five = 5;
is ($tary[5], $tary[$five]);
}
@tary = (0..50);
tary();
# bugid #15439 - clearing an array calls destructors which may try
# to modify the array - caused 'Attempt to free unreferenced scalar'
my $got = runperl (
prog => q{
sub X::DESTROY { @a = () }
@a = (bless {}, 'X');
@a = ();
},
stderr => 1
);
$got =~ s/\n/ /g;
is ($got, '');
# Test negative and funky indices.
{
my @a = 0..4;
is($a[-1], 4);
is($a[-2], 3);
is($a[-5], 0);
ok(!defined $a[-6]);
is($a[2.1] , 2);
is($a[2.9] , 2);
is($a[undef], 0);
is($a["3rd"], 3);
}
{
my @a;
eval '$a[-1] = 0';
like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0");
}
sub test_arylen {
my $ref = shift;
local $^W = 1;
is ($$ref, undef, "\$# on freed array is undef");
my @warn;
local $SIG{__WARN__} = sub {push @warn, "@_"};
$$ref = 1000;
is (scalar @warn, 1);
like ($warn[0], qr/^Attempt to set length of freed array/);
}
{
my $a = \$#{[]};
# Need a new statement to make it go out of scope
test_arylen ($a);
test_arylen (do {my @a; \$#a});
}
--- NEW FILE: goto.t ---
#!./perl
# "This IS structured code. It's just randomly structured."
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
require "test.pl";
}
use warnings;
use strict;
plan tests => 57;
our $foo;
while ($?) {
$foo = 1;
label1:
$foo = 2;
goto label2;
} continue {
$foo = 0;
goto label4;
label3:
$foo = 4;
goto label4;
}
goto label1;
$foo = 3;
label2:
is($foo, 2, 'escape while loop');
goto label3;
label4:
is($foo, 4, 'second escape while loop');
my $r = run_perl(prog => 'goto foo;', stderr => 1);
like($r, qr/label/, 'cant find label');
my $ok = 0;
sub foo {
goto bar;
return;
bar:
$ok = 1;
}
&foo;
ok($ok, 'goto in sub');
sub bar {
my $x = 'bypass';
eval "goto $x";
}
&bar;
exit;
FINALE:
is(curr_test(), 16, 'FINALE');
# does goto LABEL handle block contexts correctly?
# note that this scope-hopping differs from last & next,
# which always go up-scope strictly.
my $count = 0;
my $cond = 1;
for (1) {
if ($cond == 1) {
$cond = 0;
goto OTHER;
}
elsif ($cond == 0) {
OTHER:
$cond = 2;
is($count, 0, 'OTHER');
$count++;
goto THIRD;
}
else {
THIRD:
is($count, 1, 'THIRD');
$count++;
}
}
is($count, 2, 'end of loop');
# Does goto work correctly within a for(;;) loop?
# (BUG ID 20010309.004)
for(my $i=0;!$i++;) {
my $x=1;
goto label;
label: is($x, 1, 'goto inside a for(;;) loop body from inside the body');
}
# Does goto work correctly going *to* a for(;;) loop?
# (make sure it doesn't skip the initializer)
my ($z, $y) = (0);
FORL1: for ($y=1; $z;) {
ok($y, 'goto a for(;;) loop, from outside (does initializer)');
goto TEST19}
($y,$z) = (0, 1);
goto FORL1;
# Even from within the loop?
TEST19: $z = 0;
FORL2: for($y=1; 1;) {
if ($z) {
ok($y, 'goto a for(;;) loop, from inside (does initializer)');
last;
}
($y, $z) = (0, 1);
goto FORL2;
}
# Does goto work correctly within a try block?
# (BUG ID 20000313.004) - [perl #2359]
$ok = 0;
eval {
my $variable = 1;
goto LABEL20;
LABEL20: $ok = 1 if $variable;
};
ok($ok, 'works correctly within a try block');
is($@, "", '...and $@ not set');
# And within an eval-string?
$ok = 0;
eval q{
my $variable = 1;
goto LABEL21;
LABEL21: $ok = 1 if $variable;
};
ok($ok, 'works correctly within an eval string');
is($@, "", '...and $@ still not set');
# Test that goto works in nested eval-string
$ok = 0;
{eval q{
eval q{
goto LABEL22;
};
$ok = 0;
last;
LABEL22: $ok = 1;
};
$ok = 0 if $@;
}
ok($ok, 'works correctly in a nested eval string');
{
my $false = 0;
my $count;
$ok = 0;
{ goto A; A: $ok = 1 } continue { }
ok($ok, '#20357 goto inside /{ } continue { }/ loop');
$ok = 0;
{ do { goto A; A: $ok = 1 } while $false }
ok($ok, '#20154 goto inside /do { } while ()/ loop');
$ok = 0;
foreach(1) { goto A; A: $ok = 1 } continue { };
ok($ok, 'goto inside /foreach () { } continue { }/ loop');
$ok = 0;
sub a {
A: { if ($false) { redo A; B: $ok = 1; redo A; } }
goto B unless $count++;
}
a();
ok($ok, '#19061 loop label wiped away by goto');
$ok = 0;
my $p;
for ($p=1;$p && goto A;$p=0) { A: $ok = 1 }
ok($ok, 'weird case of goto and for(;;) loop');
}
# bug #9990 - don't prematurely free the CV we're &going to.
sub f1 {
my $x;
goto sub { $x=0; ok(1,"don't prematurely free CV\n") }
}
f1();
# bug #22181 - this used to coredump or make $x undefined, due to
# erroneous popping of the inner BLOCK context
undef $ok;
for ($count=0; $count<2; $count++) {
my $x = 1;
goto LABEL29;
LABEL29:
$ok = $x;
}
is($ok, 1, 'goto in for(;;) with continuation');
# bug #22299 - goto in require doesn't find label
open my $f, ">goto01.pm" or die;
print $f <<'EOT';
package goto01;
goto YYY;
die;
YYY: print "OK\n";
1;
EOT
close $f;
$r = runperl(prog => 'use goto01; print qq[DONE\n]');
is($r, "OK\nDONE\n", "goto within use-d file");
unlink "goto01.pm";
# test for [perl #24108]
$ok = 1;
$count = 0;
sub i_return_a_label {
$count++;
return "returned_label";
}
eval { goto +i_return_a_label; };
$ok = 0;
returned_label:
is($count, 1, 'called i_return_a_label');
ok($ok, 'skipped to returned_label');
# [perl #29708] - goto &foo could leave foo() at depth two with
# @_ == PL_sv_undef, causing a coredump
$r = runperl(
prog =>
'sub f { return if $d; $d=1; my $a=sub {goto &f}; &$a; f() } f(); print qq(ok\n)',
stderr => 1
);
is($r, "ok\n", 'avoid pad without an @_');
goto moretests;
fail('goto moretests');
exit;
bypass:
is(curr_test(), 5, 'eval "goto $x"');
# Test autoloading mechanism.
sub two {
my ($pack, $file, $line) = caller; # Should indicate original call stats.
is("@_ $pack $file $line", "1 2 3 main $::FILE $::LINE",
'autoloading mechanism.');
}
sub one {
eval <<'END';
no warnings 'redefine';
sub one { pass('sub one'); goto &two; fail('sub one tail'); }
END
goto &one;
}
$::FILE = __FILE__;
$::LINE = __LINE__ + 1;
&one(1,2,3);
{
my $wherever = 'NOWHERE';
eval { goto $wherever };
like($@, qr/Can't find label NOWHERE/, 'goto NOWHERE sets $@');
}
# see if a modified @_ propagates
{
my $i;
package Foo;
sub DESTROY { my $s = shift; ::is($s->[0], $i, "destroy $i"); }
sub show { ::is(+ at _, 5, "show $i",); }
sub start { push @_, 1, "foo", {}; goto &show; }
for (1..3) { $i = $_; start(bless([$_]), 'bar'); }
}
sub auto {
goto &loadit;
}
sub AUTOLOAD { $ok = 1 if "@_" eq "foo" }
$ok = 0;
auto("foo");
ok($ok, 'autoload');
{
my $wherever = 'FINALE';
goto $wherever;
}
fail('goto $wherever');
moretests:
# test goto duplicated labels.
{
my $z = 0;
eval {
$z = 0;
for (0..1) {
L4: # not outer scope
$z += 10;
last;
}
goto L4 if $z == 10;
last;
};
like($@, qr/Can't "goto" into the middle of a foreach loop/,
'catch goto middle of foreach');
$z = 0;
# ambiguous label resolution (outer scope means endless loop!)
L1:
for my $x (0..1) {
$z += 10;
is($z, 10, 'prefer same scope (loop body) to outer scope (loop entry)');
goto L1 unless $x;
$z += 10;
L1:
is($z, 10, 'prefer same scope: second');
last;
}
$z = 0;
L2:
{
$z += 10;
is($z, 10, 'prefer this scope (block body) to outer scope (block entry)');
goto L2 if $z == 10;
$z += 10;
L2:
is($z, 10, 'prefer this scope: second');
}
{
$z = 0;
while (1) {
L3: # not inner scope
$z += 10;
last;
}
is($z, 10, 'prefer this scope to inner scope');
goto L3 if $z == 10;
$z += 10;
L3: # this scope !
is($z, 10, 'prefer this scope to inner scope: second');
}
L4: # not outer scope
{
$z = 0;
while (1) {
L4: # not inner scope
$z += 1;
last;
}
is($z, 1, 'prefer this scope to inner,outer scopes');
goto L4 if $z == 1;
$z += 10;
L4: # this scope !
is($z, 1, 'prefer this scope to inner,outer scopes: second');
}
{
my $loop = 0;
for my $x (0..1) {
L2: # without this, fails 1 (middle) out of 3 iterations
$z = 0;
L2:
$z += 10;
is($z, 10,
"same label, multiple times in same scope (choose 1st) $loop");
goto L2 if $z == 10 and not $loop++;
}
}
}
# deep recursion with gotos eventually caused a stack reallocation
# which messed up buggy internals that didn't expect the stack to move
sub recurse1 {
unshift @_, "x";
no warnings 'recursion';
goto &recurse2;
}
sub recurse2 {
my $x = shift;
$_[0] ? +1 + recurse1($_[0] - 1) : 0
}
is(recurse1(500), 500, 'recursive goto &foo');
# [perl #32039] Chained goto &sub drops data too early.
sub a32039 { @_=("foo"); goto &b32039; }
sub b32039 { goto &c32039; }
sub c32039 { is($_[0], 'foo', 'chained &goto') }
a32039();
# [perl #35214] next and redo re-entered the loop with the wrong cop,
# causing a subsequent goto to crash
{
my $r = runperl(
stderr => 1,
prog =>
'for ($_=0;$_<3;$_++){A: if($_==1){next} if($_==2){$_++;goto A}}print qq(ok\n)'
);
is($r, "ok\n", 'next and goto');
$r = runperl(
stderr => 1,
prog =>
'for ($_=0;$_<3;$_++){A: if($_==1){$_++;redo} if($_==2){$_++;goto A}}print qq(ok\n)'
);
is($r, "ok\n", 'redo and goto');
}
# goto &foo not allowed in evals
sub null { 1 };
eval 'goto &null';
like($@, qr/Can't goto subroutine from an eval-string/, 'eval string');
eval { goto &null };
like($@, qr/Can't goto subroutine from an eval-block/, 'eval block');
# [perl #36521] goto &foo in warn handler could defeat recursion avoider
{
my $r = runperl(
stderr => 1,
prog => 'my $d; my $w = sub { return if $d++; warn q(bar)}; local $SIG{__WARN__} = sub { goto &$w; }; warn q(foo);'
);
like($r, qr/bar/, "goto &foo in warn");
}
--- NEW FILE: context.t ---
#!./perl
$n=0;
print "1..3\n";
sub foo {
$a='abcd';
$a=~/(.)/g;
$1 eq 'a' or print 'not ';
print "ok ",++$n,"\n";
}
$a=foo;
@a=foo;
foo;
--- NEW FILE: glob.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
print "1..10\n";
@oops = @ops = <op/*>;
if ($^O eq 'MSWin32') {
map { $files{lc($_)}++ } <op/*>;
map { delete $files{"op/$_"} } split /[\s\n]/, `dir /b /l op & dir /b /l /ah op 2>nul`,
}
elsif ($^O eq 'VMS') {
map { $files{lc($_)}++ } <[.op]*>;
map { s/;.*$//; delete $files{lc($_)}; } split /[\n]/, `directory/noheading/notrailing/versions=1 [.op]`,
}
elsif ($^O eq 'MacOS') {
@oops = @ops = <:op:*>;
map { $files{$_}++ } <:op:*>;
map { delete $files{$_} } split /[\s\n]/, `echo :op:\xc5`;
}
else {
map { $files{$_}++ } <op/*>;
map { delete $files{$_} } split /[\s\n]/, `echo op/*`;
}
if (keys %files) {
print "not ok 1\t(",join(' ', sort keys %files),"\n";
} else { print "ok 1\n"; }
print $/ eq "\n" ? "ok 2\n" : "not ok 2\n";
if ($^O eq 'MacOS') {
while (<jskdfjskdfj* :op:* jskdjfjkosvk*>) {
$not = "not " unless $_ eq shift @ops;
$not = "not at all " if $/ eq "\0";
}
} else {
while (<jskdfjskdfj* op/* jskdjfjkosvk*>) {
$not = "not " unless $_ eq shift @ops;
$not = "not at all " if $/ eq "\0";
}
}
print "${not}ok 3\n";
print $/ eq "\n" ? "ok 4\n" : "not ok 4\n";
# test the "glob" operator
$_ = $^O eq 'MacOS' ? ":op:*" : "op/*";
@glops = glob $_;
print "@glops" eq "@oops" ? "ok 5\n" : "not ok 5\n";
@glops = glob;
print "@glops" eq "@oops" ? "ok 6\n" : "not ok 6\n";
# glob should still work even after the File::Glob stash has gone away
# (this used to dump core)
my $i = 0;
for (1..2) {
eval "<.>";
undef %File::Glob::;
++$i;
}
print $i == 2 ? "ok 7\n" : "not ok 7\n";
# ... while ($var = glob(...)) should test definedness not truth
if( $INC{'File/Glob.pm'} ) {
my $ok = "not ok 8\n";
$ok = "ok 8\n" while my $var = glob("0");
print $ok;
}
else {
print "ok 8 # skip: File::Glob emulated Unixism\n";
}
# The formerly-broken test for the situation above would accidentally
# test definedness for an assignment with a LOGOP on the right:
my $f=0;
$ok="ok 9\n";
$ok="not ok 9\n", undef $f while $x = $f||$f;
print $ok;
# Better check that glob actually returned some entries
{
my $not = (scalar @oops > 0) ? '' : 'not ';
print "${not}ok 10\n";
}
--- NEW FILE: lop.t ---
#!./perl
#
# test the logical operators '&&', '||', '!', 'and', 'or', 'not'
#
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
print "1..7\n";
my $test = 0;
for my $i (undef, 0 .. 2, "", "0 but true") {
my $true = 1;
my $false = 0;
for my $j (undef, 0 .. 2, "", "0 but true") {
$true &&= !(
((!$i || !$j) != !($i && $j))
or (!($i || $j) != (!$i && !$j))
or (!!($i || $j) != !(!$i && !$j))
or (!(!$i || !$j) != !!($i && $j))
);
$false ||= (
((!$i || !$j) == !!($i && $j))
and (!!($i || $j) == (!$i && !$j))
and ((!$i || $j) == ($i && !$j))
and (($i || !$j) != (!$i && $j))
);
}
if (not $true) {
print "not ";
} elsif ($false) {
print "not ";
}
print "ok ", ++$test, "\n";
}
# $test == 6
my $i = 0;
(($i ||= 1) &&= 3) += 4;
print "not " unless $i == 7;
print "ok ", ++$test, "\n";
--- NEW FILE: caller.t ---
#!./perl
# Tests for caller()
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
plan( tests => 31 );
}
my @c;
print "# Tests with caller(0)\n";
@c = caller(0);
ok( (!@c), "caller(0) in main program" );
eval { @c = caller(0) };
is( $c[3], "(eval)", "subroutine name in an eval {}" );
ok( !$c[4], "hasargs false in an eval {}" );
eval q{ @c = (Caller(0))[3] };
is( $c[3], "(eval)", "subroutine name in an eval ''" );
ok( !$c[4], "hasargs false in an eval ''" );
sub { @c = caller(0) } -> ();
is( $c[3], "main::__ANON__", "anonymous subroutine name" );
ok( $c[4], "hasargs true with anon sub" );
# Bug 20020517.003, used to dump core
sub foo { @c = caller(0) }
my $fooref = delete $::{foo};
$fooref -> ();
is( $c[3], "(unknown)", "unknown subroutine name" );
ok( $c[4], "hasargs true with unknown sub" );
print "# Tests with caller(1)\n";
sub f { @c = caller(1) }
sub callf { f(); }
callf();
is( $c[3], "main::callf", "subroutine name" );
ok( $c[4], "hasargs true with callf()" );
&callf;
ok( !$c[4], "hasargs false with &callf" );
eval { f() };
is( $c[3], "(eval)", "subroutine name in an eval {}" );
ok( !$c[4], "hasargs false in an eval {}" );
eval q{ f() };
is( $c[3], "(eval)", "subroutine name in an eval ''" );
ok( !$c[4], "hasargs false in an eval ''" );
sub { f() } -> ();
is( $c[3], "main::__ANON__", "anonymous subroutine name" );
ok( $c[4], "hasargs true with anon sub" );
sub foo2 { f() }
my $fooref2 = delete $::{foo2};
$fooref2 -> ();
is( $c[3], "(unknown)", "unknown subroutine name" );
ok( $c[4], "hasargs true with unknown sub" );
# See if caller() returns the correct warning mask
sub testwarn {
my $w = shift;
is( (caller(0))[9], $w, "warnings");
}
# NB : extend the warning mask values below when new warnings are added
{
no warnings;
BEGIN { is( ${^WARNING_BITS}, "\0" x 12, 'warning bits' ) }
testwarn("\0" x 12);
use warnings;
BEGIN { is( ${^WARNING_BITS}, "UUUUUUUUUUU\25", 'warning bits' ) }
BEGIN { testwarn("UUUUUUUUUUU\25"); }
# run-time :
# the warning mask has been extended by warnings::register
testwarn("UUUUUUUUUUUU");
use warnings::register;
BEGIN { is( ${^WARNING_BITS}, "UUUUUUUUUUUU", 'warning bits' ) }
testwarn("UUUUUUUUUUUU");
}
# The next two cases test for a bug where caller ignored evals if
# the DB::sub glob existed but &DB::sub did not (for example, if
# $^P had been set but no debugger has been loaded). The tests
# thus assume that there is no &DB::sub: if there is one, they
# should both pass no matter whether or not this bug has been
# fixed.
my $debugger_test = q<
my @stackinfo = caller(0);
return scalar @stackinfo;
>;
sub pb { return (caller(0))[3] }
my $i = eval $debugger_test;
is( $i, 10, "do not skip over eval (and caller returns 10 elements)" );
is( eval 'pb()', 'main::pb', "actually return the right function name" );
my $saved_perldb = $^P;
$^P = 16;
$^P = $saved_perldb;
$i = eval $debugger_test;
is( $i, 10, 'do not skip over eval even if $^P had been on at some point' );
is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' );
--- NEW FILE: hashwarn.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use strict;
use warnings;
use vars qw{ @warnings };
BEGIN {
$SIG{'__WARN__'} = sub { push @warnings, @_ };
$| = 1;
print "1..9\n";
}
END { print "not ok\n# Uncaught warnings:\n at warnings\n" if @warnings }
sub test ($$;$) {
my($num, $bool, $diag) = @_;
if ($bool) {
print "ok $num\n";
return;
}
print "not ok $num\n";
return unless defined $diag;
$diag =~ s/\Z\n?/\n/; # unchomp
print map "# $num : $_", split m/^/m, $diag;
}
sub test_warning ($$$) {
my($num, $got, $expected) = @_;
my($pattern, $ok);
if (($pattern) = ($expected =~ m#^/(.+)/$#s) or
(undef, $pattern) = ($expected =~ m#^m([^\w\s])(.+)\1$#s)) {
# it's a regexp
$ok = ($got =~ /$pattern/);
test $num, $ok, "Expected pattern /$pattern/, got '$got'\n";
} else {
$ok = ($got eq $expected);
test $num, $ok, "Expected string '$expected', got '$got'\n";
}
# print "# $num: $got\n";
}
my $odd_msg = '/^Odd number of elements in hash assignment/';
my $odd_msg2 = '/^Odd number of elements in anonymous hash/';
my $ref_msg = '/^Reference found where even-sized list expected/';
{
my %hash = (1..3);
test_warning 1, shift @warnings, $odd_msg;
%hash = 1;
test_warning 2, shift @warnings, $odd_msg;
%hash = { 1..3 };
test_warning 3, shift @warnings, $odd_msg2;
test_warning 4, shift @warnings, $ref_msg;
%hash = [ 1..3 ];
test_warning 5, shift @warnings, $ref_msg;
%hash = sub { print "ok" };
test_warning 6, shift @warnings, $odd_msg;
{
# "Pseudo-hashes are deprecated" warnings tested in warnings/av
no warnings 'deprecated';
my $avhv = [{x=>1,y=>2}];
%$avhv = (x=>13,'y');
test_warning 7, shift @warnings, $odd_msg;
%$avhv = 'x';
test_warning 8, shift @warnings, $odd_msg;
$_ = { 1..10 };
test 9, ! @warnings, "Unexpected warning";
}
}
--- NEW FILE: split.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
plan tests => 55;
$FS = ':';
$_ = 'a:b:c';
($a,$b,$c) = split($FS,$_);
is(join(';',$a,$b,$c), 'a;b;c');
@ary = split(/:b:/);
is(join("$_", at ary), 'aa:b:cc');
$_ = "abc\n";
my @xyz = (@ary = split(//));
is(join(".", at ary), "a.b.c.\n");
$_ = "a:b:c::::";
@ary = split(/:/);
is(join(".", at ary), "a.b.c");
$_ = join(':',split(' '," a b\tc \t d "));
is($_, 'a:b:c:d');
$_ = join(':',split(/ */,"foo bar bie\tdoll"));
is($_ , "f:o:o:b:a:r:b:i:e:\t:d:o:l:l");
$_ = join(':', 'foo', split(/ /,'a b c'), 'bar');
is($_, "foo:a:b::c:bar");
# Can we say how many fields to split to?
$_ = join(':', split(' ','1 2 3 4 5 6', 3));
is($_, '1:2:3 4 5 6');
# Can we do it as a variable?
$x = 4;
$_ = join(':', split(' ','1 2 3 4 5 6', $x));
is($_, '1:2:3:4 5 6');
# Does the 999 suppress null field chopping?
$_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999));
is($_ , '1:2:3:4:5:6:::');
# Does assignment to a list imply split to one more field than that?
$foo = runperl( switches => ['-Dt'], stderr => 1, prog => '($a,$b)=split;' );
ok($foo =~ /DEBUGGING/ || $foo =~ /const\n?\Q(IV(3))\E/);
# Can we say how many fields to split to when assigning to a list?
($a,$b) = split(' ','1 2 3 4 5 6', 2);
$_ = join(':',$a,$b);
is($_, '1:2 3 4 5 6');
# do subpatterns generate additional fields (without trailing nulls)?
$_ = join '|', split(/,|(-)/, "1-10,20,,,");
is($_, "1|-|10||20");
# do subpatterns generate additional fields (with a limit)?
$_ = join '|', split(/,|(-)/, "1-10,20,,,", 10);
is($_, "1|-|10||20||||||");
# is the 'two undefs' bug fixed?
(undef, $a, undef, $b) = qw(1 2 3 4);
is("$a|$b", "2|4");
# .. even for locals?
{
local(undef, $a, undef, $b) = qw(1 2 3 4);
is("$a|$b", "2|4");
}
# check splitting of null string
$_ = join('|', split(/x/, '',-1), 'Z');
is($_, "Z");
$_ = join('|', split(/x/, '', 1), 'Z');
is($_, "Z");
$_ = join('|', split(/(p+)/,'',-1), 'Z');
is($_, "Z");
$_ = join('|', split(/.?/, '',-1), 'Z');
is($_, "Z");
# Are /^/m patterns scanned?
$_ = join '|', split(/^a/m, "a b a\na d a", 20);
is($_, "| b a\n| d a");
# Are /$/m patterns scanned?
$_ = join '|', split(/a$/m, "a b a\na d a", 20);
is($_, "a b |\na d |");
# Are /^/m patterns scanned?
$_ = join '|', split(/^aa/m, "aa b aa\naa d aa", 20);
is($_, "| b aa\n| d aa");
# Are /$/m patterns scanned?
$_ = join '|', split(/aa$/m, "aa b aa\naa d aa", 20);
is($_, "aa b |\naa d |");
# Greedyness:
$_ = "a : b :c: d";
@ary = split(/\s*:\s*/);
is(($res = join(".", at ary)), "a.b.c.d", $res);
# use of match result as pattern (!)
is('p:q:r:s', join ':', split('abc' =~ /b/, 'p1q1r1s'));
# /^/ treated as /^/m
$_ = join ':', split /^/, "ab\ncd\nef\n";
is($_, "ab\n:cd\n:ef\n");
# see if @a = @b = split(...) optimization works
@list1 = @list2 = split ('p',"a p b c p");
ok(@list1 == @list2 &&
"@list1" eq "@list2" &&
@list1 == 2 &&
"@list1" eq "a b c ");
# zero-width assertion
$_ = join ':', split /(?=\w)/, "rm b";
is($_, "r:m :b");
# unicode splittage
@ary = map {ord} split //, v1.20.300.4000.50000.4000.300.20.1;
is("@ary", "1 20 300 4000 50000 4000 300 20 1");
@ary = split(/\x{FE}/, "\x{FF}\x{FE}\x{FD}"); # bug id 20010105.016
ok(@ary == 2 &&
$ary[0] eq "\xFF" && $ary[1] eq "\xFD" &&
$ary[0] eq "\x{FF}" && $ary[1] eq "\x{FD}");
@ary = split(/(\x{FE}\xFE)/, "\xFF\x{FF}\xFE\x{FE}\xFD\x{FD}"); # variant of 31
ok(@ary == 3 &&
$ary[0] eq "\xFF\xFF" &&
$ary[0] eq "\x{FF}\xFF" &&
$ary[0] eq "\x{FF}\x{FF}" &&
$ary[1] eq "\xFE\xFE" &&
$ary[1] eq "\x{FE}\xFE" &&
$ary[1] eq "\x{FE}\x{FE}" &&
$ary[2] eq "\xFD\xFD" &&
$ary[2] eq "\x{FD}\xFD" &&
$ary[2] eq "\x{FD}\x{FD}");
{
my @a = map ord, split(//, join("", map chr, (1234, 123, 2345)));
is("@a", "1234 123 2345");
}
{
my $x = 'A';
my @a = map ord, split(/$x/, join("", map chr, (1234, ord($x), 2345)));
is("@a", "1234 2345");
}
{
# bug id 20000427.003
use warnings;
use strict;
my $sushi = "\x{b36c}\x{5a8c}\x{ff5b}\x{5079}\x{505b}";
my @charlist = split //, $sushi;
my $r = '';
foreach my $ch (@charlist) {
$r = $r . " " . sprintf "U+%04X", ord($ch);
}
is($r, " U+B36C U+5A8C U+FF5B U+5079 U+505B");
}
{
my $s = "\x20\x40\x{80}\x{100}\x{80}\x40\x20";
SKIP: {
if (ord('A') == 193) {
skip("EBCDIC", 1);
} else {
# bug id 20000426.003
my ($a, $b, $c) = split(/\x40/, $s);
ok($a eq "\x20" && $b eq "\x{80}\x{100}\x{80}" && $c eq $a);
}
}
my ($a, $b) = split(/\x{100}/, $s);
ok($a eq "\x20\x40\x{80}" && $b eq "\x{80}\x40\x20");
my ($a, $b) = split(/\x{80}\x{100}\x{80}/, $s);
ok($a eq "\x20\x40" && $b eq "\x40\x20");
SKIP: {
if (ord('A') == 193) {
skip("EBCDIC", 1);
} else {
my ($a, $b) = split(/\x40\x{80}/, $s);
ok($a eq "\x20" && $b eq "\x{100}\x{80}\x40\x20");
}
}
my ($a, $b, $c) = split(/[\x40\x{80}]+/, $s);
ok($a eq "\x20" && $b eq "\x{100}" && $c eq "\x20");
}
{
# 20001205.014
my $a = "ABC\x{263A}";
my @b = split( //, $a );
is(scalar @b, 4);
ok(length($b[3]) == 1 && $b[3] eq "\x{263A}");
$a =~ s/^A/Z/;
ok(length($a) == 4 && $a eq "ZBC\x{263A}");
}
{
my @a = split(/\xFE/, "\xFF\xFE\xFD");
ok(@a == 2 && $a[0] eq "\xFF" && $a[1] eq "\xFD");
}
{
# check that PMf_WHITE is cleared after \s+ is used
# reported in <20010627113312.RWGY6087.viemta06 at localhost>
my $r;
foreach my $pat ( qr/\s+/, qr/ll/ ) {
$r = join ':' => split($pat, "hello cruel world");
}
is($r, "he:o cruel world");
}
{
# split /(A)|B/, "1B2" should return (1, undef, 2)
my @x = split /(A)|B/, "1B2";
ok($x[0] eq '1' and (not defined $x[1]) and $x[2] eq '2');
}
{
# [perl #17064]
my $warn;
local $SIG{__WARN__} = sub { $warn = join '', @_; chomp $warn };
my $char = "\x{10f1ff}";
my @a = split /\r?\n/, "$char\n";
ok(@a == 1 && $a[0] eq $char && !defined($warn));
}
{
# [perl #18195]
for my $u (0, 1) {
for my $a (0, 1) {
$_ = 'readin,database,readout';
utf8::upgrade $_ if $u;
/(.+)/;
my @d = split /[,]/,$1;
is(join (':', at d), 'readin:database:readout', "[perl #18195]");
}
}
}
{
$p="a,b";
utf8::upgrade $p;
eval { @a=split(/[, ]+/,$p) };
is ("$@- at a-", '-a b-', '#20912 - split() to array with /[]+/ and utf8');
}
{
is (\@a, \@{"a"}, '@a must be global for following test');
$p="";
$n = @a = split /,/,$p;
is ($n, 0, '#21765 - pmreplroot hack used to return undef for 0 iters');
}
{
# [perl #28938]
# assigning off the end of the array after a split could leave garbage
# in the inner elements
my $x;
@a = split /,/, ',,,,,';
$a[3]=1;
$x = \$a[2];
is (ref $x, 'SCALAR', '#28938 - garbage after extend');
}
--- NEW FILE: oct.t ---
#!./perl
# tests 51 onwards aren't all warnings clean. (intentionally)
print "1..71\n";
my $test = 1;
sub test ($$$) {
my ($act, $string, $value) = @_;
my $result;
if ($act eq 'oct') {
$result = oct $string;
} elsif ($act eq 'hex') {
$result = hex $string;
} else {
die "Unknown action 'act'";
}
if ($value == $result) {
if ($^O eq 'VMS' && length $string > 256) {
$string = '';
} else {
$string = "\"$string\"";
}
print "ok $test # $act $string\n";
} else {
my ($valstr, $resstr);
if ($act eq 'hex' or $string =~ /x/) {
$valstr = sprintf "0x%X", $value;
$resstr = sprintf "0x%X", $result;
} elsif ($string =~ /b/) {
$valstr = sprintf "0b%b", $value;
$resstr = sprintf "0b%b", $result;
} else {
$valstr = sprintf "0%o", $value;
$resstr = sprintf "0%o", $result;
}
print "not ok $test # $act \"$string\" gives \"$result\" ($resstr), not $value ($valstr)\n";
}
$test++;
}
test ('oct', '0b1_0101', 0b101_01);
test ('oct', '0b10_101', 0_2_5);
test ('oct', '0b101_01', 2_1);
test ('oct', '0b1010_1', 0x1_5);
test ('oct', 'b1_0101', 0b10101);
test ('oct', 'b10_101', 025);
test ('oct', 'b101_01', 21);
test ('oct', 'b1010_1', 0x15);
test ('oct', '01_234', 0b10_1001_1100);
test ('oct', '012_34', 01234);
test ('oct', '0123_4', 668);
test ('oct', '01234', 0x29c);
test ('oct', '0x1_234', 0b10010_00110100);
test ('oct', '0x12_34', 01_1064);
test ('oct', '0x123_4', 4660);
test ('oct', '0x1234', 0x12_34);
test ('oct', 'x1_234', 0b100100011010_0);
test ('oct', 'x12_34', 0_11064);
test ('oct', 'x123_4', 4660);
test ('oct', 'x1234', 0x_1234);
test ('hex', '01_234', 0b_1001000110100);
test ('hex', '012_34', 011064);
test ('hex', '0123_4', 4660);
test ('hex', '01234_', 0x1234);
test ('hex', '0x_1234', 0b1001000110100);
test ('hex', '0x1_234', 011064);
test ('hex', '0x12_34', 4660);
test ('hex', '0x1234_', 0x1234);
test ('hex', 'x_1234', 0b1001000110100);
test ('hex', 'x12_34', 011064);
test ('hex', 'x123_4', 4660);
test ('hex', 'x1234_', 0x1234);
test ('oct', '0b1111_1111_1111_1111_1111_1111_1111_1111', 4294967295);
test ('oct', '037_777_777_777', 4294967295);
test ('oct', '0xffff_ffff', 4294967295);
test ('hex', '0xff_ff_ff_ff', 4294967295);
$_ = "\0_7_7";
print length eq 5 ? "ok" : "not ok", " 37\n";
print $_ eq "\0"."_"."7"."_"."7" ? "ok" : "not ok", " 38\n";
chop, chop, chop, chop;
print $_ eq "\0" ? "ok" : "not ok", " 39\n";
if (ord("\t") != 9) {
# question mark is 111 in 1047, 037, && POSIX-BC
print "\157_" eq "?_" ? "ok" : "not ok", " 40\n";
}
else {
print "\077_" eq "?_" ? "ok" : "not ok", " 40\n";
}
$_ = "\x_7_7";
print length eq 5 ? "ok" : "not ok", " 41\n";
print $_ eq "\0"."_"."7"."_"."7" ? "ok" : "not ok", " 42\n";
chop, chop, chop, chop;
print $_ eq "\0" ? "ok" : "not ok", " 43\n";
if (ord("\t") != 9) {
# / is 97 in 1047, 037, && POSIX-BC
print "\x61_" eq "/_" ? "ok" : "not ok", " 44\n";
}
else {
print "\x2F_" eq "/_" ? "ok" : "not ok", " 44\n";
}
$test = 45;
test ('oct', '0b'.( '0'x10).'1_0101', 0b101_01);
test ('oct', '0b'.( '0'x100).'1_0101', 0b101_01);
test ('oct', '0b'.('0'x1000).'1_0101', 0b101_01);
test ('hex', ( '0'x10).'01234', 0x1234);
test ('hex', ( '0'x100).'01234', 0x1234);
test ('hex', ('0'x1000).'01234', 0x1234);
# Things that perl 5.6.1 and 5.7.2 did wrong (plus some they got right)
test ('oct', "b00b0101", 0);
test ('oct', "bb0101", 0);
test ('oct', "0bb0101", 0);
test ('oct', "0x0x3A", 0);
test ('oct', "0xx3A", 0);
test ('oct', "x0x3A", 0);
test ('oct', "xx3A", 0);
test ('oct', "0x3A", 0x3A);
test ('oct', "x3A", 0x3A);
test ('oct', "0x0x4", 0);
test ('oct', "0xx4", 0);
test ('oct', "x0x4", 0);
test ('oct', "xx4", 0);
test ('oct', "0x4", 4);
test ('oct', "x4", 4);
test ('hex', "0x3A", 0x3A);
test ('hex', "x3A", 0x3A);
test ('hex', "0x4", 4);
test ('hex', "x4", 4);
eval '$a = oct "10\x{100}"';
print $@ =~ /Wide character/ ? "ok $test\n" : "not ok $test\n"; $test++;
eval '$a = hex "ab\x{100}"';
print $@ =~ /Wide character/ ? "ok $test\n" : "not ok $test\n"; $test++;
--- NEW FILE: append.t ---
#!./perl
# $RCSfile: append.t,v $$Revision: 1.2 $$Date: 2006-12-04 17:01:59 $
print "1..13\n";
$a = 'ab' . 'c'; # compile time
$b = 'def';
$c = $a . $b;
print "#1\t:$c: eq :abcdef:\n";
if ($c eq 'abcdef') {print "ok 1\n";} else {print "not ok 1\n";}
$c .= 'xyz';
print "#2\t:$c: eq :abcdefxyz:\n";
if ($c eq 'abcdefxyz') {print "ok 2\n";} else {print "not ok 2\n";}
$_ = $a;
$_ .= $b;
print "#3\t:$_: eq :abcdef:\n";
if ($_ eq 'abcdef') {print "ok 3\n";} else {print "not ok 3\n";}
# test that when right argument of concat is UTF8, and is the same
# variable as the target, and the left argument is not UTF8, it no
# longer frees the wrong string.
{
sub r2 {
my $string = '';
$string .= pack("U0a*", 'mnopqrstuvwx');
$string = "abcdefghijkl$string";
}
r2() and print "ok $_\n" for qw/ 4 5 /;
}
# test that nul bytes get copied
{
my ($a, $ab) = ("a", "a\0b");
my ($ua, $uab) = map pack("U0a*", $_), $a, $ab;
my $ub = pack("U0a*", 'b');
my $t1 = $a; $t1 .= $ab;
print $t1 =~ /b/ ? "ok 6\n" : "not ok 6\t# $t1\n";
my $t2 = $a; $t2 .= $uab;
print eval '$t2 =~ /$ub/' ? "ok 7\n" : "not ok 7\t# $t2\n";
my $t3 = $ua; $t3 .= $ab;
print $t3 =~ /$ub/ ? "ok 8\n" : "not ok 8\t# $t3\n";
my $t4 = $ua; $t4 .= $uab;
print eval '$t4 =~ /$ub/' ? "ok 9\n" : "not ok 9\t# $t4\n";
my $t5 = $a; $t5 = $ab . $t5;
print $t5 =~ /$ub/ ? "ok 10\n" : "not ok 10\t# $t5\n";
my $t6 = $a; $t6 = $uab . $t6;
print eval '$t6 =~ /$ub/' ? "ok 11\n" : "not ok 11\t# $t6\n";
my $t7 = $ua; $t7 = $ab . $t7;
print $t7 =~ /$ub/ ? "ok 12\n" : "not ok 12\t# $t7\n";
my $t8 = $ua; $t8 = $uab . $t8;
print eval '$t8 =~ /$ub/' ? "ok 13\n" : "not ok 13\t# $t8\n";
}
--- NEW FILE: magic.t ---
#!./perl
BEGIN {
$| = 1;
chdir 't' if -d 't';
@INC = '../lib';
$SIG{__WARN__} = sub { die "Dying on warning: ", @_ };
}
use warnings;
use Config;
my $test = 1;
sub ok {
my($ok, $info, $todo) = @_;
# You have to do it this way or VMS will get confused.
printf "%s $test%s\n", $ok ? "ok" : "not ok",
$todo ? " # TODO $todo" : '';
unless( $ok ) {
printf "# Failed test at line %d\n", (caller)[2];
print "# $info\n" if defined $info;
}
$test++;
return $ok;
}
sub skip {
my($reason) = @_;
printf "ok $test # skipped%s\n", defined $reason ? ": $reason" : '';
$test++;
return 1;
}
print "1..58\n";
$Is_MSWin32 = $^O eq 'MSWin32';
$Is_NetWare = $^O eq 'NetWare';
$Is_VMS = $^O eq 'VMS';
$Is_Dos = $^O eq 'dos';
$Is_os2 = $^O eq 'os2';
$Is_Cygwin = $^O eq 'cygwin';
$Is_MacOS = $^O eq 'MacOS';
$Is_MPE = $^O eq 'mpeix';
$Is_miniperl = $ENV{PERL_CORE_MINITEST};
$Is_BeOS = $^O eq 'beos';
$PERL = $ENV{PERL}
|| ($Is_NetWare ? 'perl' :
($Is_MacOS || $Is_VMS) ? $^X :
$Is_MSWin32 ? '.\perl' :
'./perl');
eval '$ENV{"FOO"} = "hi there";'; # check that ENV is inited inside eval
# cmd.exe will echo 'variable=value' but 4nt will echo just the value
# -- Nikola Knezevic
if ($Is_MSWin32) { ok `set FOO` =~ /^(?:FOO=)?hi there$/; }
elsif ($Is_MacOS) { ok "1 # skipped", 1; }
elsif ($Is_VMS) { ok `write sys\$output f\$trnlnm("FOO")` eq "hi there\n"; }
else { ok `echo \$FOO` eq "hi there\n"; }
unlink 'ajslkdfpqjsjfk';
$! = 0;
open(FOO,'ajslkdfpqjsjfk');
ok $!, $!;
close FOO; # just mention it, squelch used-only-once
if ($Is_MSWin32 || $Is_NetWare || $Is_Dos || $Is_MPE || $Is_MacOS) {
skip('SIGINT not safe on this platform') for 1..4;
}
else {
# the next tests are done in a subprocess because sh spits out a
# newline onto stderr when a child process kills itself with SIGINT.
# We use a pipe rather than system() because the VMS command buffer
# would overflow with a command that long.
open( CMDPIPE, "| $PERL");
print CMDPIPE <<'END';
$| = 1; # command buffering
$SIG{"INT"} = "ok3"; kill "INT",$$; sleep 1;
$SIG{"INT"} = "IGNORE"; kill "INT",$$; sleep 1; print "ok 4\n";
$SIG{"INT"} = "DEFAULT"; kill "INT",$$; sleep 1; print "not ok 4\n";
sub ok3 {
if (($x = pop(@_)) eq "INT") {
print "ok 3\n";
}
else {
print "not ok 3 ($x @_)\n";
}
}
END
close CMDPIPE;
open( CMDPIPE, "| $PERL");
print CMDPIPE <<'END';
{ package X;
sub DESTROY {
kill "INT",$$;
}
}
sub x {
my $x=bless [], 'X';
return sub { $x };
}
$| = 1; # command buffering
$SIG{"INT"} = "ok5";
{
local $SIG{"INT"}=x();
print ""; # Needed to expose failure in 5.8.0 (why?)
}
sleep 1;
delete $SIG{"INT"};
kill "INT",$$; sleep 1;
sub ok5 {
print "ok 5\n";
}
END
close CMDPIPE;
$? >>= 8 if $^O eq 'VMS'; # POSIX status hiding in 2nd byte
my $todo = ($^O eq 'os2' ? ' # TODO: EMX v0.9d_fix4 bug: wrong nibble? ' : '');
print $? & 0xFF ? "ok 6$todo\n" : "not ok 6$todo\n";
$test += 4;
}
# can we slice ENV?
@val1 = @ENV{keys(%ENV)};
@val2 = values(%ENV);
ok join(':', at val1) eq join(':', at val2);
ok @val1 > 1;
# regex vars
'foobarbaz' =~ /b(a)r/;
ok $` eq 'foo', $`;
ok $& eq 'bar', $&;
ok $' eq 'baz', $';
ok $+ eq 'a', $+;
# $"
@a = qw(foo bar baz);
ok "@a" eq "foo bar baz", "@a";
{
local $" = ',';
ok "@a" eq "foo,bar,baz", "@a";
}
# $;
%h = ();
$h{'foo', 'bar'} = 1;
ok((keys %h)[0] eq "foo\034bar", (keys %h)[0]);
{
local $; = 'x';
%h = ();
$h{'foo', 'bar'} = 1;
ok((keys %h)[0] eq 'fooxbar', (keys %h)[0]);
}
# $?, $@, $$
if ($Is_MacOS) {
skip('$? + system are broken on MacPerl') for 1..2;
}
else {
system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(0)"];
ok $? == 0, $?;
system qq[$PERL "-I../lib" -e "use vmsish qw(hushed); exit(1)"];
ok $? != 0, $?;
}
eval { die "foo\n" };
ok $@ eq "foo\n", $@;
ok $$ > 0, $$;
eval { $$++ };
ok $@ =~ /^Modification of a read-only value attempted/;
# $^X and $0
{
if ($^O eq 'qnx') {
chomp($wd = `/usr/bin/fullpath -t`);
}
elsif($Is_Cygwin || $Config{'d_procselfexe'}) {
# Cygwin turns the symlink into the real file
chomp($wd = `pwd`);
$wd =~ s#/t$##;
}
elsif($Is_os2) {
$wd = Cwd::sys_cwd();
}
elsif($Is_MacOS) {
$wd = ':';
}
else {
$wd = '.';
}
my $perl = ($Is_MacOS || $Is_VMS) ? $^X : "$wd/perl";
my $headmaybe = '';
my $tailmaybe = '';
$script = "$wd/show-shebang";
if ($Is_MSWin32) {
chomp($wd = `cd`);
$wd =~ s|\\|/|g;
$perl = "$wd/perl.exe";
$script = "$wd/show-shebang.bat";
$headmaybe = <<EOH ;
\@rem ='
\@echo off
$perl -x \%0
goto endofperl
\@rem ';
EOH
$tailmaybe = <<EOT ;
__END__
:endofperl
EOT
}
elsif ($Is_os2) {
$script = "./show-shebang";
}
elsif ($Is_MacOS) {
$script = ":show-shebang";
}
elsif ($Is_VMS) {
$script = "[]show-shebang";
}
if ($^O eq 'os390' or $^O eq 'posix-bc' or $^O eq 'vmesa') { # no shebang
$headmaybe = <<EOH ;
eval 'exec ./perl -S \$0 \${1+"\$\@"}'
if 0;
EOH
}
$s1 = "\$^X is $perl, \$0 is $script\n";
ok open(SCRIPT, ">$script"), $!;
ok print(SCRIPT $headmaybe . <<EOB . <<'EOF' . $tailmaybe), $!;
#!$wd/perl
EOB
print "\$^X is $^X, \$0 is $0\n";
EOF
ok close(SCRIPT), $!;
ok chmod(0755, $script), $!;
$_ = ($Is_MacOS || $Is_VMS) ? `$perl $script` : `$script`;
s/\.exe//i if $Is_Dos or $Is_Cygwin or $Is_os2;
s{./$script}{$script} if $Is_BeOS; # revert BeOS execvp() side-effect
s{\bminiperl\b}{perl}; # so that test doesn't fail with miniperl
s{is perl}{is $perl}; # for systems where $^X is only a basename
s{\\}{/}g;
ok((($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1:");
$_ = `$perl $script`;
s/\.exe//i if $Is_Dos or $Is_os2;
s{./$perl}{$perl} if $Is_BeOS; # revert BeOS execvp() side-effect
s{\\}{/}g;
ok((($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1: after `$perl $script`");
ok unlink($script), $!;
}
# $], $^O, $^T
ok $] >= 5.00319, $];
ok $^O;
ok $^T > 850000000, $^T;
# Test change 25062 is working
my $orig_osname = $^O;
{
local $^I = '.bak';
ok($^O eq $orig_osname, 'Assigning $^I does not clobber $^O');
}
$^O = $orig_osname;
if ($Is_VMS || $Is_Dos || $Is_MacOS) {
skip("%ENV manipulations fail or aren't safe on $^O") for 1..4;
}
else {
if ($ENV{PERL_VALGRIND}) {
skip("clearing \%ENV is not safe when running under valgrind");
} else {
$PATH = $ENV{PATH};
$PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0;
$ENV{foo} = "bar";
%ENV = ();
$ENV{PATH} = $PATH;
$ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0;
ok ($Is_MSWin32 ? (`set foo 2>NUL` eq "")
: (`echo \$foo` eq "\n") );
}
$ENV{__NoNeSuCh} = "foo";
$0 = "bar";
# cmd.exe will echo 'variable=value' but 4nt will echo just the value
# -- Nikola Knezevic
ok ($Is_MSWin32 ? (`set __NoNeSuCh` =~ /^(?:__NoNeSuCh=)?foo$/)
: (`echo \$__NoNeSuCh` eq "foo\n") );
if ($^O =~ /^(linux|freebsd)$/ &&
open CMDLINE, "/proc/$$/cmdline") {
chomp(my $line = scalar <CMDLINE>);
my $me = (split /\0/, $line)[0];
ok($me eq $0, 'altering $0 is effective (testing with /proc/)');
close CMDLINE;
# perlbug #22811
my $mydollarzero = sub {
my($arg) = shift;
$0 = $arg if defined $arg;
# In FreeBSD the ps -o command= will cause
# an empty header line, grab only the last line.
my $ps = (`ps -o command= -p $$`)[-1];
return if $?;
chomp $ps;
printf "# 0[%s]ps[%s]\n", $0, $ps;
$ps;
};
my $ps = $mydollarzero->("x");
ok(!$ps # we allow that something goes wrong with the ps command
# In Linux 2.4 we would get an exact match ($ps eq 'x') but
# in Linux 2.2 there seems to be something funny going on:
# it seems as if the original length of the argv[] would
# be stored in the proc struct and then used by ps(1),
# no matter what characters we use to pad the argv[].
# (And if we use \0:s, they are shown as spaces.) Sigh.
|| $ps =~ /^x\s*$/
# FreeBSD cannot get rid of both the leading "perl :"
# and the trailing " (perl)": some FreeBSD versions
# can get rid of the first one.
|| ($^O eq 'freebsd' && $ps =~ m/^(?:perl: )?x(?: \(perl\))?$/),
'altering $0 is effective (testing with `ps`)');
} else {
skip("\$0 check only on Linux and FreeBSD") for 0, 1;
}
}
{
my $ok = 1;
my $warn = '';
local $SIG{'__WARN__'} = sub { $ok = 0; $warn = join '', @_; };
$! = undef;
ok($ok, $warn, $Is_VMS ? "'\$!=undef' does throw a warning" : '');
}
# test case-insignificance of %ENV (these tests must be enabled only
# when perl is compiled with -DENV_IS_CASELESS)
if ($Is_MSWin32 || $Is_NetWare) {
%ENV = ();
$ENV{'Foo'} = 'bar';
$ENV{'fOo'} = 'baz';
ok (scalar(keys(%ENV)) == 1);
ok exists($ENV{'FOo'});
ok (delete($ENV{'foO'}) eq 'baz');
ok (scalar(keys(%ENV)) == 0);
}
else {
skip('no caseless %ENV support') for 1..4;
}
if ($Is_miniperl) {
skip ("miniperl can't rely on loading %Errno") for 1..2;
} else {
no warnings 'void';
# Make sure Errno hasn't been prematurely autoloaded
ok !keys %Errno::;
# Test auto-loading of Errno when %! is used
ok scalar eval q{
%!;
defined %Errno::;
}, $@;
}
if ($Is_miniperl) {
skip ("miniperl can't rely on loading %Errno");
} else {
# Make sure that Errno loading doesn't clobber $!
undef %Errno::;
delete $INC{"Errno.pm"};
open(FOO, "nonesuch"); # Generate ENOENT
my %errs = %{"!"}; # Cause Errno.pm to be loaded at run-time
ok ${"!"}{ENOENT};
}
ok $^S == 0 && defined $^S;
eval { ok $^S == 1 };
eval " BEGIN { ok ! defined \$^S } ";
ok $^S == 0 && defined $^S;
ok ${^TAINT} == 0;
eval { ${^TAINT} = 1 };
ok ${^TAINT} == 0;
# 5.6.1 had a bug: @+ and @- were not properly interpolated
# into double-quoted strings
# 20020414 mjd-perl-patch+ at plover.com
"I like pie" =~ /(I) (like) (pie)/;
ok "@-" eq "0 0 2 7";
ok "@+" eq "10 1 6 10";
# Tests for the magic get of $\
{
my $ok = 0;
# [perl #19330]
{
local $\ = undef;
$\++; $\++;
$ok = $\ eq 2;
}
ok $ok;
$ok = 0;
{
local $\ = "a\0b";
$ok = "a$\b" eq "aa\0bb";
}
ok $ok;
}
# Test for bug [perl #27839]
{
my $x;
sub f {
"abc" =~ /(.)./;
$x = "@+";
return @+;
};
my @y = f();
ok( $x eq "@y", "return a magic array ($x) vs (@y)" );
}
# Test for bug [perl #36434]
if (!$Is_VMS) {
local @ISA;
local %ENV;
eval { push @ISA, __PACKAGE__ };
ok( $@ eq '', 'Push a constant on a magic array');
$@ and print "# $@";
eval { %ENV = (PATH => __PACKAGE__) };
ok( $@ eq '', 'Assign a constant to a magic hash');
$@ and print "# $@";
eval { my %h = qw(A B); %ENV = (PATH => (keys %h)[0]) };
ok( $@ eq '', 'Assign a shared key to a magic hash');
$@ and print "# $@";
}
else {
# Can not do this test on VMS, EPOC, and SYMBIAN according to comments
# in mg.c/Perl_magic_clear_all_env()
#
skip('Can\'t make assignment to \%ENV on this system') for 1..3;
}
--- NEW FILE: vec.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
}
require "test.pl";
plan( tests => 31 );
my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
is(vec($foo,0,1), 0);
is(length($foo), 0);
vec($foo,0,1) = 1;
is(length($foo), 1);
is(unpack('C',$foo), 1);
is(vec($foo,0,1), 1);
is(vec($foo,20,1), 0);
vec($foo,20,1) = 1;
is(vec($foo,20,1), 1);
is(length($foo), 3);
is(vec($foo,1,8), 0);
vec($foo,1,8) = 0xf1;
is(vec($foo,1,8), 0xf1);
is((unpack('C',substr($foo,1,1)) & 255), 0xf1);
is(vec($foo,2,4), 1);;
is(vec($foo,3,4), 15);
vec($Vec, 0, 32) = 0xbaddacab;
is($Vec, "\xba\xdd\xac\xab");
is(vec($Vec, 0, 32), 3135089835);
# ensure vec() handles numericalness correctly
$foo = $bar = $baz = 0;
vec($foo = 0,0,1) = 1;
vec($bar = 0,1,1) = 1;
$baz = $foo | $bar;
ok($foo eq "1" && $foo == 1);
ok($bar eq "2" && $bar == 2);
ok("$foo $bar $baz" eq "1 2 3");
# error cases
$x = eval { vec $foo, 0, 3 };
like($@, /^Illegal number of bits in vec/);
$@ = undef;
$x = eval { vec $foo, 0, 0 };
like($@, /^Illegal number of bits in vec/);
$@ = undef;
$x = eval { vec $foo, 0, -13 };
like($@, /^Illegal number of bits in vec/);
$@ = undef;
$x = eval { vec($foo, -1, 4) = 2 };
like($@, /^Illegal number of bits in vec/);
$@ = undef;
ok(! vec('abcd', 7, 8));
# UTF8
# N.B. currently curiously coded to circumvent bugs elswhere in UTF8 handling
$foo = "\x{100}" . "\xff\xfe";
$x = substr $foo, 1;
is(vec($x, 0, 8), 255);
$@ = undef;
eval { vec($foo, 1, 8) };
ok(! $@);
$@ = undef;
eval { vec($foo, 1, 8) = 13 };
ok(! $@);
if ($Is_EBCDIC) {
is($foo, "\x8c\x0d\xff\x8a\x69");
}
else {
is($foo, "\xc4\x0d\xc3\xbf\xc3\xbe");
}
$foo = "\x{100}" . "\xff\xfe";
$x = substr $foo, 1;
vec($x, 2, 4) = 7;
is($x, "\xff\xf7");
# mixed magic
$foo = "\x61\x62\x63\x64\x65\x66";
is(vec(substr($foo, 2, 2), 0, 16), 25444);
vec(substr($foo, 1,3), 5, 4) = 3;
is($foo, "\x61\x62\x63\x34\x65\x66");
# A variation of [perl #20933]
{
my $s = "";
vec($s, 0, 1) = 0;
vec($s, 1, 1) = 1;
my @r;
$r[$_] = \ vec $s, $_, 1 for (0, 1);
ok(!(${ $r[0] } != 0 || ${ $r[1] } != 1));
}
--- NEW FILE: regexp_noamp.t ---
#!./perl
$skip_amp = 1;
for $file ('./op/regexp.t', './t/op/regexp.t', ':op:regexp.t') {
if (-r $file) {
do $file;
exit;
}
}
die "Cannot find ./op/regexp.t or ./t/op/regexp.t\n";
--- NEW FILE: ver.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
$SIG{'__WARN__'} = sub { warn $_[0] if $DOWARN };
}
$DOWARN = 1; # enable run-time warnings now
use Config;
require "test.pl";
plan( tests => 53 );
eval 'use v5.5.640';
is( $@, '', "use v5.5.640; $@");
require_ok('v5.5.640');
# printing characters should work
if (ord("\t") == 9) { # ASCII
is('ok ',v111.107.32,'ASCII printing characters');
# hash keys too
$h{v111.107} = "ok";
is('ok',$h{v111.107},'ASCII hash keys');
}
else { # EBCDIC
is('ok ',v150.146.64,'EBCDIC printing characters');
# hash keys too
$h{v150.146} = "ok";
is('ok',$h{v150.146},'EBCDIC hash keys');
}
# poetry optimization should also
sub v77 { "ok" }
$x = v77;
is('ok',$x,'poetry optimization');
# but not when dots are involved
if (ord("\t") == 9) { # ASCII
$x = v77.78.79;
}
else {
$x = v212.213.214;
}
is($x, 'MNO','poetry optimization with dots');
is(v1.20.300.4000, "\x{1}\x{14}\x{12c}\x{fa0}",'compare embedded \x{} string');
#
# now do the same without the "v"
eval 'use 5.5.640';
is( $@, '', "use 5.5.640; $@");
require_ok('5.5.640');
# hash keys too
if (ord("\t") == 9) { # ASCII
$h{111.107.32} = "ok";
}
else {
$h{150.146.64} = "ok";
}
is('ok',$h{ok },'hash keys w/o v');
if (ord("\t") == 9) { # ASCII
$x = 77.78.79;
}
else {
$x = 212.213.214;
}
is($x, 'MNO','poetry optimization with dots w/o v');
is(1.20.300.4000, "\x{1}\x{14}\x{12c}\x{fa0}",'compare embedded \x{} string w/o v');
# test sprintf("%vd"...) etc
if (ord("\t") == 9) { # ASCII
is(sprintf("%vd", "Perl"), '80.101.114.108', 'ASCII sprintf("%vd", "Perl")');
}
else {
is(sprintf("%vd", "Perl"), '215.133.153.147', 'EBCDIC sprintf("%vd", "Perl")');
}
is(sprintf("%vd", v1.22.333.4444), '1.22.333.4444', 'sprintf("%vd", v1.22.333.4444)');
if (ord("\t") == 9) { # ASCII
is(sprintf("%vx", "Perl"), '50.65.72.6c', 'ASCII sprintf("%vx", "Perl")');
}
else {
is(sprintf("%vx", "Perl"), 'd7.85.99.93', 'EBCDIC sprintf("%vx", "Perl")');
}
is(sprintf("%vX", 1.22.333.4444), '1.16.14D.115C','ASCII sprintf("%vX", 1.22.333.4444)');
if (ord("\t") == 9) { # ASCII
is(sprintf("%#*vo", ":", "Perl"), '0120:0145:0162:0154', 'ASCII sprintf("%vo", "Perl")');
}
else {
is(sprintf("%#*vo", ":", "Perl"), '0327:0205:0231:0223', 'EBCDIC sprintf("%vo", "Perl")');
}
is(sprintf("%*vb", "##", v1.22.333.4444),
'1##10110##101001101##1000101011100', 'sprintf("%vb", 1.22.333.4444)');
is(sprintf("%vd", join("", map { chr }
unpack 'U*', pack('U*',2001,2002,2003))),
'2001.2002.2003','unpack/pack U*');
{
use bytes;
if (ord("\t") == 9) { # ASCII
is(sprintf("%vd", "Perl"), '80.101.114.108', 'ASCII sprintf("%vd", "Perl") w/use bytes');
}
else {
is(sprintf("%vd", "Perl"), '215.133.153.147', 'EBCDIC sprintf("%vd", "Perl") w/use bytes');
}
if (ord("\t") == 9) { # ASCII
is(sprintf("%vd", 1.22.333.4444), '1.22.197.141.225.133.156', 'ASCII sprintf("%vd", v1.22.333.4444 w/use bytes');
}
else {
is(sprintf("%vd", 1.22.333.4444), '1.22.142.84.187.81.112', 'EBCDIC sprintf("%vd", v1.22.333.4444 w/use bytes');
}
if (ord("\t") == 9) { # ASCII
is(sprintf("%vx", "Perl"), '50.65.72.6c', 'ASCII sprintf("%vx", "Perl")');
}
else {
is(sprintf("%vx", "Perl"), 'd7.85.99.93', 'EBCDIC sprintf("%vx", "Perl")');
}
if (ord("\t") == 9) { # ASCII
is(sprintf("%vX", v1.22.333.4444), '1.16.C5.8D.E1.85.9C', 'ASCII sprintf("%vX", v1.22.333.4444)');
}
else {
is(sprintf("%vX", v1.22.333.4444), '1.16.8E.54.BB.51.70', 'EBCDIC sprintf("%vX", v1.22.333.4444)');
}
if (ord("\t") == 9) { # ASCII
is(sprintf("%#*vo", ":", "Perl"), '0120:0145:0162:0154', 'ASCII sprintf("%#*vo", ":", "Perl")');
}
else {
is(sprintf("%#*vo", ":", "Perl"), '0327:0205:0231:0223', 'EBCDIC sprintf("%#*vo", ":", "Perl")');
}
if (ord("\t") == 9) { # ASCII
is(sprintf("%*vb", "##", v1.22.333.4444),
'1##10110##11000101##10001101##11100001##10000101##10011100',
'ASCII sprintf("%*vb", "##", v1.22.333.4444)');
}
else {
is(sprintf("%*vb", "##", v1.22.333.4444),
'1##10110##10001110##1010100##10111011##1010001##1110000',
'EBCDIC sprintf("%*vb", "##", v1.22.333.4444)');
}
}
{
# bug id 20000323.056
is( "\x{41}", +v65, 'bug id 20000323.056');
is( "\x41", +v65, 'bug id 20000323.056');
is( "\x{c8}", +v200, 'bug id 20000323.056');
is( "\xc8", +v200, 'bug id 20000323.056');
is( "\x{221b}", +v8731, 'bug id 20000323.056');
}
# See if the things Camel-III says are true: 29..33
# Chapter 2 pp67/68
my $vs = v1.20.300.4000;
is($vs,"\x{1}\x{14}\x{12c}\x{fa0}","v-string ne \\x{}");
is($vs,chr(1).chr(20).chr(300).chr(4000),"v-string ne chr()");
is('foo',((chr(193) eq 'A') ? v134.150.150 : v102.111.111),"v-string ne ''");
# Chapter 15, pp403
# See if sane addr and gethostbyaddr() work
eval { require Socket; gethostbyaddr(v127.0.0.1, &Socket::AF_INET) };
if ($@) {
# No - so do not test insane fails.
$@ =~ s/\n/\n# /g;
}
SKIP: {
skip("No Socket::AF_INET # $@") if $@;
my $ip = v2004.148.0.1;
my $host;
eval { $host = gethostbyaddr($ip,&Socket::AF_INET) };
like($@, qr/Wide character/, "Non-bytes leak to gethostbyaddr");
}
# Chapter 28, pp671
ok(v5.6.0 lt v5.7.0, "v5.6.0 lt v5.7.0");
# part of 20000323.059
is(v200, chr(200), "v200 eq chr(200)" );
is(v200, +v200, "v200 eq +v200" );
is(v200, eval( "v200"), 'v200 eq "v200"' );
is(v200, eval("+v200"), 'v200 eq eval("+v200")' );
# Tests for string/numeric value of $] itself
my ($revision,$version,$subversion) = split '\.', sprintf("%vd",$^V);
print "# revision = '$revision'\n";
print "# version = '$version'\n";
print "# subversion = '$subversion'\n";
my $v = sprintf("%d.%.3d%.3d",$revision,$version,$subversion);
print "# v = '$v'\n";
print "# ] = '$]'\n";
$v =~ s/000$// if $subversion == 0;
print "# v = '$v'\n";
ok( $v eq "$]", qq{\$^V eq "\$]"});
$v = $revision + $version/1000 + $subversion/1000000;
ok( $v == $], "\$^V == \$] (numeric)" );
SKIP: {
skip("In EBCDIC the v-string components cannot exceed 2147483647", 6)
if ord "A" == 193;
# [ID 20010902.001] check if v-strings handle full UV range or not
if ( $Config{'uvsize'} >= 4 ) {
is( sprintf("%vd", eval 'v2147483647.2147483648'), '2147483647.2147483648', 'v-string > IV_MAX[32-bit]' );
is( sprintf("%vd", eval 'v3141592653'), '3141592653', 'IV_MAX < v-string < UV_MAX[32-bit]');
is( sprintf("%vd", eval 'v4294967295'), '4294967295', 'v-string == UV_MAX[32-bit] - 1');
}
SKIP: {
skip("No quads", 3) if $Config{uvsize} < 8;
if ( $Config{'uvsize'} >= 8 ) {
is( sprintf("%vd", eval 'v9223372036854775807.9223372036854775808'), '9223372036854775807.9223372036854775808', 'v-string > IV_MAX[64-bit]' );
is( sprintf("%vd", eval 'v17446744073709551615'), '17446744073709551615', 'IV_MAX < v-string < UV_MAX[64-bit]');
is( sprintf("%vd", eval 'v18446744073709551615'), '18446744073709551615', 'v-string == UV_MAX[64-bit] - 1');
}
}
}
# Tests for magic v-strings
$v = 1.2.3;
is( ref(\$v), 'SCALAR', 'v-strings are just scalars' );
$v = v1.2_3;
is( ref(\$v), 'SCALAR', 'v-strings with v are just scalars' );
is( sprintf("%vd", $v), '1.23', 'v-string ignores underscores' );
# [perl #16010]
%h = (v65 => 42);
ok( exists $h{v65}, "v-stringness is not engaged for vX" );
%h = (v65.66 => 42);
ok( exists $h{chr(65).chr(66)}, "v-stringness is engaged for vX.Y" );
%h = (65.66.67 => 42);
ok( exists $h{chr(65).chr(66).chr(67)}, "v-stringness is engaged for X.Y.Z" );
--- NEW FILE: lc.t ---
#!./perl
BEGIN {
chdir 't';
@INC = '../lib';
require './test.pl';
}
plan tests => 59;
$a = "HELLO.* world";
$b = "hello.* WORLD";
is("\Q$a\E." , "HELLO\\.\\*\\ world.", '\Q\E HELLO.* world');
is("\u$a" , "HELLO\.\* world", '\u');
is("\l$a" , "hELLO\.\* world", '\l');
is("\U$a" , "HELLO\.\* WORLD", '\U');
is("\L$a" , "hello\.\* world", '\L');
is(quotemeta($a) , "HELLO\\.\\*\\ world", 'quotemeta');
is(ucfirst($a) , "HELLO\.\* world", 'ucfirst');
is(lcfirst($a) , "hELLO\.\* world", 'lcfirst');
is(uc($a) , "HELLO\.\* WORLD", 'uc');
is(lc($a) , "hello\.\* world", 'lc');
is("\Q$b\E." , "hello\\.\\*\\ WORLD.", '\Q\E hello.* WORLD');
is("\u$b" , "Hello\.\* WORLD", '\u');
is("\l$b" , "hello\.\* WORLD", '\l');
is("\U$b" , "HELLO\.\* WORLD", '\U');
is("\L$b" , "hello\.\* world", '\L');
is(quotemeta($b) , "hello\\.\\*\\ WORLD", 'quotemeta');
is(ucfirst($b) , "Hello\.\* WORLD", 'ucfirst');
is(lcfirst($b) , "hello\.\* WORLD", 'lcfirst');
is(uc($b) , "HELLO\.\* WORLD", 'uc');
is(lc($b) , "hello\.\* world", 'lc');
# \x{100} is LATIN CAPITAL LETTER A WITH MACRON; its bijective lowercase is
# \x{101}, LATIN SMALL LETTER A WITH MACRON.
$a = "\x{100}\x{101}Aa";
$b = "\x{101}\x{100}aA";
is("\Q$a\E." , "\x{100}\x{101}Aa.", '\Q\E \x{100}\x{101}Aa');
is("\u$a" , "\x{100}\x{101}Aa", '\u');
is("\l$a" , "\x{101}\x{101}Aa", '\l');
is("\U$a" , "\x{100}\x{100}AA", '\U');
is("\L$a" , "\x{101}\x{101}aa", '\L');
is(quotemeta($a) , "\x{100}\x{101}Aa", 'quotemeta');
is(ucfirst($a) , "\x{100}\x{101}Aa", 'ucfirst');
is(lcfirst($a) , "\x{101}\x{101}Aa", 'lcfirst');
is(uc($a) , "\x{100}\x{100}AA", 'uc');
is(lc($a) , "\x{101}\x{101}aa", 'lc');
is("\Q$b\E." , "\x{101}\x{100}aA.", '\Q\E \x{101}\x{100}aA');
is("\u$b" , "\x{100}\x{100}aA", '\u');
is("\l$b" , "\x{101}\x{100}aA", '\l');
is("\U$b" , "\x{100}\x{100}AA", '\U');
is("\L$b" , "\x{101}\x{101}aa", '\L');
is(quotemeta($b) , "\x{101}\x{100}aA", 'quotemeta');
is(ucfirst($b) , "\x{100}\x{100}aA", 'ucfirst');
is(lcfirst($b) , "\x{101}\x{100}aA", 'lcfirst');
is(uc($b) , "\x{100}\x{100}AA", 'uc');
is(lc($b) , "\x{101}\x{101}aa", 'lc');
# \x{DF} is LATIN SMALL LETTER SHARP S, its uppercase is SS or \x{53}\x{53};
# \x{149} is LATIN SMALL LETTER N PRECEDED BY APOSTROPHE, its uppercase is
# \x{2BC}\x{E4} or MODIFIER LETTER APOSTROPHE and N.
# In EBCDIC \x{DF} is LATIN SMALL LETTER Y WITH DIAERESIS,
# and it's uppercase is \x{178}, LATIN CAPITAL LETTER Y WITH DIAERESIS.
if (ord("A") == 193) { # EBCDIC
is("\U\x{DF}aB\x{149}cD" , "\x{178}AB\x{2BC}NCD",
"multicharacter uppercase");
} elsif (ord("A") == 65) {
is("\U\x{DF}aB\x{149}cD" , "SSAB\x{2BC}NCD",
"multicharacter uppercase");
} else {
fail("what is your encoding?");
}
# The \x{DF} is its own lowercase, ditto for \x{149}.
# There are no single character -> multiple characters lowercase mappings.
if (ord("A") == 193) { # EBCDIC
is("\LaB\x{149}cD" , "ab\x{149}cd",
"multicharacter lowercase");
} elsif (ord("A") == 65) {
is("\L\x{DF}aB\x{149}cD" , "\x{DF}ab\x{149}cd",
"multicharacter lowercase");
} else {
fail("what is your encoding?");
}
# titlecase is used for \u / ucfirst.
# \x{587} is ARMENIAN SMALL LIGATURE ECH YIWN and its titlecase is
# \x{535}\x{582} ARMENIAN CAPITAL LETTER ECH + ARMENIAN SMALL LETTER YIWN
# while its lowercase is
# \x{587} itself
# and its uppercase is
# \x{535}\x{552} ARMENIAN CAPITAL LETTER ECH + ARMENIAN CAPITAL LETTER YIWN
$a = "\x{587}";
is("\L\x{587}" , "\x{587}", "ligature lowercase");
is("\u\x{587}" , "\x{535}\x{582}", "ligature titlecase");
is("\U\x{587}" , "\x{535}\x{552}", "ligature uppercase");
# mktables had problems where many-to-one case mappings didn't work right.
# The lib/uni/fold.t should give the fourth folding, "casefolding", a good
# workout (one cannot directly get that from Perl).
# \x{01C4} is LATIN CAPITAL LETTER DZ WITH CARON
# \x{01C5} is LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON
# \x{01C6} is LATIN SMALL LETTER DZ WITH CARON
# \x{03A3} is GREEK CAPITAL LETTER SIGMA
# \x{03C2} is GREEK SMALL LETTER FINAL SIGMA
# \x{03C3} is GREEK SMALL LETTER SIGMA
is(lc("\x{1C4}") , "\x{1C6}", "U+01C4 lc is U+01C6");
is(lc("\x{1C5}") , "\x{1C6}", "U+01C5 lc is U+01C6, too");
is(ucfirst("\x{3C2}") , "\x{3A3}", "U+03C2 ucfirst is U+03A3");
is(ucfirst("\x{3C3}") , "\x{3A3}", "U+03C3 ucfirst is U+03A3, too");
is(uc("\x{1C5}") , "\x{1C4}", "U+01C5 uc is U+01C4");
is(uc("\x{1C6}") , "\x{1C4}", "U+01C6 uc is U+01C4, too");
# #18107: A host of bugs involving [ul]c{,first}. AMS 20021106
$a = "\x{3c3}foo.bar"; # \x{3c3} == GREEK SMALL LETTER SIGMA.
$b = "\x{3a3}FOO.BAR"; # \x{3a3} == GREEK CAPITAL LETTER SIGMA.
($c = $b) =~ s/(\w+)/lc($1)/ge;
is($c , $a, "Using s///e to change case.");
($c = $a) =~ s/(\w+)/uc($1)/ge;
is($c , $b, "Using s///e to change case.");
($c = $b) =~ s/(\w+)/lcfirst($1)/ge;
is($c , "\x{3c3}FOO.bAR", "Using s///e to change case.");
($c = $a) =~ s/(\w+)/ucfirst($1)/ge;
is($c , "\x{3a3}foo.Bar", "Using s///e to change case.");
# #18931: perl5.8.0 bug in \U..\E processing
# Test case from Nicholas Clark.
for my $a (0,1) {
$_ = 'abcdefgh';
$_ .= chr 256;
chop;
/(.*)/;
is(uc($1), "ABCDEFGH", "[perl #18931]");
}
{
foreach (0, 1) {
$a = v10.v257;
chop $a;
$a =~ s/^(\s*)(\w*)/$1\u$2/;
is($a, v10, "[perl #18857]");
}
}
--- NEW FILE: readdir.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
eval 'opendir(NOSUCH, "no/such/directory");';
if ($@) { print "1..0\n"; exit; }
print "1..11\n";
for $i (1..2000) {
local *OP;
opendir(OP, "op") or die "can't opendir: $!";
# should auto-closedir() here
}
if (opendir(OP, "op")) { print "ok 1\n"; } else { print "not ok 1\n"; }
@D = grep(/^[^\.].*\.t$/i, readdir(OP));
closedir(OP);
##
## This range will have to adjust as the number of tests expands,
## as it's counting the number of .t files in src/t
##
my ($min, $max) = (125, 145);
if (@D > $min && @D < $max) { print "ok 2\n"; }
else {
printf "not ok 2 # counting op/*.t, expect $min < %d < $max files\n",
scalar @D;
}
@R = sort @D;
@G = sort <op/*.t>;
@G = sort <:op:*.t> if $^O eq 'MacOS';
if ($G[0] =~ m#.*\](\w+\.t)#i) {
# grep is to convert filespecs returned from glob under VMS to format
# identical to that returned by readdir
@G = grep(s#.*\](\w+\.t).*#op/$1#i,<op/*.t>);
}
while (@R && @G && $G[0] eq ($^O eq 'MacOS' ? ':op:' : 'op/').$R[0]) {
shift(@R);
shift(@G);
}
if (@R == 0 && @G == 0) { print "ok 3\n"; } else { print "not ok 3\n"; }
if (opendir($fh, "op")) { print "ok 4\n"; } else { print "not ok 4\n"; }
if (ref($fh) eq 'GLOB') { print "ok 5\n"; } else { print "not ok 5\n"; }
if (opendir($fh[0], "op")) { print "ok 6\n"; } else { print "not ok 6\n"; }
if (ref($fh[0]) eq 'GLOB') { print "ok 7\n"; } else { print "not ok 7\n"; }
if (opendir($fh{abc}, "op")) { print "ok 8\n"; } else { print "not ok 8\n"; }
if (ref($fh{abc}) eq 'GLOB') { print "ok 9\n"; } else { print "not ok 9\n"; }
if ("$fh" ne "$fh[0]") { print "ok 10\n"; } else { print "not ok 10\n"; }
if ("$fh" ne "$fh{abc}") { print "ok 11\n"; } else { print "not ok 11\n"; }
--- NEW FILE: reverse.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
print "1..4\n";
print "not " unless reverse("abc") eq "cba";
print "ok 1\n";
$_ = "foobar";
print "not " unless reverse() eq "raboof";
print "ok 2\n";
{
my @a = ("foo", "bar");
my @b = reverse @a;
print "not " unless $b[0] eq $a[1] && $b[1] eq $a[0];
print "ok 3\n";
}
{
# Unicode.
my $a = "\x{263A}\x{263A}x\x{263A}y\x{263A}";
my $b = scalar reverse($a);
my $c = scalar reverse($b);
print "not " unless $a eq $c;
print "ok 4\n";
}
--- NEW FILE: pack.t ---
#!./perl
# FIXME - why isn't this -w clean in maint?
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
# This is truth in an if statement, and could be a skip message
my $no_endianness = $] > 5.009 ? '' :
"Endianness pack modifiers not available on this perl";
my $no_signedness = $] > 5.009 ? '' :
"Signed/unsigned pack modifiers not available on this perl";
plan tests => 13864;
use strict;
# use warnings;
[...1491 lines suppressed...]
# U0 and C0 must be scoped
my (@x) = unpack("a(U0)U", "b\341\277\274");
is($x[0], 'b', 'before scope');
is($x[1], 225, 'after scope');
}
{
# counted length prefixes shouldn't change C0/U0 mode
# (note the length is actually 0 in this test)
is(join(',', unpack("aC/UU", "b\0\341\277\274")), 'b,225');
is(join(',', unpack("aC/CU", "b\0\341\277\274")), 'b,225');
is(join(',', unpack("aU0C/UU", "b\0\341\277\274")), 'b,8188');
is(join(',', unpack("aU0C/CU", "b\0\341\277\274")), 'b,8188');
}
{
# "Z0" (bug #34062)
my (@x) = unpack("C*", pack("CZ0", 1, "b"));
is(join(',', @x), '1', 'pack Z0 doesn\'t destroy the character before');
}
--- NEW FILE: unshift.t ---
#!./perl
# $RCSfile: unshift.t,v $$Revision: 1.2 $$Date: 2006-12-04 17:02:07 $
print "1..2\n";
@a = (1,2,3);
$cnt1 = unshift(a,0);
if (join(' ', at a) eq '0 1 2 3') {print "ok 1\n";} else {print "not ok 1\n";}
$cnt2 = unshift(a,3,2,1);
if (join(' ', at a) eq '3 2 1 0 1 2 3') {print "ok 2\n";} else {print "not ok 2\n";}
--- NEW FILE: chr.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib); # ../lib needed for test.deparse
require "test.pl";
}
plan tests => 26;
# Note that t/op/ord.t already tests for chr() <-> ord() rountripping.
# Don't assume ASCII.
is(chr(ord("A")), "A");
is(chr( 0), "\x00");
is(chr(127), "\x7F");
is(chr(128), "\x80");
is(chr(255), "\xFF");
# is(chr(-1), undef); # Shouldn't it be?
# Check UTF-8.
sub hexes { join(" ",map{sprintf"%02x",$_}unpack("C*",chr($_[0]))) }
# The following code points are some interesting steps in UTF-8.
is(hexes( 0x100), "c4 80");
is(hexes( 0x7FF), "df bf");
is(hexes( 0x800), "e0 a0 80");
is(hexes( 0xFFF), "e0 bf bf");
is(hexes( 0x1000), "e1 80 80");
is(hexes( 0xCFFF), "ec bf bf");
is(hexes( 0xD000), "ed 80 80");
is(hexes( 0xD7FF), "ed 9f bf");
is(hexes( 0xD800), "ed a0 80"); # not strict utf-8 (surrogate area begin)
is(hexes( 0xDFFF), "ed bf bf"); # not strict utf-8 (surrogate area end)
is(hexes( 0xE000), "ee 80 80");
is(hexes( 0xFFFF), "ef bf bf");
is(hexes( 0x10000), "f0 90 80 80");
is(hexes( 0x3FFFF), "f0 bf bf bf");
is(hexes( 0x40000), "f1 80 80 80");
is(hexes( 0xFFFFF), "f3 bf bf bf");
is(hexes(0x100000), "f4 80 80 80");
is(hexes(0x10FFFF), "f4 8f bf bf"); # Unicode (4.1) last code point
is(hexes(0x110000), "f4 90 80 80");
is(hexes(0x1FFFFF), "f7 bf bf bf"); # last four byte encoding
is(hexes(0x200000), "f8 88 80 80 80");
--- NEW FILE: tiearray.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
my %seen;
package Implement;
sub TIEARRAY
{
$seen{'TIEARRAY'}++;
my ($class, at val) = @_;
return bless \@val,$class;
}
sub STORESIZE
{
$seen{'STORESIZE'}++;
my ($ob,$sz) = @_;
return $#{$ob} = $sz-1;
}
sub EXTEND
{
$seen{'EXTEND'}++;
my ($ob,$sz) = @_;
return @$ob = $sz;
}
sub FETCHSIZE
{
$seen{'FETCHSIZE'}++;
return scalar(@{$_[0]});
}
sub FETCH
{
$seen{'FETCH'}++;
my ($ob,$id) = @_;
return $ob->[$id];
}
sub STORE
{
$seen{'STORE'}++;
my ($ob,$id,$val) = @_;
$ob->[$id] = $val;
}
sub UNSHIFT
{
$seen{'UNSHIFT'}++;
my $ob = shift;
unshift(@$ob, at _);
}
sub PUSH
{
$seen{'PUSH'}++;
my $ob = shift;;
push(@$ob, at _);
}
sub CLEAR
{
$seen{'CLEAR'}++;
@{$_[0]} = ();
}
sub DESTROY
{
$seen{'DESTROY'}++;
}
sub POP
{
$seen{'POP'}++;
my ($ob) = @_;
return pop(@$ob);
}
sub SHIFT
{
$seen{'SHIFT'}++;
my ($ob) = @_;
return shift(@$ob);
}
sub SPLICE
{
$seen{'SPLICE'}++;
my $ob = shift;
my $off = @_ ? shift : 0;
my $len = @_ ? shift : @$ob-1;
return splice(@$ob,$off,$len, at _);
}
package NegIndex; # 20020220 MJD
@ISA = 'Implement';
# simulate indices -2 .. 2
my $offset = 2;
$NegIndex::NEGATIVE_INDICES = 1;
sub FETCH {
my ($ob,$id) = @_;
# print "# FETCH @_\n";
$id += $offset;
$ob->[$id];
}
sub STORE {
my ($ob,$id,$value) = @_;
# print "# STORE @_\n";
$id += $offset;
$ob->[$id] = $value;
}
sub DELETE {
my ($ob,$id) = @_;
# print "# DELETE @_\n";
$id += $offset;
delete $ob->[$id];
}
sub EXISTS {
my ($ob,$id) = @_;
# print "# EXISTS @_\n";
$id += $offset;
exists $ob->[$id];
}
package main;
print "1..61\n";
my $test = 1;
{my @ary;
{ my $ob = tie @ary,'Implement',3,2,1;
print "not " unless $ob;
print "ok ", $test++,"\n";
print "not " unless tied(@ary) == $ob;
print "ok ", $test++,"\n";
}
print "not " unless @ary == 3;
print "ok ", $test++,"\n";
print "not " unless $#ary == 2;
print "ok ", $test++,"\n";
print "not " unless join(':', at ary) eq '3:2:1';
print "ok ", $test++,"\n";
print "not " unless $seen{'FETCH'} >= 3;
print "ok ", $test++,"\n";
@ary = (1,2,3);
print "not " unless $seen{'STORE'} >= 3;
print "ok ", $test++,"\n";
print "not " unless join(':', at ary) eq '1:2:3';
print "ok ", $test++,"\n";
{my @thing = @ary;
print "not " unless join(':', at thing) eq '1:2:3';
print "ok ", $test++,"\n";
tie @thing,'Implement';
@thing = @ary;
print "not " unless join(':', at thing) eq '1:2:3';
print "ok ", $test++,"\n";
}
print "not " unless pop(@ary) == 3;
print "ok ", $test++,"\n";
print "not " unless $seen{'POP'} == 1;
print "ok ", $test++,"\n";
print "not " unless join(':', at ary) eq '1:2';
print "ok ", $test++,"\n";
push(@ary,4);
print "not " unless $seen{'PUSH'} == 1;
print "ok ", $test++,"\n";
print "not " unless join(':', at ary) eq '1:2:4';
print "ok ", $test++,"\n";
my @x = splice(@ary,1,1,7);
print "not " unless $seen{'SPLICE'} == 1;
print "ok ", $test++,"\n";
print "not " unless @x == 1;
print "ok ", $test++,"\n";
print "not " unless $x[0] == 2;
print "ok ", $test++,"\n";
print "not " unless join(':', at ary) eq '1:7:4';
print "ok ", $test++,"\n";
print "not " unless shift(@ary) == 1;
print "ok ", $test++,"\n";
print "not " unless $seen{'SHIFT'} == 1;
print "ok ", $test++,"\n";
print "not " unless join(':', at ary) eq '7:4';
print "ok ", $test++,"\n";
my $n = unshift(@ary,5,6);
print "not " unless $seen{'UNSHIFT'} == 1;
print "ok ", $test++,"\n";
print "not " unless $n == 4;
print "ok ", $test++,"\n";
print "not " unless join(':', at ary) eq '5:6:7:4';
print "ok ", $test++,"\n";
@ary = split(/:/,'1:2:3');
print "not " unless join(':', at ary) eq '1:2:3';
print "ok ", $test++,"\n";
my $t = 0;
foreach $n (@ary)
{
print "not " unless $n == ++$t;
print "ok ", $test++,"\n";
}
# (30-33) 20020303 mjd-perl-patch+ at plover.com
@ary = ();
$seen{POP} = 0;
pop @ary; # this didn't used to call POP at all
print "not " unless $seen{POP} == 1;
print "ok ", $test++,"\n";
$seen{SHIFT} = 0;
shift @ary; # this didn't used to call SHIFT at all
print "not " unless $seen{SHIFT} == 1;
print "ok ", $test++,"\n";
$seen{PUSH} = 0;
push @ary; # this didn't used to call PUSH at all
print "not " unless $seen{PUSH} == 1;
print "ok ", $test++,"\n";
$seen{UNSHIFT} = 0;
unshift @ary; # this didn't used to call UNSHIFT at all
print "not " unless $seen{UNSHIFT} == 1;
print "ok ", $test++,"\n";
@ary = qw(3 2 1);
print "not " unless join(':', at ary) eq '3:2:1';
print "ok ", $test++,"\n";
untie @ary;
}
# 20020401 mjd-perl-patch+ at plover.com
# Thanks to Dave Mitchell for the small test case and the fix
{
my @a;
sub X::TIEARRAY { bless {}, 'X' }
sub X::SPLICE {
do '/dev/null';
die;
}
tie @a, 'X';
eval { splice(@a) };
# If we survived this far.
print "ok ", $test++, "\n";
}
{ # 20020220 mjd-perl-patch+ at plover.com
my @n;
tie @n => 'NegIndex', ('A' .. 'E');
# FETCH
print "not " unless $n[0] eq 'C';
print "ok ", $test++,"\n";
print "not " unless $n[1] eq 'D';
print "ok ", $test++,"\n";
print "not " unless $n[2] eq 'E';
print "ok ", $test++,"\n";
print "not " unless $n[-1] eq 'B';
print "ok ", $test++,"\n";
print "not " unless $n[-2] eq 'A';
print "ok ", $test++,"\n";
# STORE
$n[-2] = 'a';
print "not " unless $n[-2] eq 'a';
print "ok ", $test++,"\n";
$n[-1] = 'b';
print "not " unless $n[-1] eq 'b';
print "ok ", $test++,"\n";
$n[0] = 'c';
print "not " unless $n[0] eq 'c';
print "ok ", $test++,"\n";
$n[1] = 'd';
print "not " unless $n[1] eq 'd';
print "ok ", $test++,"\n";
$n[2] = 'e';
print "not " unless $n[2] eq 'e';
print "ok ", $test++,"\n";
# DELETE and EXISTS
for (-2 .. 2) {
print exists($n[$_]) ? "ok $test\n" : "not ok $test\n";
$test++;
delete $n[$_];
print defined($n[$_]) ? "not ok $test\n" : "ok $test\n";
$test++;
print exists($n[$_]) ? "not ok $test\n" : "ok $test\n";
$test++;
}
}
print "not " unless $seen{'DESTROY'} == 3;
print "ok ", $test++,"\n";
--- NEW FILE: threads.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl'; # for which_perl() etc
$| = 1;
}
use strict;
use Config;
BEGIN {
if (!$Config{useithreads}) {
print "1..0 # Skip: no ithreads\n";
exit 0;
}
if ($ENV{PERL_CORE_MINITEST}) {
print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
exit 0;
}
plan(3);
}
use threads;
# test that we don't get:
# Attempt to free unreferenced scalar: SV 0x40173f3c
fresh_perl_is(<<'EOI', 'ok', { }, 'delete() under threads');
use threads;
threads->new(sub { my %h=(1,2); delete $h{1}})->join for 1..2;
print "ok";
EOI
#PR24660
# test that we don't get:
# Attempt to free unreferenced scalar: SV 0x814e0dc.
fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref under threads');
use threads;
use Scalar::Util;
my $data = "a";
my $obj = \$data;
my $copy = $obj;
Scalar::Util::weaken($copy);
threads->new(sub { 1 })->join for (1..1);
print "ok";
EOI
#PR24663
# test that we don't get:
# panic: magic_killbackrefs.
# Scalars leaked: 3
fresh_perl_is(<<'EOI', 'ok', { }, 'weaken ref #2 under threads');
package Foo;
sub new { bless {},shift }
package main;
use threads;
use Scalar::Util qw(weaken);
my $object = Foo->new;
my $ref = $object;
weaken $ref;
threads->new(sub { $ref = $object } )->join; # $ref = $object causes problems
print "ok";
EOI
--- NEW FILE: push.t ---
#!./perl
# $RCSfile: push.t,v $$Revision: 1.2 $$Date: 2006-12-04 17:02:04 $
@tests = split(/\n/, <<EOF);
0 3, 0 1 2, 3 4 5 6 7
0 0 a b c, , a b c 0 1 2 3 4 5 6 7
8 0 a b c, , 0 1 2 3 4 5 6 7 a b c
7 0 6.5, , 0 1 2 3 4 5 6 6.5 7
1 0 a b c d e f g h i j,, 0 a b c d e f g h i j 1 2 3 4 5 6 7
0 1 a, 0, a 1 2 3 4 5 6 7
1 6 x y z, 1 2 3 4 5 6, 0 x y z 7
0 7 x y z, 0 1 2 3 4 5 6, x y z 7
1 7 x y z, 1 2 3 4 5 6 7, 0 x y z
4, 4 5 6 7, 0 1 2 3
-4, 4 5 6 7, 0 1 2 3
EOF
print "1..", 4 + @tests, "\n";
die "blech" unless @tests;
@x = (1,2,3);
push(@x, at x);
if (join(':', at x) eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
push(@x,4);
if (join(':', at x) eq '1:2:3:1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
# test for push/pop intuiting @ on array
push(x,3);
if (join(':', at x) eq '1:2:3:1:2:3:4:3') {print "ok 3\n";} else {print "not ok 3\n";}
pop(x);
if (join(':', at x) eq '1:2:3:1:2:3:4') {print "ok 4\n";} else {print "not ok 4\n";}
$test = 5;
foreach $line (@tests) {
($list,$get,$leave) = split(/,\t*/,$line);
($pos, $len, @list) = split(' ',$list);
@get = split(' ',$get);
@leave = split(' ',$leave);
@x = (0,1,2,3,4,5,6,7);
if (defined $len) {
@got = splice(@x, $pos, $len, @list);
}
else {
@got = splice(@x, $pos);
}
if (join(':', at got) eq join(':', at get) &&
join(':', at x) eq join(':', at leave)) {
print "ok ",$test++,"\n";
}
else {
print "not ok ",$test++," got: @got == @get left: @x == @leave\n";
}
}
1; # this file is require'd by lib/tie-stdpush.t
--- NEW FILE: srand.t ---
#!./perl -w
BEGIN {
chdir "t" if -d "t";
@INC = qw(. ../lib);
}
# Test srand.
use strict;
require "test.pl";
plan(tests => 4);
# Generate a load of random numbers.
# int() avoids possible floating point error.
sub mk_rand { map int rand 10000, 1..100; }
# Check that rand() is deterministic.
srand(1138);
my @first_run = mk_rand;
srand(1138);
my @second_run = mk_rand;
ok( eq_array(\@first_run, \@second_run), 'srand(), same arg, same rands' );
# Check that different seeds provide different random numbers
srand(31337);
@first_run = mk_rand;
srand(1138);
@second_run = mk_rand;
ok( !eq_array(\@first_run, \@second_run),
'srand(), different arg, different rands' );
# Check that srand() isn't affected by $_
{
local $_ = 42;
srand();
@first_run = mk_rand;
srand(42);
@second_run = mk_rand;
ok( !eq_array(\@first_run, \@second_run),
'srand(), no arg, not affected by $_');
}
# This test checks whether Perl called srand for you.
@first_run = `$^X -le "print int rand 100 for 1..100"`;
sleep(1); # in case our srand() is too time-dependent
@second_run = `$^X -le "print int rand 100 for 1..100"`;
ok( !eq_array(\@first_run, \@second_run), 'srand() called automatically');
--- NEW FILE: localref.t ---
#!./perl
chdir 't' if -d 't';
@INC = qw(. ../lib);
require "test.pl";
plan( tests => 64 );
$aa = 1;
{ local $aa; $aa = 2; is($aa,2); }
is($aa,1);
{ local ${aa}; $aa = 3; is($aa,3); }
is($aa,1);
{ local ${"aa"}; $aa = 4; is($aa,4); }
is($aa,1);
$x = "aa";
{ local ${$x}; $aa = 5; is($aa,5); undef $x; is($aa,5); }
is($aa,1);
$x = "a";
{ local ${$x x2};$aa = 6; is($aa,6); undef $x; is($aa,6); }
is($aa,1);
$x = "aa";
{ local $$x; $aa = 7; is($aa,7); undef $x; is($aa,7); }
is($aa,1);
@aa = qw/a b/;
{ local @aa; @aa = qw/c d/; is("@aa","c d"); }
is("@aa","a b");
{ local @{aa}; @aa = qw/e f/; is("@aa","e f"); }
is("@aa","a b");
{ local @{"aa"}; @aa = qw/g h/; is("@aa","g h"); }
is("@aa","a b");
$x = "aa";
{ local @{$x}; @aa = qw/i j/; is("@aa","i j"); undef $x; is("@aa","i j"); }
is("@aa","a b");
$x = "a";
{ local @{$x x2};@aa = qw/k l/; is("@aa","k l"); undef $x; is("@aa","k l"); }
is("@aa","a b");
$x = "aa";
{ local @$x; @aa = qw/m n/; is("@aa","m n"); undef $x; is("@aa","m n"); }
is("@aa","a b");
%aa = qw/a b/;
{ local %aa; %aa = qw/c d/; is($aa{c},"d"); }
is($aa{a},"b");
{ local %{aa}; %aa = qw/e f/; is($aa{e},"f"); }
is($aa{a},"b");
{ local %{"aa"}; %aa = qw/g h/; is($aa{g},"h"); }
is($aa{a},"b");
$x = "aa";
{ local %{$x}; %aa = qw/i j/; is($aa{i},"j"); undef $x; is($aa{i},"j"); }
is($aa{a},"b");
$x = "a";
{ local %{$x x2};%aa = qw/k l/; is($aa{k},"l"); undef $x; is($aa{k},"l"); }
is($aa{a},"b");
$x = "aa";
{ local %$x; %aa = qw/m n/; is($aa{m},"n"); undef $x; is($aa{m},"n"); }
is($aa{a},"b");
sub test_err_localref () {
like($@,qr/Can't localize through a reference/,'error');
}
$x = \$aa;
my $y = \$aa;
eval { local $$x; }; test_err_localref;
eval { local ${$x}; }; test_err_localref;
eval { local $$y; }; test_err_localref;
eval { local ${$y}; }; test_err_localref;
eval { local ${\$aa}; }; test_err_localref;
eval { local ${\'aa'}; }; test_err_localref;
$x = \@aa;
$y = \@aa;
eval { local @$x; }; test_err_localref;
eval { local @{$x}; }; test_err_localref;
eval { local @$y; }; test_err_localref;
eval { local @{$y}; }; test_err_localref;
eval { local @{\@aa}; }; test_err_localref;
eval { local @{[]}; }; test_err_localref;
$x = \%aa;
$y = \%aa;
eval { local %$x; }; test_err_localref;
eval { local %{$x}; }; test_err_localref;
eval { local %$y; }; test_err_localref;
eval { local %{$y}; }; test_err_localref;
eval { local %{\%aa}; }; test_err_localref;
eval { local %{{a=>1}}; };test_err_localref;
{
# [perl #27638] when restoring a localized variable, the thing being
# freed shouldn't be visible
my $ok;
$x = 0;
sub X::DESTROY { $ok = !ref($x); }
{
local $x = \ bless {}, 'X';
1;
}
ok($ok,'old value not visible during restore');
}
--- NEW FILE: stat.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl'; # for which_perl() etc
}
use Config;
use File::Spec;
plan tests => 86;
my $Perl = which_perl();
$Is_Amiga = $^O eq 'amigaos';
$Is_Cygwin = $^O eq 'cygwin';
$Is_Darwin = $^O eq 'darwin';
$Is_Dos = $^O eq 'dos';
$Is_MacOS = $^O eq 'MacOS';
$Is_MPE = $^O eq 'mpeix';
$Is_MSWin32 = $^O eq 'MSWin32';
$Is_NetWare = $^O eq 'NetWare';
$Is_OS2 = $^O eq 'os2';
$Is_Solaris = $^O eq 'solaris';
$Is_VMS = $^O eq 'VMS';
$Is_DGUX = $^O eq 'dgux';
$Is_MPRAS = $^O =~ /svr4/ && -f '/etc/.relid';
$Is_Rhapsody= $^O eq 'rhapsody';
$Is_Dosish = $Is_Dos || $Is_OS2 || $Is_MSWin32 || $Is_NetWare || $Is_Cygwin;
$Is_UFS = $Is_Darwin && (() = `df -t ufs .`) == 2;
my($DEV, $INO, $MODE, $NLINK, $UID, $GID, $RDEV, $SIZE,
$ATIME, $MTIME, $CTIME, $BLKSIZE, $BLOCKS) = (0..12);
my $Curdir = File::Spec->curdir;
my $tmpfile = 'Op_stat.tmp';
my $tmpfile_link = $tmpfile.'2';
1 while unlink $tmpfile;
open(FOO, ">$tmpfile") || DIE("Can't open temp test file: $!");
close FOO;
open(FOO, ">$tmpfile") || DIE("Can't open temp test file: $!");
my($nlink, $mtime, $ctime) = (stat(FOO))[$NLINK, $MTIME, $CTIME];
SKIP: {
skip "No link count", 1 if $Is_VMS;
is($nlink, 1, 'nlink on regular file');
}
SKIP: {
skip "mtime and ctime not reliable", 2
if $Is_MSWin32 or $Is_NetWare or $Is_Cygwin or $Is_Dos or $Is_MacOS;
ok( $mtime, 'mtime' );
is( $mtime, $ctime, 'mtime == ctime' );
}
# Cygwin seems to have a 3 second granularity on its timestamps.
my $funky_FAT_timestamps = $Is_Cygwin;
sleep 3 if $funky_FAT_timestamps;
print FOO "Now is the time for all good men to come to.\n";
close(FOO);
sleep 2;
SKIP: {
unlink $tmpfile_link;
my $lnk_result = eval { link $tmpfile, $tmpfile_link };
skip "link() unimplemented", 6 if $@ =~ /unimplemented/;
is( $@, '', 'link() implemented' );
ok( $lnk_result, 'linked tmp testfile' );
ok( chmod(0644, $tmpfile), 'chmoded tmp testfile' );
my($nlink, $mtime, $ctime) = (stat($tmpfile))[$NLINK, $MTIME, $CTIME];
SKIP: {
skip "No link count", 1 if $Config{dont_use_nlink};
skip "Cygwin9X fakes hard links by copying", 1
if $Config{myuname} =~ /^cygwin_(?:9\d|me)\b/i;
is($nlink, 2, 'Link count on hard linked file' );
}
SKIP: {
my $cwd = File::Spec->rel2abs($Curdir);
skip "Solaris tmpfs has different mtime/ctime link semantics", 2
if $Is_Solaris and $cwd =~ m#^/tmp# and
$mtime && $mtime == $ctime;
skip "AFS has different mtime/ctime link semantics", 2
if $cwd =~ m#$Config{'afsroot'}/#;
skip "AmigaOS has different mtime/ctime link semantics", 2
if $Is_Amiga;
# Win32 could pass $mtime test but as FAT and NTFS have
# no ctime concept $ctime is ALWAYS == $mtime
# expect netware to be the same ...
skip "No ctime concept on this OS", 2
if $Is_MSWin32 ||
($Is_Darwin && $Is_UFS);
if( !ok($mtime, 'hard link mtime') ||
!isnt($mtime, $ctime, 'hard link ctime != mtime') ) {
print STDERR <<DIAG;
# Check if you are on a tmpfs of some sort. Building in /tmp sometimes
# has this problem. Building on the ClearCase VOBS filesystem may also
# cause this failure.
#
# Darwin's UFS doesn't have a ctime concept, and thus is expected to fail
# this test.
DIAG
}
}
}
# truncate and touch $tmpfile.
open(F, ">$tmpfile") || DIE("Can't open temp test file: $!");
ok(-z \*F, '-z on empty filehandle');
ok(! -s \*F, ' and -s');
close F;
ok(-z $tmpfile, '-z on empty file');
ok(! -s $tmpfile, ' and -s');
open(F, ">$tmpfile") || DIE("Can't open temp test file: $!");
print F "hi\n";
close F;
open(F, "<$tmpfile") || DIE("Can't open temp test file: $!");
ok(!-z *F, '-z on empty filehandle');
ok( -s *F, ' and -s');
close F;
ok(! -z $tmpfile, '-z on non-empty file');
ok(-s $tmpfile, ' and -s');
# Strip all access rights from the file.
ok( chmod(0000, $tmpfile), 'chmod 0000' );
SKIP: {
skip "-r, -w and -x have different meanings on VMS", 3 if $Is_VMS;
SKIP: {
# Going to try to switch away from root. Might not work.
my $olduid = $>;
eval { $> = 1; };
skip "Can't test -r or -w meaningfully if you're superuser", 2
if $> == 0;
SKIP: {
skip "Can't test -r meaningfully?", 1 if $Is_Dos || $Is_Cygwin;
ok(!-r $tmpfile, " -r");
}
ok(!-w $tmpfile, " -w");
# switch uid back (may not be implemented)
eval { $> = $olduid; };
}
ok(! -x $tmpfile, ' -x');
}
ok(chmod(0700,$tmpfile), 'chmod 0700');
ok(-r $tmpfile, ' -r');
ok(-w $tmpfile, ' -w');
SKIP: {
skip "-x simply determines if a file ends in an executable suffix", 1
if $Is_Dosish || $Is_MacOS;
ok(-x $tmpfile, ' -x');
}
ok( -f $tmpfile, ' -f');
ok(! -d $tmpfile, ' !-d');
# Is this portable?
ok( -d $Curdir, '-d cwd' );
ok(! -f $Curdir, '!-f cwd' );
SKIP: {
unlink($tmpfile_link);
my $symlink_rslt = eval { symlink $tmpfile, $tmpfile_link };
skip "symlink not implemented", 3 if $@ =~ /unimplemented/;
is( $@, '', 'symlink() implemented' );
ok( $symlink_rslt, 'symlink() ok' );
ok(-l $tmpfile_link, '-l');
}
ok(-o $tmpfile, '-o');
ok(-e $tmpfile, '-e');
unlink($tmpfile_link);
ok(! -e $tmpfile_link, ' -e on unlinked file');
SKIP: {
skip "No character, socket or block special files", 6
if $Is_MSWin32 || $Is_NetWare || $Is_Dos;
skip "/dev isn't available to test against", 6
unless -d '/dev' && -r '/dev' && -x '/dev';
skip "Skipping: unexpected ls output in MP-RAS", 6
if $Is_MPRAS;
my $LS = $Config{d_readlink} ? "ls -lL" : "ls -l";
my $CMD = "$LS /dev 2>/dev/null";
my $DEV = qx($CMD);
skip "$CMD failed", 6 if $DEV eq '';
my @DEV = do { my $dev; opendir($dev, "/dev") ? readdir($dev) : () };
skip "opendir failed: $!", 6 if @DEV == 0;
# /dev/stdout might be either character special or a named pipe,
# or a symlink, or a socket, depending on which OS and how are
# you running the test, so let's censor that one away.
# Similar remarks hold for stderr.
$DEV =~ s{^[cpls].+?\sstdout$}{}m;
@DEV = grep { $_ ne 'stdout' } @DEV;
$DEV =~ s{^[cpls].+?\sstderr$}{}m;
@DEV = grep { $_ ne 'stderr' } @DEV;
# /dev/printer is also naughty: in IRIX it shows up as
# Srwx-----, not srwx------.
$DEV =~ s{^.+?\sprinter$}{}m;
@DEV = grep { $_ ne 'printer' } @DEV;
# If running as root, we will see .files in the ls result,
# and readdir() will see them always. Potential for conflict,
# so let's weed them out.
$DEV =~ s{^.+?\s\..+?$}{}m;
@DEV = grep { ! m{^\..+$} } @DEV;
# Irix ls -l marks sockets with 'S' while 's' is a 'XENIX semaphore'.
if ($^O eq 'irix') {
$DEV =~ s{^S(.+?)}{s$1}mg;
}
my $try = sub {
my @c1 = eval qq[\$DEV =~ /^$_[0].*/mg];
my @c2 = eval qq[grep { $_[1] "/dev/\$_" } \@DEV];
my $c1 = scalar @c1;
my $c2 = scalar @c2;
is($c1, $c2, "ls and $_[1] agreeing on /dev ($c1 $c2)");
};
SKIP: {
skip("DG/UX ls -L broken", 3) if $Is_DGUX;
$try->('b', '-b');
$try->('c', '-c');
$try->('s', '-S');
}
ok(! -b $Curdir, '!-b cwd');
ok(! -c $Curdir, '!-c cwd');
ok(! -S $Curdir, '!-S cwd');
}
SKIP: {
my($cnt, $uid);
$cnt = $uid = 0;
# Find a set of directories that's very likely to have setuid files
# but not likely to be *all* setuid files.
my @bin = grep {-d && -r && -x} qw(/sbin /usr/sbin /bin /usr/bin);
skip "Can't find a setuid file to test with", 3 unless @bin;
for my $bin (@bin) {
opendir BIN, $bin or die "Can't opendir $bin: $!";
while (defined($_ = readdir BIN)) {
$_ = "$bin/$_";
$cnt++;
$uid++ if -u;
last if $uid && $uid < $cnt;
}
}
closedir BIN;
skip "No setuid programs", 3 if $uid == 0;
isnt($cnt, 0, 'found some programs');
isnt($uid, 0, ' found some setuid programs');
ok($uid < $cnt, " they're not all setuid");
}
# To assist in automated testing when a controlling terminal (/dev/tty)
# may not be available (at, cron rsh etc), the PERL_SKIP_TTY_TEST env var
# can be set to skip the tests that need a tty.
SKIP: {
skip "These tests require a TTY", 4 if $ENV{PERL_SKIP_TTY_TEST};
my $TTY = $Is_Rhapsody ? "/dev/ttyp0" : "/dev/tty";
SKIP: {
skip "Test uses unixisms", 2 if $Is_MSWin32 || $Is_NetWare;
skip "No TTY to test -t with", 2 unless -e $TTY;
open(TTY, $TTY) ||
warn "Can't open $TTY--run t/TEST outside of make.\n";
ok(-t TTY, '-t');
ok(-c TTY, 'tty is -c');
close(TTY);
}
ok(! -t TTY, '!-t on closed TTY filehandle');
{
local $TODO = 'STDIN not a tty when output is to pipe' if $Is_VMS;
ok(-t, '-t on STDIN');
}
}
my $Null = File::Spec->devnull;
SKIP: {
skip "No null device to test with", 1 unless -e $Null;
skip "We know Win32 thinks '$Null' is a TTY", 1 if $Is_MSWin32;
open(NULL, $Null) or DIE("Can't open $Null: $!");
ok(! -t NULL, 'null device is not a TTY');
close(NULL);
}
# These aren't strictly "stat" calls, but so what?
my $statfile = File::Spec->catfile($Curdir, 'op', 'stat.t');
ok( -T $statfile, '-T');
ok(! -B $statfile, '!-B');
SKIP: {
skip("DG/UX", 1) if $Is_DGUX;
ok(-B $Perl, '-B');
}
ok(! -T $Perl, '!-T');
open(FOO,$statfile);
SKIP: {
eval { -T FOO; };
skip "-T/B on filehandle not implemented", 15 if $@ =~ /not implemented/;
is( $@, '', '-T on filehandle causes no errors' );
ok(-T FOO, ' -T');
ok(! -B FOO, ' !-B');
$_ = <FOO>;
like($_, qr/perl/, 'after readline');
ok(-T FOO, ' still -T');
ok(! -B FOO, ' still -B');
close(FOO);
open(FOO,$statfile);
$_ = <FOO>;
like($_, qr/perl/, 'reopened and after readline');
ok(-T FOO, ' still -T');
ok(! -B FOO, ' still !-B');
ok(seek(FOO,0,0), 'after seek');
ok(-T FOO, ' still -T');
ok(! -B FOO, ' still !-B');
# It's documented this way in perlfunc *shrug*
() = <FOO>;
ok(eof FOO, 'at EOF');
ok(-T FOO, ' still -T');
ok(-B FOO, ' now -B');
}
close(FOO);
SKIP: {
skip "No null device to test with", 2 unless -e $Null;
ok(-T $Null, 'null device is -T');
ok(-B $Null, ' and -B');
}
# and now, a few parsing tests:
$_ = $tmpfile;
ok(-f, 'bare -f uses $_');
ok(-f(), ' -f() "');
unlink $tmpfile or print "# unlink failed: $!\n";
# bug id 20011101.069
my @r = \stat($Curdir);
is(scalar @r, 13, 'stat returns full 13 elements');
stat $0;
eval { lstat _ };
like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/,
'lstat _ croaks after stat' );
eval { -l _ };
like( $@, qr/^The stat preceding -l _ wasn't an lstat/,
'-l _ croaks after stat' );
lstat $0;
eval { lstat _ };
is( "$@", "", "lstat _ ok after lstat" );
eval { -l _ };
is( "$@", "", "-l _ ok after lstat" );
SKIP: {
skip "No lstat", 2 unless $Config{d_lstat};
# bug id 20020124.004
# If we have d_lstat, we should have symlink()
my $linkname = 'dolzero';
symlink $0, $linkname or die "# Can't symlink $0: $!";
lstat $linkname;
-T _;
eval { lstat _ };
like( $@, qr/^The stat preceding lstat\(\) wasn't an lstat/,
'lstat croaks after -T _' );
eval { -l _ };
like( $@, qr/^The stat preceding -l _ wasn't an lstat/,
'-l _ croaks after -T _' );
unlink $linkname or print "# unlink $linkname failed: $!\n";
}
print "# Zzz...\n";
sleep(3);
my $f = 'tstamp.tmp';
unlink $f;
ok (open(S, "> $f"), 'can create tmp file');
close S or die;
my @a = stat $f;
print "# time=$^T, stat=(@a)\n";
my @b = (-M _, -A _, -C _);
print "# -MAC=(@b)\n";
ok( (-M _) < 0, 'negative -M works');
ok( (-A _) < 0, 'negative -A works');
ok( (-C _) < 0, 'negative -C works');
ok(unlink($f), 'unlink tmp file');
{
ok(open(F, ">", $tmpfile), 'can create temp file');
close F;
chmod 0077, $tmpfile;
my @a = stat($tmpfile);
my $s1 = -s _;
-T _;
my $s2 = -s _;
is($s1, $s2, q(-T _ doesn't break the statbuffer));
unlink $tmpfile;
}
END {
1 while unlink $tmpfile;
}
--- NEW FILE: universal.t ---
#!./perl
#
# check UNIVERSAL
#
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
$| = 1;
require "./test.pl";
}
print "1..102\n";
$a = {};
bless $a, "Bob";
ok $a->isa("Bob");
package Human;
sub eat {}
package Female;
@ISA=qw(Human);
package Alice;
@ISA=qw(Bob Female);
sub sing;
sub drink { return "drinking " . $_[1] }
sub new { bless {} }
$Alice::VERSION = 2.718;
{
package Cedric;
our @ISA;
use base qw(Human);
}
{
package Programmer;
our $VERSION = 1.667;
sub write_perl { 1 }
}
package main;
$a = new Alice;
ok $a->isa("Alice");
ok $a->isa("main::Alice"); # check that alternate class names work
ok(("main::Alice"->new)->isa("Alice"));
ok $a->isa("Bob");
ok $a->isa("main::Bob");
ok $a->isa("Female");
ok $a->isa("Human");
ok ! $a->isa("Male");
ok ! $a->isa('Programmer');
ok $a->isa("HASH");
ok $a->can("eat");
ok ! $a->can("sleep");
ok my $ref = $a->can("drink"); # returns a coderef
is $a->$ref("tea"), "drinking tea"; # ... which works
ok $ref = $a->can("sing");
eval { $a->$ref() };
ok $@; # ... but not if no actual subroutine
ok (!Cedric->isa('Programmer'));
ok (Cedric->isa('Human'));
push(@Cedric::ISA,'Programmer');
ok (Cedric->isa('Programmer'));
{
package Alice;
base::->import('Programmer');
}
ok $a->isa('Programmer');
ok $a->isa("Female");
@Cedric::ISA = qw(Bob);
ok (!Cedric->isa('Programmer'));
my $b = 'abc';
my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE);
my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} );
for ($p=0; $p < @refs; $p++) {
for ($q=0; $q < @vals; $q++) {
is UNIVERSAL::isa($vals[$p], $refs[$q]), ($p==$q or $p+$q==1);
};
};
ok ! UNIVERSAL::can(23, "can");
ok $a->can("VERSION");
ok $a->can("can");
ok ! $a->can("export_tags"); # a method in Exporter
cmp_ok eval { $a->VERSION }, '==', 2.718;
ok ! (eval { $a->VERSION(2.719) });
like $@, qr/^Alice version 2.71(?:9|8999\d+) required--this is only version 2.718 at /;
ok (eval { $a->VERSION(2.718) });
is $@, '';
my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
## The test for import here is *not* because we want to ensure that UNIVERSAL
## can always import; it is an historical accident that UNIVERSAL can import.
if ('a' lt 'A') {
is $subs, "can import isa VERSION";
} else {
is $subs, "VERSION can import isa";
}
ok $a->isa("UNIVERSAL");
ok ! UNIVERSAL::isa([], "UNIVERSAL");
ok ! UNIVERSAL::can({}, "can");
ok UNIVERSAL::isa(Alice => "UNIVERSAL");
cmp_ok UNIVERSAL::can(Alice => "can"), '==', \&UNIVERSAL::can;
# now use UNIVERSAL.pm and see what changes
eval "use UNIVERSAL";
ok $a->isa("UNIVERSAL");
my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
# XXX import being here is really a bug
if ('a' lt 'A') {
is $sub2, "can import isa VERSION";
} else {
is $sub2, "VERSION can import isa";
}
eval 'sub UNIVERSAL::sleep {}';
ok $a->can("sleep");
ok ! UNIVERSAL::can($b, "can");
ok ! $a->can("export_tags"); # a method in Exporter
ok ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH');
{
package Pickup;
use UNIVERSAL qw( isa can VERSION );
::ok isa "Pickup", UNIVERSAL;
::cmp_ok can( "Pickup", "can" ), '==', \&UNIVERSAL::can;
::ok VERSION "UNIVERSAL" ;
}
{
# test isa() and can() on magic variables
"Human" =~ /(.*)/;
ok $1->isa("Human");
ok $1->can("eat");
package HumanTie;
sub TIESCALAR { bless {} }
sub FETCH { "Human" }
tie my($x), "HumanTie";
::ok $x->isa("Human");
::ok $x->can("eat");
}
# bugid 3284
# a second call to isa('UNIVERSAL') when @ISA is null failed due to caching
@X::ISA=();
my $x = {}; bless $x, 'X';
ok $x->isa('UNIVERSAL');
ok $x->isa('UNIVERSAL');
--- NEW FILE: mkdir.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
plan tests => 13;
use File::Path;
rmtree('blurfl');
# tests 3 and 7 rather naughtily expect English error messages
$ENV{'LC_ALL'} = 'C';
$ENV{LANGUAGE} = 'C'; # GNU locale extension
ok(mkdir('blurfl',0777));
ok(!mkdir('blurfl',0777));
like($!, qr/cannot move|exist|denied|unknown/i);
ok(-d 'blurfl');
ok(rmdir('blurfl'));
ok(!rmdir('blurfl'));
like($!, qr/cannot find|such|exist|not found|not a directory|unknown/i);
ok(mkdir('blurfl'));
ok(rmdir('blurfl'));
SKIP: {
# trailing slashes will be removed before the system call to mkdir
# but we don't care for MacOS ...
skip("MacOS", 4) if $^O eq 'MacOS';
ok(mkdir('blurfl///'));
ok(-d 'blurfl');
ok(rmdir('blurfl///'));
ok(!-d 'blurfl');
}
--- NEW FILE: cproto.t ---
#!./perl
# Tests to ensure that we don't unexpectedly change prototypes of builtins
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
BEGIN { require './test.pl'; }
plan tests => 234;
while (<DATA>) {
chomp;
my ($keyword, $proto) = split;
if ($proto eq 'undef') {
ok( !defined prototype "CORE::".$keyword, $keyword );
}
elsif ($proto eq 'unknown') {
eval { prototype "CORE::".$keyword };
like( $@, qr/Can't find an opnumber for/, $keyword );
}
else {
is( "(".prototype("CORE::".$keyword).")", $proto, $keyword );
}
}
# the keyword list :
__DATA__
abs (;$)
accept (**)
alarm (;$)
and ()
atan2 ($$)
bind (*$)
binmode (*;$)
bless ($;$)
caller (;$)
chdir (;$)
chmod (@)
chomp undef
chop undef
chown (@)
chr (;$)
chroot (;$)
close (;*)
closedir (*)
cmp unknown
connect (*$)
continue unknown
cos (;$)
crypt ($$)
dbmclose (\%)
dbmopen (\%$$)
defined undef
delete undef
die (@)
do undef
dump ()
each (\%)
else undef
elsif undef
endgrent ()
endhostent ()
endnetent ()
endprotoent ()
endpwent ()
endservent ()
eof (;*)
eq ($$)
err unknown
eval undef
exec undef
exists undef
exit (;$)
exp (;$)
fcntl (*$$)
fileno (*)
flock (*$)
for undef
foreach undef
fork ()
format undef
formline ($@)
ge ($$)
getc (;*)
getgrent ()
getgrgid ($)
getgrnam ($)
gethostbyaddr ($$)
gethostbyname ($)
gethostent ()
getlogin ()
getnetbyaddr ($$)
getnetbyname ($)
getnetent ()
getpeername (*)
getpgrp (;$)
getppid ()
getpriority ($$)
getprotobyname ($)
getprotobynumber ($)
getprotoent ()
getpwent ()
getpwnam ($)
getpwuid ($)
getservbyname ($$)
getservbyport ($$)
getservent ()
getsockname (*)
getsockopt (*$$)
glob undef
gmtime (;$)
goto undef
grep undef
gt ($$)
hex (;$)
if undef
index ($$;$)
int (;$)
ioctl (*$$)
join ($@)
keys (\%)
kill (@)
last undef
lc (;$)
lcfirst (;$)
le ($$)
length (;$)
link ($$)
listen (*$)
local undef
localtime (;$)
lock (\$)
log (;$)
lstat (*)
lt ($$)
m undef
map undef
mkdir ($;$)
msgctl ($$$)
msgget ($$)
msgrcv ($$$$$)
msgsnd ($$$)
my undef
ne ($$)
next undef
no undef
not ($)
oct (;$)
open (*;$@)
opendir (*$)
or ()
ord (;$)
our undef
pack ($@)
package undef
pipe (**)
pop (;\@)
pos undef
print undef
printf undef
prototype undef
push (\@@)
q undef
qq undef
qr undef
quotemeta (;$)
qw undef
qx undef
rand (;$)
read (*\$$;$)
readdir (*)
readline (;*)
readlink (;$)
readpipe unknown
recv (*\$$$)
redo undef
ref (;$)
rename ($$)
require undef
reset (;$)
return undef
reverse (@)
rewinddir (*)
rindex ($$;$)
rmdir (;$)
s undef
scalar undef
seek (*$$)
seekdir (*$)
select (;*)
semctl ($$$$)
semget ($$$)
semop ($$)
send (*$$;$)
setgrent ()
sethostent ($)
setnetent ($)
setpgrp (;$$)
setpriority ($$$)
setprotoent ($)
setpwent ()
setservent ($)
setsockopt (*$$$)
shift (;\@)
shmctl ($$$)
shmget ($$$)
shmread ($$$$)
shmwrite ($$$$)
shutdown (*$)
sin (;$)
sleep (;$)
socket (*$$$)
socketpair (**$$$)
sort undef
splice (\@;$$@)
split undef
sprintf ($@)
sqrt (;$)
srand (;$)
stat (*)
study undef
sub undef
substr ($$;$$)
symlink ($$)
syscall ($@)
sysopen (*$$;$)
sysread (*\$$;$)
sysseek (*$$)
system undef
syswrite (*$;$$)
tell (;*)
telldir (*)
tie undef
tied undef
time ()
times ()
tr undef
truncate ($$)
uc (;$)
ucfirst (;$)
umask (;$)
undef undef
unless undef
unlink (@)
unpack ($$)
unshift (\@@)
untie undef
until undef
use undef
utime (@)
values (\%)
vec ($$$)
wait ()
waitpid ($$)
wantarray ()
warn (@)
while undef
write (;*)
x unknown
xor ($$)
y undef
--- NEW FILE: sselect.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = ('.', '../lib');
}
require 'test.pl';
plan (9);
my $blank = "";
eval {select undef, $blank, $blank, 0};
is ($@, "");
eval {select $blank, undef, $blank, 0};
is ($@, "");
eval {select $blank, $blank, undef, 0};
is ($@, "");
eval {select "", $blank, $blank, 0};
is ($@, "");
eval {select $blank, "", $blank, 0};
is ($@, "");
eval {select $blank, $blank, "", 0};
is ($@, "");
eval {select "a", $blank, $blank, 0};
like ($@, qr/^Modification of a read-only value attempted/);
eval {select $blank, "a", $blank, 0};
like ($@, qr/^Modification of a read-only value attempted/);
eval {select $blank, $blank, "a", 0};
like ($@, qr/^Modification of a read-only value attempted/);
--- NEW FILE: time.t ---
#!./perl
# $RCSfile: time.t,v $$Revision: 1.2 $$Date: 2006-12-04 17:02:07 $
if ( $does_gmtime = gmtime(time) ) {
print "1..7\n"
}
else {
print "1..4\n"
}
my $test = 1;
sub ok ($$) {
my($ok, $name) = @_;
# You have to do it this way or VMS will get confused.
print $ok ? "ok $test - $name\n" : "not ok $test - $name\n";
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
$test++;
return $ok;
}
($beguser,$begsys) = times;
$beg = time;
while (($now = time) == $beg) { sleep 1 }
ok($now > $beg && $now - $beg < 10, 'very basic time test');
for ($i = 0; $i < 1_000_000; $i++) {
($nowuser, $nowsys) = times;
$i = 2_000_000 if $nowuser > $beguser && ( $nowsys >= $begsys ||
(!$nowsys && !$begsys));
last if time - $beg > 20;
}
ok($i >= 2_000_000, 'very basic times test');
($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($beg);
($xsec,$foo) = localtime($now);
$localyday = $yday;
ok($sec != $xsec && $mday && $year, 'localtime() list context');
ok(localtime() =~ /^(Sun|Mon|Tue|Wed|Thu|Fri|Sat)[ ]
(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)[ ]
([ \d]\d)\ (\d\d):(\d\d):(\d\d)\ (\d{4})$
/x,
'localtime(), scalar context'
);
exit 0 unless $does_gmtime;
($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($beg);
($xsec,$foo) = localtime($now);
ok($sec != $xsec && $mday && $year, 'gmtime() list context');
my $day_diff = $localyday - $yday;
ok( grep({ $day_diff == $_ } (0, 1, -1, 364, 365, -364, -365)),
'gmtime() and localtime() agree what day of year');
# This could be stricter.
ok(gmtime() =~ /^(Sun|Mon|Tue|Wed|Thu|Fri|Sat)[ ]
(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)[ ]
([ \d]\d)\ (\d\d):(\d\d):(\d\d)\ (\d{4})$
/x,
'gmtime(), scalar context'
);
--- NEW FILE: ord.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib); # ../lib needed for test.deparse
require "test.pl";
}
plan tests => 7;
# compile time evaluation
# 'A' 65 ASCII
# 'A' 193 EBCDIC
ok(ord('A') == 65 || ord('A') == 193, "ord('A') is ".ord('A'));
is(ord(chr(500)), 500, "compile time chr 500");
# run time evaluation
$x = 'ABC';
ok(ord($x) == 65 || ord($x) == 193, "ord('$x') is ".ord($x));
ok(chr 65 eq 'A' || chr 193 eq 'A', "chr can produce 'A'");
$x = 500;
is(ord(chr($x)), $x, "runtime chr $x");
is(ord("\x{1234}"), 0x1234, 'compile time ord \x{....}');
$x = "\x{1234}";
is(ord($x), 0x1234, 'runtime ord \x{....}');
--- NEW FILE: negate.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
plan tests => 16;
# Some of these will cause warnings if left on. Here we're checking the
# functionality, not the warnings.
no warnings "numeric";
# test cases based on [perl #36675] -'-10' eq '+10'
is(- 10, -10, "Simple numeric negation to negative");
is(- -10, 10, "Simple numeric negation to positive");
is(-"10", -10, "Negation of a positive string to negative");
is(-"10.0", -10, "Negation of a positive decimal sting to negative");
is(-"10foo", -10, "Negation of a numeric-lead string returns negation of numeric");
is(-"-10", "+10", 'Negation of string starting with "-" returns a string starting with "+" - numeric');
is(-"-10.0", "+10.0", 'Negation of string starting with "-" returns a string starting with "+" - decimal');
is(-"-10foo", "+10foo", 'Negation of string starting with "-" returns a string starting with "+" - non-numeric');
is(-"xyz", "-xyz", 'Negation of a negative string adds "-" to the front');
is(-"-xyz", "+xyz", "Negation of a negative string to positive");
is(-"+xyz", "-xyz", "Negation of a positive string to negative");
is(-bareword, "-bareword", "Negation of bareword treated like a string");
is(- -bareword, "+bareword", "Negation of -bareword returns string +bareword");
is(-" -10", 10, "Negation of a whitespace-lead numeric string");
is(-" -10.0", 10, "Negation of a whitespace-lead decimal string");
is(-" -10foo", 10, "Negation of a whitespace-lead sting starting with a numeric")
--- NEW FILE: exp.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
plan tests => 16;
# compile time evaluation
$s = sqrt(2);
is(substr($s,0,5), '1.414');
$s = exp(1);
is(substr($s,0,7), '2.71828');
cmp_ok(exp(log(1)), '==', 1);
# run time evaluation
$x1 = 1;
$x2 = 2;
$s = sqrt($x2);
is(substr($s,0,5), '1.414');
$s = exp($x1);
is(substr($s,0,7), '2.71828');
cmp_ok(exp(log($x1)), '==', 1);
# tests for transcendental functions
my $pi = 3.1415926535897931160;
my $pi_2 = 1.5707963267948965580;
sub round {
my $result = shift;
return sprintf("%.9f", $result);
}
# sin() tests
cmp_ok(sin(0), '==', 0.0);
cmp_ok(round(sin($pi)), '==', 0.0);
cmp_ok(round(sin(-1 * $pi)), '==', 0.0);
cmp_ok(round(sin($pi_2)), '==', 1.0);
cmp_ok(round(sin(-1 * $pi_2)), '==', -1.0);
# cos() tests
cmp_ok(cos(0), '==', 1.0);
cmp_ok(round(cos($pi)), '==', -1.0);
cmp_ok(round(cos(-1 * $pi)), '==', -1.0);
cmp_ok(round(cos($pi_2)), '==', 0.0);
cmp_ok(round(cos(-1 * $pi_2)), '==', 0.0);
# atan2() tests were removed due to differing results from calls to
# atan2() on various OS's and architectures. See perlport.pod for
# more information.
--- NEW FILE: hashassign.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
# use strict;
plan tests => 213;
my @comma = ("key", "value");
# The peephole optimiser already knows that it should convert the string in
# $foo{string} into a shared hash key scalar. It might be worth making the
# tokeniser build the LHS of => as a shared hash key scalar too.
# And so there's the possiblility of it going wrong
# And going right on 8 bit but wrong on utf8 keys.
# And really we should also try utf8 literals in {} and => in utf8.t
# Some of these tests are (effectively) duplicated in each.t
my %comma = @comma;
ok (keys %comma == 1, 'keys on comma hash');
ok (values %comma == 1, 'values on comma hash');
# defeat any tokeniser or optimiser cunning
my $key = 'ey';
is ($comma{"k" . $key}, "value", 'is key present? (unoptimised)');
# now with cunning:
is ($comma{key}, "value", 'is key present? (maybe optimised)');
#tokeniser may treat => differently.
my @temp = (key=>undef);
is ($comma{$temp[0]}, "value", 'is key present? (using LHS of =>)');
@temp = %comma;
ok (eq_array (\@comma, \@temp), 'list from comma hash');
@temp = each %comma;
ok (eq_array (\@comma, \@temp), 'first each from comma hash');
@temp = each %comma;
ok (eq_array ([], \@temp), 'last each from comma hash');
my %temp = %comma;
ok (keys %temp == 1, 'keys on copy of comma hash');
ok (values %temp == 1, 'values on copy of comma hash');
is ($temp{'k' . $key}, "value", 'is key present? (unoptimised)');
# now with cunning:
is ($temp{key}, "value", 'is key present? (maybe optimised)');
@temp = (key=>undef);
is ($comma{$temp[0]}, "value", 'is key present? (using LHS of =>)');
@temp = %temp;
ok (eq_array (\@temp, \@temp), 'list from copy of comma hash');
@temp = each %temp;
ok (eq_array (\@temp, \@temp), 'first each from copy of comma hash');
@temp = each %temp;
ok (eq_array ([], \@temp), 'last each from copy of comma hash');
my @arrow = (Key =>"Value");
my %arrow = @arrow;
ok (keys %arrow == 1, 'keys on arrow hash');
ok (values %arrow == 1, 'values on arrow hash');
# defeat any tokeniser or optimiser cunning
$key = 'ey';
is ($arrow{"K" . $key}, "Value", 'is key present? (unoptimised)');
# now with cunning:
is ($arrow{Key}, "Value", 'is key present? (maybe optimised)');
#tokeniser may treat => differently.
@temp = ('Key', undef);
is ($arrow{$temp[0]}, "Value", 'is key present? (using LHS of =>)');
@temp = %arrow;
ok (eq_array (\@arrow, \@temp), 'list from arrow hash');
@temp = each %arrow;
ok (eq_array (\@arrow, \@temp), 'first each from arrow hash');
@temp = each %arrow;
ok (eq_array ([], \@temp), 'last each from arrow hash');
%temp = %arrow;
ok (keys %temp == 1, 'keys on copy of arrow hash');
ok (values %temp == 1, 'values on copy of arrow hash');
is ($temp{'K' . $key}, "Value", 'is key present? (unoptimised)');
# now with cunning:
is ($temp{Key}, "Value", 'is key present? (maybe optimised)');
@temp = ('Key', undef);
is ($arrow{$temp[0]}, "Value", 'is key present? (using LHS of =>)');
@temp = %temp;
ok (eq_array (\@temp, \@temp), 'list from copy of arrow hash');
@temp = each %temp;
ok (eq_array (\@temp, \@temp), 'first each from copy of arrow hash');
@temp = each %temp;
ok (eq_array ([], \@temp), 'last each from copy of arrow hash');
my %direct = ('Camel', 2, 'Dromedary', 1);
my %slow;
$slow{Dromedary} = 1;
$slow{Camel} = 2;
ok (eq_hash (\%slow, \%direct), "direct list assignment to hash");
%direct = (Camel => 2, 'Dromedary' => 1);
ok (eq_hash (\%slow, \%direct), "direct list assignment to hash using =>");
$slow{Llama} = 0; # A llama is not a camel :-)
ok (!eq_hash (\%direct, \%slow), "different hashes should not be equal!");
my (%names, %names_copy);
%names = ('$' => 'Scalar', '@' => 'Array', # Grr '
'%', 'Hash', '&', 'Code');
%names_copy = %names;
ok (eq_hash (\%names, \%names_copy), "check we can copy our hash");
sub in {
my %args = @_;
return eq_hash (\%names, \%args);
}
ok (in (%names), "pass hash into a method");
sub in_method {
my $self = shift;
my %args = @_;
return eq_hash (\%names, \%args);
}
ok (main->in_method (%names), "pass hash into a method");
sub out {
return %names;
}
%names_copy = out ();
ok (eq_hash (\%names, \%names_copy), "pass hash from a subroutine");
sub out_method {
my $self = shift;
return %names;
}
%names_copy = main->out_method ();
ok (eq_hash (\%names, \%names_copy), "pass hash from a method");
sub in_out {
my %args = @_;
return %args;
}
%names_copy = in_out (%names);
ok (eq_hash (\%names, \%names_copy), "pass hash to and from a subroutine");
sub in_out_method {
my $self = shift;
my %args = @_;
return %args;
}
%names_copy = main->in_out_method (%names);
ok (eq_hash (\%names, \%names_copy), "pass hash to and from a method");
my %names_copy2 = %names;
ok (eq_hash (\%names, \%names_copy2), "check copy worked");
# This should get ignored.
%names_copy = ('%', 'Associative Array', %names);
ok (eq_hash (\%names, \%names_copy), "duplicates at the start of a list");
# This should not
%names_copy = ('*', 'Typeglob', %names);
$names_copy2{'*'} = 'Typeglob';
ok (eq_hash (\%names_copy, \%names_copy2), "duplicates at the end of a list");
%names_copy = ('%', 'Associative Array', '*', 'Endangered species', %names,
'*', 'Typeglob',);
ok (eq_hash (\%names_copy, \%names_copy2), "duplicates at both ends");
# And now UTF8
foreach my $chr (60, 200, 600, 6000, 60000) {
# This little game may set a UTF8 flag internally. Or it may not. :-)
my ($key, $value) = (chr ($chr) . "\x{ABCD}", "$chr\x{ABCD}");
chop ($key, $value);
my @utf8c = ($key, $value);
my %utf8c = @utf8c;
ok (keys %utf8c == 1, 'keys on utf8 comma hash');
ok (values %utf8c == 1, 'values on utf8 comma hash');
# defeat any tokeniser or optimiser cunning
is ($utf8c{"" . $key}, $value, 'is key present? (unoptimised)');
my $tempval = sprintf '$utf8c{"\x{%x}"}', $chr;
is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)");
$tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr;
eval $tempval or die "'$tempval' gave $@";
is ($utf8c{$temp[0]}, $value, 'is key present? (using LHS of $tempval)');
@temp = %utf8c;
ok (eq_array (\@utf8c, \@temp), 'list from utf8 comma hash');
@temp = each %utf8c;
ok (eq_array (\@utf8c, \@temp), 'first each from utf8 comma hash');
@temp = each %utf8c;
ok (eq_array ([], \@temp), 'last each from utf8 comma hash');
%temp = %utf8c;
ok (keys %temp == 1, 'keys on copy of utf8 comma hash');
ok (values %temp == 1, 'values on copy of utf8 comma hash');
is ($temp{"" . $key}, $value, 'is key present? (unoptimised)');
$tempval = sprintf '$temp{"\x{%x}"}', $chr;
is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)");
$tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr;
eval $tempval or die "'$tempval' gave $@";
is ($temp{$temp[0]}, $value, "is key present? (using LHS of $tempval)");
@temp = %temp;
ok (eq_array (\@temp, \@temp), 'list from copy of utf8 comma hash');
@temp = each %temp;
ok (eq_array (\@temp, \@temp), 'first each from copy of utf8 comma hash');
@temp = each %temp;
ok (eq_array ([], \@temp), 'last each from copy of utf8 comma hash');
my $assign = sprintf '("\x{%x}" => "%d")', $chr, $chr;
print "# $assign\n";
my (@utf8a) = eval $assign;
my %utf8a = @utf8a;
ok (keys %utf8a == 1, 'keys on utf8 arrow hash');
ok (values %utf8a == 1, 'values on utf8 arrow hash');
# defeat any tokeniser or optimiser cunning
is ($utf8a{$key . ""}, $value, 'is key present? (unoptimised)');
$tempval = sprintf '$utf8a{"\x{%x}"}', $chr;
is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)");
$tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr;
eval $tempval or die "'$tempval' gave $@";
is ($utf8a{$temp[0]}, $value, "is key present? (using LHS of $tempval)");
@temp = %utf8a;
ok (eq_array (\@utf8a, \@temp), 'list from utf8 arrow hash');
@temp = each %utf8a;
ok (eq_array (\@utf8a, \@temp), 'first each from utf8 arrow hash');
@temp = each %utf8a;
ok (eq_array ([], \@temp), 'last each from utf8 arrow hash');
%temp = %utf8a;
ok (keys %temp == 1, 'keys on copy of utf8 arrow hash');
ok (values %temp == 1, 'values on copy of utf8 arrow hash');
is ($temp{'' . $key}, $value, 'is key present? (unoptimised)');
$tempval = sprintf '$temp{"\x{%x}"}', $chr;
is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)");
$tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr;
eval $tempval or die "'$tempval' gave $@";
is ($temp{$temp[0]}, $value, "is key present? (using LHS of $tempval)");
@temp = %temp;
ok (eq_array (\@temp, \@temp), 'list from copy of utf8 arrow hash');
@temp = each %temp;
ok (eq_array (\@temp, \@temp), 'first each from copy of utf8 arrow hash');
@temp = each %temp;
ok (eq_array ([], \@temp), 'last each from copy of utf8 arrow hash');
}
# now some tests for hash assignment in scalar and list context with
# duplicate keys [perl #24380]
{
my %h; my $x; my $ar;
is( (join ':', %h = (1) x 8), '1:1',
'hash assignment in list context removes duplicates' );
is( scalar( %h = (1,2,1,3,1,4,1,5) ), 2,
'hash assignment in scalar context' );
is( scalar( ($x,%h) = (0,1,2,1,3,1,4,1,5) ), 3,
'scalar + hash assignment in scalar context' );
$ar = [ %h = (1,2,1,3,1,4,1,5) ];
is( $#$ar, 1, 'hash assignment in list context' );
is( "@$ar", "1 5", '...gets the last values' );
$ar = [ ($x,%h) = (0,1,2,1,3,1,4,1,5) ];
is( $#$ar, 2, 'scalar + hash assignment in list context' );
is( "@$ar", "0 1 5", '...gets the last values' );
}
--- NEW FILE: chdir.t ---
#!./perl -w
BEGIN {
# We're not going to chdir() into 't' because we don't know if
# chdir() works! Instead, we'll hedge our bets and put both
# possibilities into @INC.
@INC = qw(t . lib ../lib);
}
use Config;
require "test.pl";
plan(tests => 38);
my $IsVMS = $^O eq 'VMS';
my $IsMacOS = $^O eq 'MacOS';
# Might be a little early in the testing process to start using these,
# but I can't think of a way to write this test without them.
use File::Spec::Functions qw(:DEFAULT splitdir rel2abs splitpath);
# Can't use Cwd::abs_path() because it has different ideas about
# path separators than File::Spec.
sub abs_path {
my $d = rel2abs(curdir);
$d = uc($d) if $IsVMS;
$d = lc($d) if $^O =~ /^uwin/;
$d;
}
my $Cwd = abs_path;
# Let's get to a known position
SKIP: {
my ($vol,$dir) = splitpath(abs_path,1);
my $test_dir = $IsVMS ? 'T' : 't';
skip("Already in t/", 2) if (splitdir($dir))[-1] eq $test_dir;
ok( chdir($test_dir), 'chdir($test_dir)');
is( abs_path, catdir($Cwd, $test_dir), ' abs_path() agrees' );
}
$Cwd = abs_path;
SKIP: {
skip("no fchdir", 6) unless ($Config{d_fchdir} || "") eq "define";
ok(opendir(my $dh, "."), "opendir .");
ok(open(my $fh, "<", "op"), "open op");
ok(chdir($fh), "fchdir op");
ok(-f "chdir.t", "verify that we are in op");
if (($Config{d_dirfd} || "") eq "define") {
ok(chdir($dh), "fchdir back");
}
else {
eval { chdir($dh); };
like($@, qr/^The dirfd function is unimplemented at/, "dirfd is unimplemented");
chdir "..";
}
ok(-d "op", "verify that we are back");
}
SKIP: {
skip("has fchdir", 1) if ($Config{d_fchdir} || "") eq "define";
opendir(my $dh, "op");
eval { chdir($dh); };
like($@, qr/^The fchdir function is unimplemented at/, "fchdir is unimplemented");
}
# The environment variables chdir() pays attention to.
my @magic_envs = qw(HOME LOGDIR SYS$LOGIN);
sub check_env {
my($key) = @_;
# Make sure $ENV{'SYS$LOGIN'} is only honored on VMS.
if( $key eq 'SYS$LOGIN' && !$IsVMS && !$IsMacOS ) {
ok( !chdir(), "chdir() on $^O ignores only \$ENV{$key} set" );
is( abs_path, $Cwd, ' abs_path() did not change' );
pass( " no need to test SYS\$LOGIN on $^O" ) for 1..7;
}
else {
ok( chdir(), "chdir() w/ only \$ENV{$key} set" );
is( abs_path, $ENV{$key}, ' abs_path() agrees' );
chdir($Cwd);
is( abs_path, $Cwd, ' and back again' );
my $warning = '';
local $SIG{__WARN__} = sub { $warning .= join '', @_ };
# Check the deprecated chdir(undef) feature.
#line 64
ok( chdir(undef), "chdir(undef) w/ only \$ENV{$key} set" );
is( abs_path, $ENV{$key}, ' abs_path() agrees' );
is( $warning, <<WARNING, ' got uninit & deprecation warning' );
Use of uninitialized value in chdir at $0 line 64.
Use of chdir('') or chdir(undef) as chdir() is deprecated at $0 line 64.
WARNING
chdir($Cwd);
# Ditto chdir('').
$warning = '';
#line 76
ok( chdir(''), "chdir('') w/ only \$ENV{$key} set" );
is( abs_path, $ENV{$key}, ' abs_path() agrees' );
is( $warning, <<WARNING, ' got deprecation warning' );
Use of chdir('') or chdir(undef) as chdir() is deprecated at $0 line 76.
WARNING
chdir($Cwd);
}
}
my %Saved_Env = ();
sub clean_env {
foreach my $env (@magic_envs) {
$Saved_Env{$env} = $ENV{$env};
# Can't actually delete SYS$ stuff on VMS.
next if $IsVMS && $env eq 'SYS$LOGIN';
next if $IsVMS && $env eq 'HOME' && !$Config{'d_setenv'};
unless ($IsMacOS) { # ENV on MacOS is "special" :-)
# On VMS, %ENV is many layered.
delete $ENV{$env} while exists $ENV{$env};
}
}
# The following means we won't really be testing for non-existence,
# but in Perl we can only delete from the process table, not the job
# table.
$ENV{'SYS$LOGIN'} = '' if $IsVMS;
}
END {
no warnings 'uninitialized';
# Restore the environment for VMS (and doesn't hurt for anyone else)
@ENV{@magic_envs} = @Saved_Env{@magic_envs};
}
foreach my $key (@magic_envs) {
# We're going to be using undefs a lot here.
no warnings 'uninitialized';
clean_env;
$ENV{$key} = catdir $Cwd, ($IsVMS ? 'OP' : 'op');
check_env($key);
}
{
clean_env;
if (($IsVMS || $IsMacOS) && !$Config{'d_setenv'}) {
pass("Can't reset HOME, so chdir() test meaningless");
} else {
ok( !chdir(), 'chdir() w/o any ENV set' );
}
is( abs_path, $Cwd, ' abs_path() agrees' );
}
--- NEW FILE: attrs.t ---
#!./perl -w
# Regression tests for attributes.pm and the C< : attrs> syntax.
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
plan 'no_plan';
$SIG{__WARN__} = sub { die @_ };
sub eval_ok ($;$) {
eval shift;
is( $@, '', @_);
}
eval_ok 'sub t1 ($) : locked { $_[0]++ }';
eval_ok 'sub t2 : locked { $_[0]++ }';
eval_ok 'sub t3 ($) : locked ;';
eval_ok 'sub t4 : locked ;';
our $anon1; eval_ok '$anon1 = sub ($) : locked:method { $_[0]++ }';
our $anon2; eval_ok '$anon2 = sub : locked : method { $_[0]++ }';
our $anon3; eval_ok '$anon3 = sub : method { $_[0]->[1] }';
eval 'sub e1 ($) : plugh ;';
like $@, qr/^Invalid CODE attributes?: ["']?plugh["']? at/;
eval 'sub e2 ($) : plugh(0,0) xyzzy ;';
like $@, qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /;
eval 'sub e3 ($) : plugh(0,0 xyzzy ;';
like $@, qr/Unterminated attribute parameter in attribute list at/;
eval 'sub e4 ($) : plugh + xyzzy ;';
like $@, qr/Invalid separator character '[+]' in attribute list at/;
eval_ok 'my main $x : = 0;';
eval_ok 'my $x : = 0;';
eval_ok 'my $x ;';
eval_ok 'my ($x) : = 0;';
eval_ok 'my ($x) ;';
eval_ok 'my ($x) : ;';
eval_ok 'my ($x,$y) : = 0;';
eval_ok 'my ($x,$y) ;';
eval_ok 'my ($x,$y) : ;';
eval 'my ($x,$y) : plugh;';
like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/;
# bug #16080
eval '{my $x : plugh}';
like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/;
eval '{my ($x,$y) : plugh(})}';
like $@, qr/^Invalid SCALAR attribute: ["']?plugh\(}\)["']? at/;
# More syntax tests from the attributes manpage
eval 'my $x : switch(10,foo(7,3)) : expensive;';
like $@, qr/^Invalid SCALAR attributes: ["']?switch\(10,foo\(7,3\)\) : expensive["']? at/;
eval q/my $x : Ugly('\(") :Bad;/;
like $@, qr/^Invalid SCALAR attributes: ["']?Ugly\('\\\("\) : Bad["']? at/;
eval 'my $x : _5x5;';
like $@, qr/^Invalid SCALAR attribute: ["']?_5x5["']? at/;
eval 'my $x : locked method;';
like $@, qr/^Invalid SCALAR attributes: ["']?locked : method["']? at/;
eval 'my $x : switch(10,foo();';
like $@, qr/^Unterminated attribute parameter in attribute list at/;
eval q/my $x : Ugly('(');/;
like $@, qr/^Unterminated attribute parameter in attribute list at/;
eval 'my $x : 5x5;';
like $@, qr/error/;
eval 'my $x : Y2::north;';
like $@, qr/Invalid separator character ':' in attribute list at/;
sub A::MODIFY_SCALAR_ATTRIBUTES { return }
eval 'my A $x : plugh;';
like $@, qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/;
eval 'my A $x : plugh plover;';
like $@, qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /;
eval 'package Cat; my Cat @socks;';
like $@, qr/^Can't declare class for non-scalar \@socks in "my"/;
sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" }
sub X::foo { 1 }
*Y::bar = \&X::foo;
*Y::bar = \&X::foo; # second time for -w
eval 'package Z; sub Y::bar : foo';
like $@, qr/^X at /;
eval 'package Z; sub Y::baz : locked {}';
my @attrs = eval 'attributes::get \&Y::baz';
is "@attrs", "locked";
@attrs = eval 'attributes::get $anon1';
is "@attrs", "locked method";
sub Z::DESTROY { }
sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' }
my $thunk = eval 'bless +sub : method locked { 1 }, "Z"';
is ref($thunk), "Z";
@attrs = eval 'attributes::get $thunk';
is "@attrs", "locked method Z";
# Test attributes on predeclared subroutines:
eval 'package A; sub PS : lvalue';
@attrs = eval 'attributes::get \&A::PS';
is "@attrs", "lvalue";
# Test ability to modify existing sub's (or XSUB's) attributes.
eval 'package A; sub X { $_[0] } sub X : lvalue';
@attrs = eval 'attributes::get \&A::X';
is "@attrs", "lvalue";
# Above not with just 'pure' built-in attributes.
sub Z::MODIFY_CODE_ATTRIBUTES { (); }
eval 'package Z; sub L { $_[0] } sub L : Z lvalue';
@attrs = eval 'attributes::get \&Z::L';
is "@attrs", "lvalue Z";
# Begin testing attributes that tie
{
package Ttie;
sub DESTROY {}
sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; }
sub FETCH { ${$_[0]} }
sub STORE {
::pass;
${$_[0]} = $_[1]*2;
}
package Tloop;
sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttie', -1; (); }
}
eval_ok '
package Tloop;
for my $i (0..2) {
my $x : TieLoop = $i;
$x != $i*2 and ::is $x, $i*2;
}
';
# bug #15898
eval 'our ${""} : foo = 1';
like $@, qr/Can't declare scalar dereference in our/;
eval 'my $$foo : bar = 1';
like $@, qr/Can't declare scalar dereference in my/;
my @code = qw(lvalue locked method);
unshift @code, 'assertion' if $] >= 5.009;
my @other = qw(shared unique);
my %valid;
$valid{CODE} = {map {$_ => 1} @code};
$valid{SCALAR} = {map {$_ => 1} @other};
$valid{ARRAY} = $valid{HASH} = $valid{SCALAR};
our ($scalar, @array, %hash);
foreach my $value (\&foo, \$scalar, \@array, \%hash) {
my $type = ref $value;
foreach my $negate ('', '-') {
foreach my $attr (@code, @other) {
my $attribute = $negate . $attr;
eval "use attributes __PACKAGE__, \$value, '$attribute'";
if ($valid{$type}{$attr}) {
if ($attribute eq '-shared') {
like $@, qr/^A variable may not be unshared/;
} else {
is( $@, '', "$type attribute $attribute");
}
} else {
like $@, qr/^Invalid $type attribute: $attribute/,
"Bogus $type attribute $attribute should fail";
}
}
}
}
--- NEW FILE: sysio.t ---
#!./perl
print "1..42\n";
chdir('op') || chdir('t/op') || die "sysio.t: cannot look for myself: $!";
@INC = '../../lib';
open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!";
$reopen = ($^O eq 'VMS' ||
$^O eq 'os2' ||
$^O eq 'MSWin32' ||
$^O eq 'NetWare' ||
$^O eq 'dos' ||
$^O eq 'mpeix');
$x = 'abc';
# should not be able to do negative lengths
eval { sysread(I, $x, -1) };
print 'not ' unless ($@ =~ /^Negative length /);
print "ok 1\n";
# $x should be intact
print 'not ' unless ($x eq 'abc');
print "ok 2\n";
# should not be able to read before the buffer
eval { sysread(I, $x, 1, -4) };
print 'not ' unless ($x eq 'abc');
print "ok 3\n";
# $x should be intact
print 'not ' unless ($x eq 'abc');
print "ok 4\n";
$a ='0123456789';
# default offset 0
print 'not ' unless(sysread(I, $a, 3) == 3);
print "ok 5\n";
# $a should be as follows
print 'not ' unless ($a eq '#!.');
print "ok 6\n";
# reading past the buffer should zero pad
print 'not ' unless(sysread(I, $a, 2, 5) == 2);
print "ok 7\n";
# the zero pad should be seen now
print 'not ' unless ($a eq "#!.\0\0/p");
print "ok 8\n";
# try changing the last two characters of $a
print 'not ' unless(sysread(I, $a, 3, -2) == 3);
print "ok 9\n";
# the last two characters of $a should have changed (into three)
print 'not ' unless ($a eq "#!.\0\0erl");
print "ok 10\n";
$outfile = 'sysio.out';
open(O, ">$outfile") || die "sysio.t: cannot write $outfile: $!";
select(O); $|=1; select(STDOUT);
# cannot write negative lengths
eval { syswrite(O, $x, -1) };
print 'not ' unless ($@ =~ /^Negative length /);
print "ok 11\n";
# $x still intact
print 'not ' unless ($x eq 'abc');
print "ok 12\n";
# $outfile still intact
print 'not ' if (-s $outfile);
print "ok 13\n";
# should not be able to write from after the buffer
eval { syswrite(O, $x, 1, 3) };
print 'not ' unless ($@ =~ /^Offset outside string /);
print "ok 14\n";
# $x still intact
print 'not ' unless ($x eq 'abc');
print "ok 15\n";
# $outfile still intact
if ($reopen) { # must close file to update EOF marker for stat
close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
}
print 'not ' if (-s $outfile);
print "ok 16\n";
# should not be able to write from before the buffer
eval { syswrite(O, $x, 1, -4) };
print 'not ' unless ($@ =~ /^Offset outside string /);
print "ok 17\n";
# $x still intact
print 'not ' unless ($x eq 'abc');
print "ok 18\n";
# $outfile still intact
if ($reopen) { # must close file to update EOF marker for stat
close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
}
print 'not ' if (-s $outfile);
print "ok 19\n";
# default offset 0
if (syswrite(O, $a, 2) == 2){
print "ok 20\n";
} else {
print "# $!\nnot ok 20\n";
# most other tests make no sense after e.g. "No space left on device"
die $!;
}
# $a still intact
print 'not ' unless ($a eq "#!.\0\0erl");
print "ok 21\n";
# $outfile should have grown now
if ($reopen) { # must close file to update EOF marker for stat
close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
}
print 'not ' unless (-s $outfile == 2);
print "ok 22\n";
# with offset
print 'not ' unless (syswrite(O, $a, 2, 5) == 2);
print "ok 23\n";
# $a still intact
print 'not ' unless ($a eq "#!.\0\0erl");
print "ok 24\n";
# $outfile should have grown now
if ($reopen) { # must close file to update EOF marker for stat
close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
}
print 'not ' unless (-s $outfile == 4);
print "ok 25\n";
# with negative offset and a bit too much length
print 'not ' unless (syswrite(O, $a, 5, -3) == 3);
print "ok 26\n";
# $a still intact
print 'not ' unless ($a eq "#!.\0\0erl");
print "ok 27\n";
# $outfile should have grown now
if ($reopen) { # must close file to update EOF marker for stat
close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
}
print 'not ' unless (-s $outfile == 7);
print "ok 28\n";
# with implicit length argument
print 'not ' unless (syswrite(O, $x) == 3);
print "ok 29\n";
# $a still intact
print 'not ' unless ($x eq "abc");
print "ok 30\n";
# $outfile should have grown now
if ($reopen) { # must close file to update EOF marker for stat
close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
}
print 'not ' unless (-s $outfile == 10);
print "ok 31\n";
close(O);
open(I, $outfile) || die "sysio.t: cannot read $outfile: $!";
$b = 'xyz';
# reading too much only return as much as available
print 'not ' unless (sysread(I, $b, 100) == 10);
print "ok 32\n";
# this we should have
print 'not ' unless ($b eq '#!ererlabc');
print "ok 33\n";
# test sysseek
print 'not ' unless sysseek(I, 2, 0) == 2;
print "ok 34\n";
sysread(I, $b, 3);
print 'not ' unless $b eq 'ere';
print "ok 35\n";
print 'not ' unless sysseek(I, -2, 1) == 3;
print "ok 36\n";
sysread(I, $b, 4);
print 'not ' unless $b eq 'rerl';
print "ok 37\n";
print 'not ' unless sysseek(I, 0, 0) eq '0 but true';
print "ok 38\n";
print 'not ' if defined sysseek(I, -1, 1);
print "ok 39\n";
close(I);
unlink $outfile;
# Check that utf8 IO doesn't upgrade the scalar
open(I, ">$outfile") || die "sysio.t: cannot write $outfile: $!";
# Will skip harmlessly on stdioperl
eval {binmode STDOUT, ":utf8"};
die $@ if $@ and $@ !~ /^IO layers \(like ':utf8'\) unavailable/;
# y diaresis is \w when UTF8
$a = chr 255;
print $a =~ /\w/ ? "not ok 40\n" : "ok 40\n";
syswrite I, $a;
# Should not be upgraded as a side effect of syswrite.
print $a =~ /\w/ ? "not ok 41\n" : "ok 41\n";
# This should work
eval {syswrite I, 2;};
print $@ eq "" ? "ok 42\n" : "not ok 42 # $@";
close(I);
unlink $outfile;
chdir('..');
1;
# eof
--- NEW FILE: numconvert.t ---
#!./perl
#
# test the conversion operators
#
# Notations:
#
# "N p i N vs N N": Apply op-N, then op-p, then op-i, then reporter-N
# Compare with application of op-N, then reporter-N
# Right below are descriptions of different ops and reporters.
# We do not use these subroutines any more, sub overhead makes a "switch"
# solution better:
# obviously, 0, 1 and 2, 3 are destructive. (XXXX 64-bit? 4 destructive too)
# *0 = sub {--$_[0]}; # -
# *1 = sub {++$_[0]}; # +
# # Converters
# *2 = sub { $_[0] = $max_uv & $_[0]}; # U
# *3 = sub { use integer; $_[0] += $zero}; # I
# *4 = sub { $_[0] += $zero}; # N
# *5 = sub { $_[0] = "$_[0]" }; # P
# # Side effects
# *6 = sub { $max_uv & $_[0]}; # u
# *7 = sub { use integer; $_[0] + $zero}; # i
# *8 = sub { $_[0] + $zero}; # n
# *9 = sub { $_[0] . "" }; # p
# # Reporters
# sub a2 { sprintf "%u", $_[0] } # U
# sub a3 { sprintf "%d", $_[0] } # I
# sub a4 { sprintf "%g", $_[0] } # N
# sub a5 { "$_[0]" } # P
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use strict 'vars';
my $max_chain = $ENV{PERL_TEST_NUMCONVERTS} || 2;
# Bulk out if unsigned type is hopelessly wrong:
my $max_uv1 = ~0;
my $max_uv2 = sprintf "%u", $max_uv1 ** 6; # 6 is an arbitrary number here
my $big_iv = do {use integer; $max_uv1 * 16}; # 16 is an arbitrary number here
my $max_uv_less3 = $max_uv1 - 3;
print "# max_uv1 = $max_uv1, max_uv2 = $max_uv2, big_iv = $big_iv\n";
print "# max_uv_less3 = $max_uv_less3\n";
if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1 or $max_uv1 == $max_uv_less3) {
print "1..0 # skipped: unsigned perl arithmetic is not sane";
eval { require Config; import Config };
use vars qw(%Config);
if ($Config{d_quad} eq 'define') {
print " (common in 64-bit platforms)";
}
print "\n";
exit 0;
}
if ($max_uv_less3 =~ tr/0-9//c) {
print "1..0 # skipped: this perl stringifies large unsigned integers using E notation\n";
exit 0;
}
my $st_t = 4*4; # We try 4 initializers and 4 reporters
my $num = 0;
$num += 10**$_ - 4**$_ for 1.. $max_chain;
$num *= $st_t;
print "1..$num\n"; # In fact 15 times more subsubtests...
my $max_uv = ~0;
my $max_iv = int($max_uv/2);
my $zero = 0;
my $l_uv = length $max_uv;
my $l_iv = length $max_iv;
# Hope: the first digits are good
my $larger_than_uv = substr 97 x 100, 0, $l_uv;
my $smaller_than_iv = substr 12 x 100, 0, $l_iv;
my $yet_smaller_than_iv = substr 97 x 100, 0, ($l_iv - 1);
my @list = (1, $yet_smaller_than_iv, $smaller_than_iv, $max_iv, $max_iv + 1,
$max_uv, $max_uv + 1);
unshift @list, (reverse map -$_, @list), 0; # 15 elts
@list = map "$_", @list; # Normalize
print "# @list\n";
# need to special case ++ for max_uv, as ++ "magic" on a string gives
# another string, whereas ++ magic on a string used as a number gives
# a number. Not a problem when NV preserves UV, but if it doesn't then
# stringification of the latter gives something in e notation.
my $max_uv_pp = "$max_uv"; $max_uv_pp++;
my $max_uv_p1 = "$max_uv"; $max_uv_p1+=0; $max_uv_p1++;
# Also need to cope with %g notation for max_uv_p1 that actually gives an
# integer less than max_uv because of correct rounding for the limited
# precisision. This bites for 12 byte long doubles and 8 byte UVs
my $temp = $max_uv_p1;
my $max_uv_p1_as_iv;
{use integer; $max_uv_p1_as_iv = 0 + sprintf "%s", $temp}
my $max_uv_p1_as_uv = 0 | sprintf "%s", $temp;
my @opnames = split //, "-+UINPuinp";
# @list = map { 2->($_), 3->($_), 4->($_), 5->($_), } @list; # Prepare input
#print "@list\n";
#print "'@ops'\n";
my $test = 1;
my $nok;
for my $num_chain (1..$max_chain) {
my @ops = map [split //], grep /[4-9]/,
map { sprintf "%0${num_chain}d", $_ } 0 .. 10**$num_chain - 1;
#@ops = ([]) unless $num_chain;
#@ops = ([6, 4]);
# print "'@ops'\n";
for my $op (@ops) {
for my $first (2..5) {
for my $last (2..5) {
$nok = 0;
my @otherops = grep $_ <= 3, @$op;
my @curops = ($op,\@otherops);
for my $num (@list) {
my $inpt;
my @ans;
for my $short (0, 1) {
# undef $inpt; # Forget all we had - some bugs were masked
$inpt = $num; # Try to not contaminate $num...
$inpt = "$inpt";
if ($first == 2) {
$inpt = $max_uv & $inpt; # U 2
} elsif ($first == 3) {
use integer; $inpt += $zero; # I 3
} elsif ($first == 4) {
$inpt += $zero; # N 4
} else {
$inpt = "$inpt"; # P 5
}
# Saves 20% of time - not with this logic:
#my $tmp = $inpt;
#my $tmp1 = $num;
#next if $num_chain > 1
# and "$tmp" ne "$tmp1"; # Already the coercion gives problems...
for my $curop (@{$curops[$short]}) {
if ($curop < 5) {
if ($curop < 3) {
if ($curop == 0) {
--$inpt; # - 0
} elsif ($curop == 1) {
++$inpt; # + 1
} else {
$inpt = $max_uv & $inpt; # U 2
}
} elsif ($curop == 3) {
use integer; $inpt += $zero;
} else {
$inpt += $zero; # N 4
}
} elsif ($curop < 8) {
if ($curop == 5) {
$inpt = "$inpt"; # P 5
} elsif ($curop == 6) {
$max_uv & $inpt; # u 6
} else {
use integer; $inpt + $zero;
}
} elsif ($curop == 8) {
$inpt + $zero; # n 8
} else {
$inpt . ""; # p 9
}
}
if ($last == 2) {
$inpt = sprintf "%u", $inpt; # U 2
} elsif ($last == 3) {
$inpt = sprintf "%d", $inpt; # I 3
} elsif ($last == 4) {
$inpt = sprintf "%g", $inpt; # N 4
} else {
$inpt = "$inpt"; # P 5
}
push @ans, $inpt;
}
if ($ans[0] ne $ans[1]) {
print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n";
# XXX ought to check that "+" was in the list of opnames
if ((($ans[0] eq $max_uv_pp) and ($ans[1] eq $max_uv_p1))
or (($ans[1] eq $max_uv_pp) and ($ans[0] eq $max_uv_p1))) {
# string ++ versus numeric ++. Tolerate this little
# bit of insanity
print "# ok, as string ++ of max_uv is \"$max_uv_pp\", numeric is $max_uv_p1\n"
} elsif ($opnames[$last] eq 'I' and $ans[1] eq "-1"
and $ans[0] eq $max_uv_p1_as_iv) {
# Max UV plus 1 is NV. This NV may stringify in E notation.
# And the number of decimal digits shown in E notation will depend
# on the binary digits in the mantissa. And it may be that
# (say) 18446744073709551616 in E notation is truncated to
# (say) 1.8446744073709551e+19 (say) which gets converted back
# as 1.8446744073709551000e+19
# ie 18446744073709551000
# which isn't the integer we first had.
# But each step of conversion is correct. So it's not an error.
# (Only shows up for 64 bit UVs and NVs with 64 bit mantissas,
# and on Crays (64 bit integers, 48 bit mantissas) IIRC)
print "# ok, \"$max_uv_p1\" correctly converts to IV \"$max_uv_p1_as_iv\"\n";
} elsif ($opnames[$last] eq 'U' and $ans[1] eq ~0
and $ans[0] eq $max_uv_p1_as_uv) {
# as aboce
print "# ok, \"$max_uv_p1\" correctly converts to UV \"$max_uv_p1_as_uv\"\n";
} elsif (grep {/^N$/} @opnames[@{$curops[0]}]
and $ans[0] == $ans[1] and $ans[0] <= ~0
# First must be in E notation (ie not just digits) and
# second must still be an integer.
# eg 1.84467440737095516e+19
# 1.84467440737095516e+19 for 64 bit mantissa is in the
# integer range, so 1.84467440737095516e+19 + 0 is treated
# as integer addition. [should it be?]
# and 18446744073709551600 + 0 is 18446744073709551600
# Which isn't the string you first thought of.
# I can't remember why there isn't symmetry in this
# exception, ie why only the first ops are tested for 'N'
and $ans[0] != /^-?\d+$/ and $ans[1] !~ /^-?\d+$/) {
print "# ok, numerically equal - notation changed due to adding zero\n";
} else {
$nok++,
}
}
}
if ($nok) {
print "not ok $test\n";
} else {
print "ok $test\n";
}
#print $txt if $nok;
$test++;
}
}
}
}
--- NEW FILE: read.t ---
#!./perl
# $RCSfile: read.t,v $$Revision: 1.2 $$Date: 2006-12-04 17:02:04 $
BEGIN {
chdir 't';
@INC = '../lib';
require './test.pl';
}
use strict;
plan tests => 2564;
open(FOO,'op/read.t') || open(FOO,'t/op/read.t') || open(FOO,':op:read.t') || die "Can't open op.read";
seek(FOO,4,0) or die "Seek failed: $!";
my $buf;
my $got = read(FOO,$buf,4);
is ($got, 4);
is ($buf, "perl");
seek (FOO,0,2) || seek(FOO,20000,0);
$got = read(FOO,$buf,4);
is ($got, 0);
is ($buf, "");
# This is true if Config is not built, or if PerlIO is enabled
# ie assume that PerlIO is present, unless we know for sure otherwise.
my $has_perlio = !eval {
no warnings;
require Config;
!$Config::Config{useperlio}
};
my $tmpfile = 'Op_read.tmp';
END { 1 while unlink $tmpfile }
my (@values, @buffers) = ('', '');
foreach (65, 161, 253, 9786) {
push @values, join "", map {chr $_} $_ .. $_ + 4;
push @buffers, join "", map {chr $_} $_ + 5 .. $_ + 20;
}
my @offsets = (0, 3, 7, 22, -1, -3, -5, -7);
my @lengths = (0, 2, 5, 10);
foreach my $value (@values) {
foreach my $initial_buffer (@buffers) {
my @utf8 = 1;
if ($value !~ tr/\0-\377//c) {
# It's all 8 bit
unshift @utf8, 0;
}
SKIP:
foreach my $utf8 (@utf8) {
skip "Needs :utf8 layer but no perlio", 2 * @offsets * @lengths
if $utf8 and !$has_perlio;
1 while unlink $tmpfile;
open FH, ">$tmpfile" or die "Can't open $tmpfile: $!";
binmode FH, "utf8" if $utf8;
print FH $value;
close FH;
foreach my $offset (@offsets) {
foreach my $length (@lengths) {
# Will read the lesser of the length of the file and the
# read length
my $will_read = $value;
if ($length < length $will_read) {
substr ($will_read, $length) = '';
}
# Going to trash this so need a copy
my $buffer = $initial_buffer;
my $expect = $buffer;
if ($offset > 0) {
# Right pad with NUL bytes
$expect .= "\0" x $offset;
substr ($expect, $offset) = '';
}
substr ($expect, $offset) = $will_read;
open FH, $tmpfile or die "Can't open $tmpfile: $!";
binmode FH, "utf8" if $utf8;
my $what = sprintf "%d into %d l $length o $offset",
ord $value, ord $buffer;
$what .= ' u' if $utf8;
$got = read (FH, $buffer, $length, $offset);
is ($got, length $will_read, "got $what");
is ($buffer, $expect, "buffer $what");
close FH;
}
}
}
}
}
--- NEW FILE: recurse.t ---
#!./perl
#
# test recursive functions.
#
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
require "test.pl";
plan(tests => 28);
}
use strict;
sub gcd {
return gcd($_[0] - $_[1], $_[1]) if ($_[0] > $_[1]);
return gcd($_[0], $_[1] - $_[0]) if ($_[0] < $_[1]);
$_[0];
}
sub factorial {
$_[0] < 2 ? 1 : $_[0] * factorial($_[0] - 1);
}
sub fibonacci {
$_[0] < 2 ? 1 : fibonacci($_[0] - 2) + fibonacci($_[0] - 1);
}
# Highly recursive, highly aggressive.
# Kids, don't try this at home.
#
# For example ackermann(4,1) will take quite a long time.
# It will simply eat away your memory. Trust me.
sub ackermann {
return $_[1] + 1 if ($_[0] == 0);
return ackermann($_[0] - 1, 1) if ($_[1] == 0);
ackermann($_[0] - 1, ackermann($_[0], $_[1] - 1));
}
# Highly recursive, highly boring.
sub takeuchi {
$_[1] < $_[0] ?
takeuchi(takeuchi($_[0] - 1, $_[1], $_[2]),
takeuchi($_[1] - 1, $_[2], $_[0]),
takeuchi($_[2] - 1, $_[0], $_[1]))
: $_[2];
}
is(gcd(1147, 1271), 31, "gcd(1147, 1271) == 31");
is(gcd(1908, 2016), 36, "gcd(1908, 2016) == 36");
is(factorial(10), 3628800, "factorial(10) == 3628800");
is(factorial(factorial(3)), 720, "factorial(factorial(3)) == 720");
is(fibonacci(10), 89, "fibonacci(10) == 89");
is(fibonacci(fibonacci(7)), 17711, "fibonacci(fibonacci(7)) == 17711");
my @ack = qw(1 2 3 4 2 3 4 5 3 5 7 9 5 13 29 61);
for my $x (0..3) {
for my $y (0..3) {
my $a = ackermann($x, $y);
is($a, shift(@ack), "ackermann($x, $y) == $a");
}
}
my ($x, $y, $z) = (18, 12, 6);
is(takeuchi($x, $y, $z), $z + 1, "takeuchi($x, $y, $z) == $z + 1");
{
sub get_first1 {
get_list1(@_)->[0];
}
sub get_list1 {
return [curr_test] unless $_[0];
my $u = get_first1(0);
[$u];
}
my $x = get_first1(1);
ok($x, "premature FREETMPS (change 5699)");
}
{
sub get_first2 {
return get_list2(@_)->[0];
}
sub get_list2 {
return [curr_test] unless $_[0];
my $u = get_first2(0);
return [$u];
}
my $x = get_first2(1);
ok($x, "premature FREETMPS (change 5699)");
}
{
local $^W = 0; # We do not need recursion depth warning.
sub sillysum {
return $_[0] + ($_[0] > 0 ? sillysum($_[0] - 1) : 0);
}
is(sillysum(1000), 1000*1001/2, "recursive sum of 1..1000");
}
# check ok for recursion depth > 65536
{
my $r;
eval {
$r = runperl(
nolib => 1,
stderr => 1,
prog => q{$d=0; $e=1; sub c { ++$d; if ($d > 66000) { $e=0 } else { c(); c() unless $d % 32768 } --$d } c(); exit $e});
};
SKIP: {
skip("Out of memory -- increase your data/heap?", 2)
if $r =~ /Out of memory/i;
is($r, '', "64K deep recursion - no output expected");
if ($^O eq 'MacOS') {
ok(1, "$^O: \$? is unreliable");
} else {
is($?, 0, "64K deep recursion - no coredump expected");
}
}
}
--- NEW FILE: die_exit.t ---
#!./perl
#
# Verify that C<die> return the return code
# -- Robin Barker <rmb at cise.npl.co.uk>
#
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
if ($^O eq 'mpeix') {
print "1..0 # Skip: broken on MPE/iX\n";
exit 0;
}
$| = 1;
use strict;
my %tests = (
1 => [ 0, 0],
2 => [ 0, 1],
3 => [ 0, 127],
4 => [ 0, 128],
5 => [ 0, 255],
6 => [ 0, 256],
7 => [ 0, 512],
8 => [ 1, 0],
9 => [ 1, 1],
10 => [ 1, 256],
11 => [ 128, 0],
12 => [ 128, 1],
13 => [ 128, 256],
14 => [ 255, 0],
15 => [ 255, 1],
16 => [ 255, 256],
# see if implicit close preserves $?
17 => [ 0, 512, '{ local *F; open F, q[TEST]; close F; $!=0 } die;'],
);
my $max = keys %tests;
print "1..$max\n";
# Dump any error messages from the dying processes off to a temp file.
open(STDERR, ">die_exit.err") or die "Can't open temp error file: $!";
foreach my $test (1 .. $max) {
my($bang, $query, $code) = @{$tests{$test}};
$code ||= 'die;';
if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') {
system(qq{$^X -e "\$! = $bang; \$? = $query; $code"});
}
else {
system(qq{$^X -e '\$! = $bang; \$? = $query; $code'});
}
my $exit = $?;
# VMS exit code 44 (SS$_ABORT) is returned if a program dies. We only get
# the severity bits, which boils down to 4. See L<perlvms/$?>.
$bang = 4 if $^O eq 'VMS';
printf "# 0x%04x 0x%04x 0x%04x\n", $exit, $bang, $query;
print "not " unless $exit == (($bang || ($query >> 8) || 255) << 8);
print "ok $test\n";
}
close STDERR;
END { 1 while unlink 'die_exit.err' }
--- NEW FILE: chars.t ---
#!./perl
print "1..33\n";
# because of ebcdic.c these should be the same on asciiish
# and ebcdic machines.
# Peter Prymmer <pvhp at best.com>.
my $c = "\c@";
print +((ord($c) == 0) ? "" : "not "),"ok 1\n";
$c = "\cA";
print +((ord($c) == 1) ? "" : "not "),"ok 2\n";
$c = "\cB";
print +((ord($c) == 2) ? "" : "not "),"ok 3\n";
$c = "\cC";
print +((ord($c) == 3) ? "" : "not "),"ok 4\n";
$c = "\cD";
print +((ord($c) == 4) ? "" : "not "),"ok 5\n";
$c = "\cE";
print +((ord($c) == 5) ? "" : "not "),"ok 6\n";
$c = "\cF";
print +((ord($c) == 6) ? "" : "not "),"ok 7\n";
$c = "\cG";
print +((ord($c) == 7) ? "" : "not "),"ok 8\n";
$c = "\cH";
print +((ord($c) == 8) ? "" : "not "),"ok 9\n";
$c = "\cI";
print +((ord($c) == 9) ? "" : "not "),"ok 10\n";
$c = "\cJ";
print +((ord($c) == 10) ? "" : "not "),"ok 11\n";
$c = "\cK";
print +((ord($c) == 11) ? "" : "not "),"ok 12\n";
$c = "\cL";
print +((ord($c) == 12) ? "" : "not "),"ok 13\n";
$c = "\cM";
print +((ord($c) == 13) ? "" : "not "),"ok 14\n";
$c = "\cN";
print +((ord($c) == 14) ? "" : "not "),"ok 15\n";
$c = "\cO";
print +((ord($c) == 15) ? "" : "not "),"ok 16\n";
$c = "\cP";
print +((ord($c) == 16) ? "" : "not "),"ok 17\n";
$c = "\cQ";
print +((ord($c) == 17) ? "" : "not "),"ok 18\n";
$c = "\cR";
print +((ord($c) == 18) ? "" : "not "),"ok 19\n";
$c = "\cS";
print +((ord($c) == 19) ? "" : "not "),"ok 20\n";
$c = "\cT";
print +((ord($c) == 20) ? "" : "not "),"ok 21\n";
$c = "\cU";
print +((ord($c) == 21) ? "" : "not "),"ok 22\n";
$c = "\cV";
print +((ord($c) == 22) ? "" : "not "),"ok 23\n";
$c = "\cW";
print +((ord($c) == 23) ? "" : "not "),"ok 24\n";
$c = "\cX";
print +((ord($c) == 24) ? "" : "not "),"ok 25\n";
$c = "\cY";
print +((ord($c) == 25) ? "" : "not "),"ok 26\n";
$c = "\cZ";
print +((ord($c) == 26) ? "" : "not "),"ok 27\n";
$c = "\c[";
print +((ord($c) == 27) ? "" : "not "),"ok 28\n";
$c = "\c\\";
print +((ord($c) == 28) ? "" : "not "),"ok 29\n";
$c = "\c]";
print +((ord($c) == 29) ? "" : "not "),"ok 30\n";
$c = "\c^";
print +((ord($c) == 30) ? "" : "not "),"ok 31\n";
$c = "\c_";
print +((ord($c) == 31) ? "" : "not "),"ok 32\n";
$c = "\c?";
print +((ord($c) == 127) ? "" : "not "),"ok 33\n";
--- NEW FILE: stash.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = qw(../lib);
}
require "./test.pl";
plan( tests => 2 );
# Used to segfault (bug #15479)
fresh_perl_is(
'%:: = ""',
'Odd number of elements in hash assignment at - line 1.',
{ switches => [ '-w' ] },
'delete $::{STDERR} and print a warning',
);
# Used to segfault
fresh_perl_is(
'BEGIN { $::{"X::"} = 2 }',
'',
{ switches => [ '-w' ] },
q(Insert a non-GV in a stash, under warnings 'once'),
);
--- NEW FILE: override.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
plan tests => 21;
#
# This file tries to test builtin override using CORE::GLOBAL
#
my $dirsep = "/";
BEGIN { package Foo; *main::getlogin = sub { "kilroy"; } }
is( getlogin, "kilroy" );
my $t = 42;
BEGIN { *CORE::GLOBAL::time = sub () { $t; } }
is( 45, time + 3 );
#
# require has special behaviour
#
my $r;
BEGIN { *CORE::GLOBAL::require = sub { $r = shift; 1; } }
require Foo;
is( $r, "Foo.pm" );
require Foo::Bar;
is( $r, join($dirsep, "Foo", "Bar.pm") );
require 'Foo';
is( $r, "Foo" );
require 5.6;
is( $r, "5.6" );
require v5.6;
ok( abs($r - 5.006) < 0.001 && $r eq "\x05\x06" );
eval "use Foo";
is( $r, "Foo.pm" );
eval "use Foo::Bar";
is( $r, join($dirsep, "Foo", "Bar.pm") );
eval "use 5.6";
is( $r, "5.6" );
# localizing *CORE::GLOBAL::foo should revert to finding CORE::foo
{
local(*CORE::GLOBAL::require);
$r = '';
eval "require NoNeXiSt;";
ok( ! ( $r or $@ !~ /^Can't locate NoNeXiSt/i ) );
}
#
# readline() has special behaviour too
#
$r = 11;
BEGIN { *CORE::GLOBAL::readline = sub (;*) { ++$r }; }
is( <FH> , 12 );
is( <$fh> , 13 );
my $pad_fh;
is( <$pad_fh> , 14 );
# Non-global readline() override
BEGIN { *Rgs::readline = sub (;*) { --$r }; }
package Rgs;
::is( <FH> , 13 );
::is( <$fh> , 12 );
::is( <$pad_fh> , 11 );
# Verify that the parsing of overriden keywords isn't messed up
# by the indirect object notation
{
local $SIG{__WARN__} = sub {
::like( $_[0], qr/^ok overriden at/ );
};
BEGIN { *OverridenWarn::warn = sub { CORE::warn "@_ overriden"; }; }
package OverridenWarn;
sub foo { "ok" }
warn( OverridenWarn->foo() );
warn OverridenWarn->foo();
}
BEGIN { *OverridenPop::pop = sub { ::is( $_[0][0], "ok" ) }; }
package OverridenPop;
sub foo { [ "ok" ] }
pop( OverridenPop->foo() );
pop OverridenPop->foo();
--- NEW FILE: subst_amp.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
}
print "1..13\n";
$_ = 'x' x 20;
s/\d*|x/<$&>/g;
$foo = '<>' . ('<x><>' x 20) ;
print ($_ eq $foo ? "ok 1\n" : "not ok 1\n#'$_'\n#'$foo'\n");
$t = 'aaa';
$_ = $t;
@res = ();
pos = 1;
s/\Ga(?{push @res, $_, $`})/xx/g;
print "not " unless "$_ @res" eq 'axxxx aaa a aaa aa';
print "ok 2\n";
$_ = $t;
@res = ();
pos = 1;
s/\Ga(?{push @res, $_, $`})/x/g;
print "not " unless "$_ @res" eq 'axx aaa a aaa aa';
print "ok 3\n";
$_ = $t;
@res = ();
pos = 1;
s/\Ga(?{push @res, $_, $`})/xx/;
print "not " unless "$_ @res" eq 'axxa aaa a';
print "ok 4\n";
$_ = $t;
@res = ();
pos = 1;
s/\Ga(?{push @res, $_, $`})/x/;
print "not " unless "$_ @res" eq 'axa aaa a';
print "ok 5\n";
$a = $t;
@res = ();
pos ($a) = 1;
$a =~ s/\Ga(?{push @res, $_, $`})/xx/g;
print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa';
print "ok 6\n";
$a = $t;
@res = ();
pos ($a) = 1;
$a =~ s/\Ga(?{push @res, $_, $`})/x/g;
print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa';
print "ok 7\n";
$a = $t;
@res = ();
pos ($a) = 1;
$a =~ s/\Ga(?{push @res, $_, $`})/xx/;
print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a';
print "ok 8\n";
$a = $t;
@res = ();
pos ($a) = 1;
$a =~ s/\Ga(?{push @res, $_, $`})/x/;
print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a';
print "ok 9\n";
sub x2 {'xx'}
sub x1 {'x'}
$a = $t;
@res = ();
pos ($a) = 1;
$a =~ s/\Ga(?{push @res, $_, $`})/x2/ge;
print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa';
print "ok 10\n";
$a = $t;
@res = ();
pos ($a) = 1;
$a =~ s/\Ga(?{push @res, $_, $`})/x1/ge;
print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa';
print "ok 11\n";
$a = $t;
@res = ();
pos ($a) = 1;
$a =~ s/\Ga(?{push @res, $_, $`})/x2/e;
print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a';
print "ok 12\n";
$a = $t;
@res = ();
pos ($a) = 1;
$a =~ s/\Ga(?{push @res, $_, $`})/x1/e;
print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a';
print "ok 13\n";
--- NEW FILE: nothr5005.t ---
#!./perl
# NOTE: Please don't add tests to this file unless they *need* to be run in
# separate executable and can't simply use eval.
BEGIN
{
chdir 't' if -d 't';
@INC = '../lib';
require Config;
import Config;
if ($Config{'use5005threads'})
{
print "1..0 # Skip: this perl is threaded\n";
exit 0;
}
}
$|=1;
print "1..9\n";
$t = 1;
sub foo { local(@_) = ('p', 'q', 'r'); }
sub bar { unshift @_, 'D'; @_ }
sub baz { push @_, 'E'; return @_ }
for (1..3)
{
print "not " unless join('',foo('a', 'b', 'c')) eq 'pqr';
print "ok ",$t++,"\n";
print "not" unless join('',bar('d')) eq 'Dd';
print "ok ",$t++,"\n";
print "not" unless join('',baz('e')) eq 'eE';
print "ok ",$t++,"\n";
}
--- NEW FILE: runlevel.t ---
#!./perl
##
## Many of these tests are originally from Michael Schroeder
## <Michael.Schroeder at informatik.uni-erlangen.de>
## Adapted and expanded by Gurusamy Sarathy <gsar at activestate.com>
##
chdir 't' if -d 't';
@INC = '../lib';
$Is_VMS = $^O eq 'VMS';
$Is_MSWin32 = $^O eq 'MSWin32';
$Is_NetWare = $^O eq 'NetWare';
$Is_MacOS = $^O eq 'MacOS';
$ENV{PERL5LIB} = "../lib" unless $Is_VMS;
$|=1;
undef $/;
@prgs = split "\n########\n", <DATA>;
print "1..", scalar @prgs, "\n";
$tmpfile = "runltmp000";
1 while -f ++$tmpfile;
END { if ($tmpfile) { 1 while unlink $tmpfile; } }
for (@prgs){
my $switch = "";
if (s/^\s*(-\w+)//){
$switch = $1;
}
my($prog,$expected) = split(/\nEXPECT\n/, $_);
open TEST, ">$tmpfile";
print TEST "$prog\n";
close TEST or die "Could not close: $!";
my $results = $Is_VMS ?
`MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
$Is_MSWin32 ?
`.\\perl -I../lib $switch $tmpfile 2>&1` :
$Is_NetWare ?
`perl -I../lib $switch $tmpfile 2>&1` :
$Is_MacOS ?
`$^X -I::lib -MMac::err=unix $switch $tmpfile` :
`./perl $switch $tmpfile 2>&1`;
my $status = $?;
$results =~ s/\n+$//;
# allow expected output to be written as if $prog is on STDIN
$results =~ s/runltmp\d+/-/g;
$results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg
$expected =~ s/\n+$//;
if ($results ne $expected) {
print STDERR "PROG: $switch\n$prog\n";
print STDERR "EXPECTED:\n$expected\n";
print STDERR "GOT:\n$results\n";
print "not ";
}
print "ok ", ++$i, "\n";
}
__END__
@a = (1, 2, 3);
{
@a = sort { last ; } @a;
}
EXPECT
Can't "last" outside a loop block at - line 3.
########
package TEST;
sub TIESCALAR {
my $foo;
return bless \$foo;
}
sub FETCH {
eval 'die("test")';
print "still in fetch\n";
return ">$@<";
}
package main;
tie $bar, TEST;
print "- $bar\n";
EXPECT
still in fetch
- >test at (eval 1) line 1.
<
########
package TEST;
sub TIESCALAR {
my $foo;
eval('die("foo\n")');
print "after eval\n";
return bless \$foo;
}
sub FETCH {
return "ZZZ";
}
package main;
tie $bar, TEST;
print "- $bar\n";
print "OK\n";
EXPECT
after eval
- ZZZ
OK
########
package TEST;
sub TIEHANDLE {
my $foo;
return bless \$foo;
}
sub PRINT {
print STDERR "PRINT CALLED\n";
(split(/./, 'x'x10000))[0];
eval('die("test\n")');
}
package main;
open FH, ">&STDOUT";
tie *FH, TEST;
print FH "OK\n";
print STDERR "DONE\n";
EXPECT
PRINT CALLED
DONE
########
sub warnhook {
print "WARNHOOK\n";
eval('die("foooo\n")');
}
$SIG{'__WARN__'} = 'warnhook';
warn("dfsds\n");
print "END\n";
EXPECT
WARNHOOK
END
########
package TEST;
use overload
"\"\"" => \&str
;
sub str {
eval('die("test\n")');
return "STR";
}
package main;
$bar = bless {}, TEST;
print "$bar\n";
print "OK\n";
EXPECT
STR
OK
########
sub foo {
$a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)');
}
@a = (3, 2, 0, 1);
@a = sort foo @a;
print join(', ', @a)."\n";
EXPECT
0, 1, 2, 3
########
sub foo {
goto bar if $a == 0 || $b == 0;
$a <=> $b;
}
@a = (3, 2, 0, 1);
@a = sort foo @a;
print join(', ', @a)."\n";
exit;
bar:
print "bar reached\n";
EXPECT
Can't "goto" out of a pseudo block at - line 2.
########
%seen = ();
sub sortfn {
(split(/./, 'x'x10000))[0];
my (@y) = ( 4, 6, 5);
@y = sort { $a <=> $b } @y;
my $t = "sortfn ".join(', ', @y)."\n";
print $t if ($seen{$t}++ == 0);
return $_[0] <=> $_[1];
}
@x = ( 3, 2, 1 );
@x = sort { &sortfn($a, $b) } @x;
print "---- ".join(', ', @x)."\n";
EXPECT
sortfn 4, 5, 6
---- 1, 2, 3
########
@a = (3, 2, 1);
@a = sort { eval('die("no way")') , $a <=> $b} @a;
print join(", ", @a)."\n";
EXPECT
1, 2, 3
########
@a = (1, 2, 3);
foo:
{
@a = sort { last foo; } @a;
}
EXPECT
Label not found for "last foo" at - line 2.
########
package TEST;
sub TIESCALAR {
my $foo;
return bless \$foo;
}
sub FETCH {
next;
return "ZZZ";
}
sub STORE {
}
package main;
tie $bar, TEST;
{
print "- $bar\n";
}
print "OK\n";
EXPECT
Can't "next" outside a loop block at - line 8.
########
package TEST;
sub TIESCALAR {
my $foo;
return bless \$foo;
}
sub FETCH {
goto bbb;
return "ZZZ";
}
package main;
tie $bar, TEST;
print "- $bar\n";
exit;
bbb:
print "bbb\n";
EXPECT
Can't find label bbb at - line 8.
########
sub foo {
$a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)');
}
@a = (3, 2, 0, 1);
@a = sort foo @a;
print join(', ', @a)."\n";
EXPECT
0, 1, 2, 3
########
package TEST;
sub TIESCALAR {
my $foo;
return bless \$foo;
}
sub FETCH {
return "fetch";
}
sub STORE {
(split(/./, 'x'x10000))[0];
}
package main;
tie $bar, TEST;
$bar = "x";
########
package TEST;
sub TIESCALAR {
my $foo;
next;
return bless \$foo;
}
package main;
{
tie $bar, TEST;
}
EXPECT
Can't "next" outside a loop block at - line 4.
########
@a = (1, 2, 3);
foo:
{
@a = sort { exit(0) } @a;
}
END { print "foobar\n" }
EXPECT
foobar
########
$SIG{__DIE__} = sub {
print "In DIE\n";
$i = 0;
while (($p,$f,$l,$s) = caller(++$i)) {
print "$p|$f|$l|$s\n";
}
};
eval { die };
&{sub { eval 'die' }}();
sub foo { eval { die } } foo();
{package rmb; sub{ eval{die} } ->() }; # check __ANON__ knows package
EXPECT
In DIE
main|-|8|(eval)
In DIE
main|-|9|(eval)
main|-|9|main::__ANON__
In DIE
main|-|10|(eval)
main|-|10|main::foo
In DIE
rmb|-|11|(eval)
rmb|-|11|rmb::__ANON__
########
package TEST;
sub TIEARRAY {
return bless [qw(foo fee fie foe)], $_[0];
}
sub FETCH {
my ($s,$i) = @_;
if ($i) {
goto bbb;
}
bbb:
return $s->[$i];
}
package main;
tie my @bar, 'TEST';
print join('|', @bar[0..3]), "\n";
EXPECT
foo|fee|fie|foe
########
package TH;
sub TIEHASH { bless {}, TH }
sub STORE { eval { print "@_[1,2]\n" }; die "bar\n" }
tie %h, TH;
eval { $h{A} = 1; print "never\n"; };
print $@;
eval { $h{B} = 2; };
print $@;
EXPECT
A 1
bar
B 2
bar
########
sub n { 0 }
sub f { my $x = shift; d(); }
f(n());
f();
sub d {
my $i = 0; my @a;
while (do { { package DB; @a = caller($i++) } } ) {
@a = @DB::args;
for (@a) { print "$_\n"; $_ = '' }
}
}
EXPECT
0
########
sub TIEHANDLE { bless {} }
sub PRINT { next }
tie *STDERR, '';
{ map ++$_, 1 }
EXPECT
Can't "next" outside a loop block at - line 2.
########
sub TIEHANDLE { bless {} }
sub PRINT { print "[TIE] $_[1]" }
tie *STDERR, '';
die "DIE\n";
EXPECT
[TIE] DIE
########
sub TIEHANDLE { bless {} }
sub PRINT {
(split(/./, 'x'x10000))[0];
eval('die("test\n")');
warn "[TIE] $_[1]";
}
open OLDERR, '>&STDERR';
tie *STDERR, '';
use warnings FATAL => qw(uninitialized);
print undef;
EXPECT
[TIE] Use of uninitialized value in print at - line 11.
--- NEW FILE: not.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
plan tests => 16;
# not() tests
pass() if not();
is(not(), 1);
is(not(), not(0));
# test not(..) and !
is(! 1, not 1);
is(! 0, not 0);
is(! (0, 0), not(0, 0));
# test the return of !
{
my $not0 = ! 0;
my $not1 = ! 1;
no warnings;
ok($not1 == undef);
ok($not1 == ());
use warnings;
ok($not1 eq '');
ok($not1 == 0);
ok($not0 == 1);
}
# test the return of not
{
my $not0 = not 0;
my $not1 = not 1;
no warnings;
ok($not1 == undef);
ok($not1 == ());
use warnings;
ok($not1 eq '');
ok($not1 == 0);
ok($not0 == 1);
}
--- NEW FILE: inccode.t ---
#!./perl -w
# Tests for the coderef-in- at INC feature
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
}
use File::Spec;
require "test.pl";
plan(tests => 45);
my @tempfiles = ();
sub get_temp_fh {
my $f = "DummyModule0000";
1 while -e ++$f;
push @tempfiles, $f;
open my $fh, ">$f" or die "Can't create $f: $!";
print $fh "package ".substr($_[0],0,-3).";\n1;\n";
print $fh $_[1] if @_ > 1;
close $fh or die "Couldn't close: $!";
open $fh, $f or die "Can't open $f: $!";
return $fh;
}
END { 1 while unlink @tempfiles }
sub fooinc {
my ($self, $filename) = @_;
if (substr($filename,0,3) eq 'Foo') {
return get_temp_fh($filename);
}
else {
return undef;
}
}
push @INC, \&fooinc;
my $evalret = eval { require Bar; 1 };
ok( !$evalret, 'Trying non-magic package' );
$evalret = eval { require Foo; 1 };
die $@ if $@;
ok( $evalret, 'require Foo; magic via code ref' );
ok( exists $INC{'Foo.pm'}, ' %INC sees Foo.pm' );
is( ref $INC{'Foo.pm'}, 'CODE', ' val Foo.pm is a coderef in %INC' );
is( $INC{'Foo.pm'}, \&fooinc, ' val Foo.pm is correct in %INC' );
$evalret = eval "use Foo1; 1;";
die $@ if $@;
ok( $evalret, 'use Foo1' );
ok( exists $INC{'Foo1.pm'}, ' %INC sees Foo1.pm' );
is( ref $INC{'Foo1.pm'}, 'CODE', ' val Foo1.pm is a coderef in %INC' );
is( $INC{'Foo1.pm'}, \&fooinc, ' val Foo1.pm is correct in %INC' );
$evalret = eval { do 'Foo2.pl'; 1 };
die $@ if $@;
ok( $evalret, 'do "Foo2.pl"' );
ok( exists $INC{'Foo2.pl'}, ' %INC sees Foo2.pl' );
is( ref $INC{'Foo2.pl'}, 'CODE', ' val Foo2.pl is a coderef in %INC' );
is( $INC{'Foo2.pl'}, \&fooinc, ' val Foo2.pl is correct in %INC' );
pop @INC;
sub fooinc2 {
my ($self, $filename) = @_;
if (substr($filename, 0, length($self->[1])) eq $self->[1]) {
return get_temp_fh($filename);
}
else {
return undef;
}
}
my $arrayref = [ \&fooinc2, 'Bar' ];
push @INC, $arrayref;
$evalret = eval { require Foo; 1; };
die $@ if $@;
ok( $evalret, 'Originally loaded packages preserved' );
$evalret = eval { require Foo3; 1; };
ok( !$evalret, 'Original magic INC purged' );
$evalret = eval { require Bar; 1 };
die $@ if $@;
ok( $evalret, 'require Bar; magic via array ref' );
ok( exists $INC{'Bar.pm'}, ' %INC sees Bar.pm' );
is( ref $INC{'Bar.pm'}, 'ARRAY', ' val Bar.pm is an arrayref in %INC' );
is( $INC{'Bar.pm'}, $arrayref, ' val Bar.pm is correct in %INC' );
ok( eval "use Bar1; 1;", 'use Bar1' );
ok( exists $INC{'Bar1.pm'}, ' %INC sees Bar1.pm' );
is( ref $INC{'Bar1.pm'}, 'ARRAY', ' val Bar1.pm is an arrayref in %INC' );
is( $INC{'Bar1.pm'}, $arrayref, ' val Bar1.pm is correct in %INC' );
ok( eval { do 'Bar2.pl'; 1 }, 'do "Bar2.pl"' );
ok( exists $INC{'Bar2.pl'}, ' %INC sees Bar2.pl' );
is( ref $INC{'Bar2.pl'}, 'ARRAY', ' val Bar2.pl is an arrayref in %INC' );
is( $INC{'Bar2.pl'}, $arrayref, ' val Bar2.pl is correct in %INC' );
pop @INC;
sub FooLoader::INC {
my ($self, $filename) = @_;
if (substr($filename,0,4) eq 'Quux') {
return get_temp_fh($filename);
}
else {
return undef;
}
}
my $href = bless( {}, 'FooLoader' );
push @INC, $href;
$evalret = eval { require Quux; 1 };
die $@ if $@;
ok( $evalret, 'require Quux; magic via hash object' );
ok( exists $INC{'Quux.pm'}, ' %INC sees Quux.pm' );
is( ref $INC{'Quux.pm'}, 'FooLoader',
' val Quux.pm is an object in %INC' );
is( $INC{'Quux.pm'}, $href, ' val Quux.pm is correct in %INC' );
pop @INC;
my $aref = bless( [], 'FooLoader' );
push @INC, $aref;
$evalret = eval { require Quux1; 1 };
die $@ if $@;
ok( $evalret, 'require Quux1; magic via array object' );
ok( exists $INC{'Quux1.pm'}, ' %INC sees Quux1.pm' );
is( ref $INC{'Quux1.pm'}, 'FooLoader',
' val Quux1.pm is an object in %INC' );
is( $INC{'Quux1.pm'}, $aref, ' val Quux1.pm is correct in %INC' );
pop @INC;
my $sref = bless( \(my $x = 1), 'FooLoader' );
push @INC, $sref;
$evalret = eval { require Quux2; 1 };
die $@ if $@;
ok( $evalret, 'require Quux2; magic via scalar object' );
ok( exists $INC{'Quux2.pm'}, ' %INC sees Quux2.pm' );
is( ref $INC{'Quux2.pm'}, 'FooLoader',
' val Quux2.pm is an object in %INC' );
is( $INC{'Quux2.pm'}, $sref, ' val Quux2.pm is correct in %INC' );
pop @INC;
push @INC, sub {
my ($self, $filename) = @_;
if (substr($filename,0,4) eq 'Toto') {
$INC{$filename} = 'xyz';
return get_temp_fh($filename);
}
else {
return undef;
}
};
$evalret = eval { require Toto; 1 };
die $@ if $@;
ok( $evalret, 'require Toto; magic via anonymous code ref' );
ok( exists $INC{'Toto.pm'}, ' %INC sees Toto.pm' );
ok( ! ref $INC{'Toto.pm'}, q/ val Toto.pm isn't a ref in %INC/ );
is( $INC{'Toto.pm'}, 'xyz', ' val Toto.pm is correct in %INC' );
pop @INC;
push @INC, sub {
my ($self, $filename) = @_;
if ($filename eq 'abc.pl') {
return get_temp_fh($filename, qq(return "abc";\n));
}
else {
return undef;
}
};
$ret = "";
$ret ||= do 'abc.pl';
is( $ret, 'abc', 'do "abc.pl" sees return value' );
pop @INC;
my $filename = $^O eq 'MacOS' ? ':Foo:Foo.pm' : './Foo.pm';
{
local @INC;
@INC = sub { $filename = 'seen'; return undef; };
eval { require $filename; };
is( $filename, 'seen', 'the coderef sees fully-qualified pathnames' );
}
--- NEW FILE: join.t ---
#!./perl
print "1..22\n";
@x = (1, 2, 3);
if (join(':', at x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
if (join('',1,2,3) eq '123') {print "ok 2\n";} else {print "not ok 2\n";}
if (join(':',split(/ /,"1 2 3")) eq '1:2:3') {print "ok 3\n";} else {print "not ok 3\n";}
my $f = 'a';
$f = join ',', 'b', $f, 'e';
if ($f eq 'b,a,e') {print "ok 4\n";} else {print "# '$f'\nnot ok 4\n";}
$f = 'a';
$f = join ',', $f, 'b', 'e';
if ($f eq 'a,b,e') {print "ok 5\n";} else {print "not ok 5\n";}
$f = 'a';
$f = join $f, 'b', 'e', 'k';
if ($f eq 'baeak') {print "ok 6\n";} else {print "# '$f'\nnot ok 6\n";}
# 7,8 check for multiple read of tied objects
{ package X;
sub TIESCALAR { my $x = 7; bless \$x };
sub FETCH { my $y = shift; $$y += 5 };
tie my $t, 'X';
my $r = join ':', $t, 99, $t, 99;
print "# expected '12:99:17:99' got '$r'\nnot " if $r ne '12:99:17:99';
print "ok 7\n";
$r = join '', $t, 99, $t, 99;
print "# expected '22992799' got '$r'\nnot " if $r ne '22992799';
print "ok 8\n";
};
# 9,10 and for multiple read of undef
{ my $s = 5;
local ($^W, $SIG{__WARN__}) = ( 1, sub { $s+=4 } );
my $r = join ':', 'a', undef, $s, 'b', undef, $s, 'c';
print "# expected 'a::9:b::13:c' got '$r'\nnot " if $r ne 'a::9:b::13:c';
print "ok 9\n";
my $r = join '', 'a', undef, $s, 'b', undef, $s, 'c';
print "# expected 'a17b21c' got '$r'\nnot " if $r ne 'a17b21c';
print "ok 10\n";
};
{ my $s = join("", chr(0x1234), chr(0xff));
print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}";
print "ok 11\n";
}
{ my $s = join(chr(0xff), chr(0x1234), "");
print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}";
print "ok 12\n";
}
{ my $s = join(chr(0x1234), chr(0xff), chr(0x2345));
print "not " unless length($s) == 3 && $s eq "\x{ff}\x{1234}\x{2345}";
print "ok 13\n";
}
{ my $s = join(chr(0xff), chr(0x1234), chr(0xfe));
print "not " unless length($s) == 3 && $s eq "\x{1234}\x{ff}\x{fe}";
print "ok 14\n";
}
{ # [perl #24846] $jb2 should be in bytes, not in utf8.
my $b = "abc\304";
my $u = "abc\x{0100}";
sub join_into_my_variable {
my $r = join("", @_);
return $r;
}
my $jb1 = join_into_my_variable("", $b);
my $ju1 = join_into_my_variable("", $u);
my $jb2 = join_into_my_variable("", $b);
my $ju2 = join_into_my_variable("", $u);
{
use bytes;
print "not " unless $jb1 eq $b;
print "ok 15\n";
}
print "not " unless $jb1 eq $b;
print "ok 16\n";
{
use bytes;
print "not " unless $ju1 eq $u;
print "ok 17\n";
}
print "not " unless $ju1 eq $u;
print "ok 18\n";
{
use bytes;
print "not " unless $jb2 eq $b;
print "ok 19\n";
}
print "not " unless $jb2 eq $b;
print "ok 20\n";
{
use bytes;
print "not " unless $ju2 eq $u;
print "ok 21\n";
}
print "not " unless $ju2 eq $u;
print "ok 22\n";
}
--- NEW FILE: alarm.t ---
#!./perl
BEGIN {
chdir 't';
@INC = '../lib';
require './test.pl';
}
BEGIN {
use Config;
if( !$Config{d_alarm} ) {
skip_all("alarm() not implemented on this platform");
}
}
plan tests => 5;
my $Perl = which_perl();
my $start_time = time;
eval {
local $SIG{ALRM} = sub { die "ALARM!\n" };
alarm 3;
# perlfunc recommends against using sleep in combination with alarm.
1 while (time - $start_time < 6);
};
alarm 0;
my $diff = time - $start_time;
# alarm time might be one second less than you said.
is( $@, "ALARM!\n", 'alarm w/$SIG{ALRM} vs inf loop' );
ok( abs($diff - 3) <= 1, " right time" );
my $start_time = time;
eval {
local $SIG{ALRM} = sub { die "ALARM!\n" };
alarm 3;
system(qq{$Perl -e "sleep 6"});
};
alarm 0;
$diff = time - $start_time;
# alarm time might be one second less than you said.
is( $@, "ALARM!\n", 'alarm w/$SIG{ALRM} vs system()' );
{
local $TODO = "Why does system() block alarm() on $^O?"
if $^O eq 'VMS' || $^O eq'MacOS' || $^O eq 'dos';
ok( abs($diff - 3) <= 1, " right time (waited $diff secs for 3-sec alarm)" );
}
{
local $SIG{"ALRM"} = sub { die };
eval { alarm(1); my $x = qx($Perl -e "sleep 3") };
chomp (my $foo = "foo\n");
ok($foo eq "foo", '[perl #33928] chomp() fails after alarm(), `sleep`');
}
--- NEW FILE: int.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
print "1..14\n";
# compile time evaluation
if (int(1.234) == 1) {print "ok 1\n";} else {print "not ok 1\n";}
if (int(-1.234) == -1) {print "ok 2\n";} else {print "not ok 2\n";}
# run time evaluation
$x = 1.234;
if (int($x) == 1) {print "ok 3\n";} else {print "not ok 3\n";}
if (int(-$x) == -1) {print "ok 4\n";} else {print "not ok 4\n";}
$x = length("abc") % -10;
print $x == -7 ? "ok 5\n" : "# expected -7, got $x\nnot ok 5\n";
{
use integer;
$x = length("abc") % -10;
$y = (3/-10)*-10;
print $x+$y == 3 && abs($x) < 10 ? "ok 6\n" : "not ok 6\n";
}
# check bad strings still get converted
@x = ( 6, 8, 10);
print "not " if $x["1foo"] != 8;
print "ok 7\n";
# check values > 32 bits work.
$x = 4294967303.15;
$y = int ($x);
if ($y eq "4294967303") {
print "ok 8\n"
} else {
print "not ok 8 # int($x) is $y, not 4294967303\n"
}
$y = int (-$x);
if ($y eq "-4294967303") {
print "ok 9\n"
} else {
print "not ok 9 # int($x) is $y, not -4294967303\n"
}
$x = 4294967294.2;
$y = int ($x);
if ($y eq "4294967294") {
print "ok 10\n"
} else {
print "not ok 10 # int($x) is $y, not 4294967294\n"
}
$x = 4294967295.7;
$y = int ($x);
if ($y eq "4294967295") {
print "ok 11\n"
} else {
print "not ok 11 # int($x) is $y, not 4294967295\n"
}
$x = 4294967296.11312;
$y = int ($x);
if ($y eq "4294967296") {
print "ok 12\n"
} else {
print "not ok 12 # int($x) is $y, not 4294967296\n"
}
$y = int(279964589018079/59);
if ($y == 4745162525730) {
print "ok 13\n"
} else {
print "not ok 13 # int(279964589018079/59) is $y, not 4745162525730\n"
}
$y = 279964589018079;
$y = int($y/59);
if ($y == 4745162525730) {
print "ok 14\n"
} else {
print "not ok 14 # int(279964589018079/59) is $y, not 4745162525730\n"
}
--- NEW FILE: write.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
# read in a file
sub cat {
my $file = shift;
local $/;
open my $fh, $file or die "can't open '$file': $!";
my $data = <$fh>;
close $fh;
$data;
}
#-- testing numeric fields in all variants (WL)
sub swrite {
my $format = shift;
local $^A = ""; # don't litter, use a local bin
formline( $format, @_ );
return $^A;
}
my @NumTests = (
# [ format, value1, expected1, value2, expected2, .... ]
[ '@###', 0, ' 0', 1, ' 1', 9999.6, '####',
9999.4999, '9999', -999.6, '####', 1e+100, '####' ],
[ '@0##', 0, '0000', 1, '0001', 9999.6, '####',
-999.4999, '-999', -999.6, '####', 1e+100, '####' ],
[ '^###', 0, ' 0', undef, ' ' ],
[ '^0##', 0, '0000', undef, ' ' ],
[ '@###.', 0, ' 0.', 1, ' 1.', 9999.6, '#####',
9999.4999, '9999.', -999.6, '#####' ],
[ '@##.##', 0, ' 0.00', 1, ' 1.00', 999.996, '######',
999.99499, '999.99', -100, '######' ],
[ '@0#.##', 0, '000.00', 1, '001.00', 10, '010.00',
-0.0001, qr/^[\-0]00\.00$/ ],
);
my $num_tests = 0;
for my $tref ( @NumTests ){
$num_tests += (@$tref - 1)/2;
}
#---------------------------------------------------------
# number of tests in section 1
my $bas_tests = 20;
# number of tests in section 3
my $hmb_tests = 37;
printf "1..%d\n", $bas_tests + $num_tests + $hmb_tests;
############
## Section 1
############
format OUT =
the quick brown @<<
$fox
jumped
@*
$multiline
^<<<<<<<<<
$foo
^<<<<<<<<<
$foo
^<<<<<<...
$foo
now @<<the@>>>> for all@|||||men to come @<<<<
{
'i' . 's', "time\n", $good, 'to'
}
.
open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
END { 1 while unlink 'Op_write.tmp' }
$fox = 'foxiness';
$good = 'good';
$multiline = "forescore\nand\nseven years\n";
$foo = 'when in the course of human events it becomes necessary';
write(OUT);
close OUT or die "Could not close: $!";
$right =
"the quick brown fox
jumped
forescore
and
seven years
when in
the course
of huma...
now is the time for all good men to come to\n";
if (cat('Op_write.tmp') eq $right)
{ print "ok 1\n"; 1 while unlink 'Op_write.tmp'; }
else
{ print "not ok 1\n"; }
$fox = 'wolfishness';
my $fox = 'foxiness'; # Test a lexical variable.
format OUT2 =
the quick brown @<<
$fox
jumped
@*
$multiline
^<<<<<<<<< ~~
$foo
now @<<the@>>>> for all@|||||men to come @<<<<
'i' . 's', "time\n", $good, 'to'
.
open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp";
$good = 'good';
$multiline = "forescore\nand\nseven years\n";
$foo = 'when in the course of human events it becomes necessary';
write(OUT2);
close OUT2 or die "Could not close: $!";
$right =
"the quick brown fox
jumped
forescore
and
seven years
when in
the course
of human
events it
becomes
necessary
now is the time for all good men to come to\n";
if (cat('Op_write.tmp') eq $right)
{ print "ok 2\n"; 1 while unlink 'Op_write.tmp'; }
else
{ print "not ok 2\n"; }
eval <<'EOFORMAT';
format OUT2 =
the brown quick @<<
$fox
jumped
@*
$multiline
and
^<<<<<<<<< ~~
$foo
now @<<the@>>>> for all@|||||men to come @<<<<
'i' . 's', "time\n", $good, 'to'
.
EOFORMAT
open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
$fox = 'foxiness';
$good = 'good';
$multiline = "forescore\nand\nseven years\n";
$foo = 'when in the course of human events it becomes necessary';
write(OUT2);
close OUT2 or die "Could not close: $!";
$right =
"the brown quick fox
jumped
forescore
and
seven years
and
when in
the course
of human
events it
becomes
necessary
now is the time for all good men to come to\n";
if (cat('Op_write.tmp') eq $right)
{ print "ok 3\n"; 1 while unlink 'Op_write.tmp'; }
else
{ print "not ok 3\n"; }
# formline tests
$mustbe = <<EOT;
@ a
@> ab
@>> abc
@>>> abc
@>>>> abc
@>>>>> abc
@>>>>>> abc
@>>>>>>> abc
@>>>>>>>> abc
@>>>>>>>>> abc
@>>>>>>>>>> abc
EOT
$was1 = $was2 = '';
for (0..10) {
# lexical picture
$^A = '';
my $format1 = '@' . '>' x $_;
formline $format1, 'abc';
$was1 .= "$format1 $^A\n";
# global
$^A = '';
local $format2 = '@' . '>' x $_;
formline $format2, 'abc';
$was2 .= "$format2 $^A\n";
}
print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n";
print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n";
$^A = '';
# more test
format OUT3 =
^<<<<<<...
$foo
.
open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp";
$foo = 'fit ';
write(OUT3);
close OUT3 or die "Could not close: $!";
$right =
"fit\n";
if (cat('Op_write.tmp') eq $right)
{ print "ok 6\n"; 1 while unlink 'Op_write.tmp'; }
else
{ print "not ok 6\n"; }
# test lexicals and globals
{
my $this = "ok";
our $that = 7;
format LEX =
@<<@|
$this,$that
.
open(LEX, ">&STDOUT") or die;
write LEX;
$that = 8;
write LEX;
close LEX or die "Could not close: $!";
}
# LEX_INTERPNORMAL test
my %e = ( a => 1 );
format OUT4 =
@<<<<<<
"$e{a}"
.
open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp";
write (OUT4);
close OUT4 or die "Could not close: $!";
if (cat('Op_write.tmp') eq "1\n") {
print "ok 9\n";
1 while unlink "Op_write.tmp";
}
else {
print "not ok 9\n";
}
eval <<'EOFORMAT';
format OUT10 =
@####.## @0###.##
$test1, $test1
.
EOFORMAT
open(OUT10, '>Op_write.tmp') || die "Can't create Op_write.tmp";
$test1 = 12.95;
write(OUT10);
close OUT10 or die "Could not close: $!";
$right = " 12.95 00012.95\n";
if (cat('Op_write.tmp') eq $right)
{ print "ok 10\n"; 1 while unlink 'Op_write.tmp'; }
else
{ print "not ok 10\n"; }
eval <<'EOFORMAT';
format OUT11 =
@0###.##
$test1
@ 0#
$test1
@0 #
$test1
.
EOFORMAT
open(OUT11, '>Op_write.tmp') || die "Can't create Op_write.tmp";
$test1 = 12.95;
write(OUT11);
close OUT11 or die "Could not close: $!";
$right =
"00012.95
1 0#
10 #\n";
if (cat('Op_write.tmp') eq $right)
{ print "ok 11\n"; 1 while unlink 'Op_write.tmp'; }
else
{ print "not ok 11\n"; }
{
our $el;
format OUT12 =
ok ^<<<<<<<<<<<<<<~~ # sv_chop() naze
$el
.
my %hash = (12 => 3);
open(OUT12, '>Op_write.tmp') || die "Can't create Op_write.tmp";
for $el (keys %hash) {
write(OUT12);
}
close OUT12 or die "Could not close: $!";
print cat('Op_write.tmp');
}
{
# Bug report and testcase by Alexey Tourbin
use Tie::Scalar;
my $v;
tie $v, 'Tie::StdScalar';
$v = 13;
format OUT13 =
ok ^<<<<<<<<< ~~
$v
.
open(OUT13, '>Op_write.tmp') || die "Can't create Op_write.tmp";
write(OUT13);
close OUT13 or die "Could not close: $!";
print cat('Op_write.tmp');
}
{ # test 14
# Bug #24774 format without trailing \n failed assertion, but this
# must fail since we have a trailing ; in the eval'ed string (WL)
my @v = ('k');
eval "format OUT14 = \n@\n\@v";
print +($@ && $@ =~ /Format not terminated/)
? "ok 14\n" : "not ok 14 $@\n";
}
{ # test 15
# text lost in ^<<< field with \r in value (WL)
my $txt = "line 1\rline 2";
format OUT15 =
^<<<<<<<<<<<<<<<<<<
$txt
^<<<<<<<<<<<<<<<<<<
$txt
.
open(OUT15, '>Op_write.tmp') || die "Can't create Op_write.tmp";
write(OUT15);
close OUT15 or die "Could not close: $!";
my $res = cat('Op_write.tmp');
print $res eq "line 1\nline 2\n" ? "ok 15\n" : "not ok 15\n";
}
{ # test 16: multiple use of a variable in same line with ^<
my $txt = "this_is_block_1 this_is_block_2 this_is_block_3 this_is_block_4";
format OUT16 =
^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
$txt, $txt
^<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<
$txt, $txt
.
open(OUT16, '>Op_write.tmp') || die "Can't create Op_write.tmp";
write(OUT16);
close OUT16 or die "Could not close: $!";
my $res = cat('Op_write.tmp');
print $res eq <<EOD ? "ok 16\n" : "not ok 16\n";
this_is_block_1 this_is_block_2
this_is_block_3 this_is_block_4
EOD
}
{ # test 17: @* "should be on a line of its own", but it should work
# cleanly with literals before and after. (WL)
my $txt = "This is line 1.\nThis is the second line.\nThird and last.\n";
format OUT17 =
Here we go: @* That's all, folks!
$txt
.
open(OUT17, '>Op_write.tmp') || die "Can't create Op_write.tmp";
write(OUT17);
close OUT17 or die "Could not close: $!";
my $res = cat('Op_write.tmp');
chomp( $txt );
my $exp = <<EOD;
Here we go: $txt That's all, folks!
EOD
print $res eq $exp ? "ok 17\n" : "not ok 17\n";
}
{ # test 18: @# and ~~ would cause runaway format, but we now
# catch this while compiling (WL)
format OUT18 =
@######## ~~
10
.
open(OUT18, '>Op_write.tmp') || die "Can't create Op_write.tmp";
eval { write(OUT18); };
print +($@ && $@ =~ /Repeated format line will never terminate/)
? "ok 18\n" : "not ok 18: $@\n";
close OUT18 or die "Could not close: $!";
}
{ # test 19: \0 in an evel'ed format, doesn't cause empty lines (WL)
my $v = 'gaga';
eval "format OUT19 = \n" .
'@<<<' . "\0\n" .
'$v' . "\n" .
'@<<<' . "\0\n" .
'$v' . "\n.\n";
open(OUT19, '>Op_write.tmp') || die "Can't create Op_write.tmp";
write(OUT19);
close OUT19 or die "Could not close: $!";
my $res = cat('Op_write.tmp');
print $res eq <<EOD ? "ok 19\n" : "not ok 19\n";
gaga\0
gaga\0
EOD
}
{ # test 20: hash accesses; single '}' must not terminate format '}' (WL)
my %h = ( xkey => 'xval', ykey => 'yval' );
format OUT20 =
@>>>> @<<<< ~~
each %h
@>>>> @<<<<
$h{xkey}, $h{ykey}
@>>>> @<<<<
{ $h{xkey}, $h{ykey}
}
}
.
my $exp = '';
while( my( $k, $v ) = each( %h ) ){
$exp .= sprintf( "%5s %s\n", $k, $v );
}
$exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
$exp .= sprintf( "%5s %s\n", $h{xkey}, $h{ykey} );
$exp .= "}\n";
open(OUT20, '>Op_write.tmp') || die "Can't create Op_write.tmp";
write(OUT20);
close OUT20 or die "Could not close: $!";
my $res = cat('Op_write.tmp');
print $res eq $exp ? "ok 20\n" : "not ok 20 res=[$res]exp=[$exp]\n";
}
#####################
## Section 2
## numeric formatting
#####################
my $nt = $bas_tests;
for my $tref ( @NumTests ){
my $writefmt = shift( @$tref );
while (@$tref) {
my $val = shift @$tref;
my $expected = shift @$tref;
my $writeres = swrite( $writefmt, $val );
$nt++;
my $ok = ref($expected)
? $writeres =~ $expected
: $writeres eq $expected;
print $ok
? "ok $nt - $writefmt\n"
: "not ok $nt\n# f=[$writefmt] exp=[$expected] got=[$writeres]\n";
}
}
#####################################
## Section 3
## Easiest to add new tests above here
#######################################
# scary format testing from H.Merijn Brand
my $test = $bas_tests + $num_tests + 1;
my $tests = $bas_tests + $num_tests + $hmb_tests;
if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' || $^O eq 'MacOS' ||
($^O eq 'os2' and not eval '$OS2::can_fork')) {
foreach ($test..$tests) {
print "ok $_ # skipped: '|-' and '-|' not supported\n";
}
exit(0);
}
use strict; # Amazed that this hackery can be made strict ...
# Just a complete test for format, including top-, left- and bottom marging
# and format detection through glob entries
format EMPTY =
.
format Comment =
ok @<<<<<
$test
.
# [ID 20020227.005] format bug with undefined _TOP
open STDOUT_DUP, ">&STDOUT";
my $oldfh = select STDOUT_DUP;
$= = 10;
{ local $~ = "Comment";
write;
$test++;
print $- == 9
? "ok $test # TODO\n" : "not ok $test # TODO \$- = $- instead of 9\n";
$test++;
print $^ eq "STDOUT_DUP_TOP"
? "ok $test\n" : "not ok $test\n# \$^ = $^ instead of 'STDOUT_DUP_TOP'\n";
$test++;
}
select $oldfh;
close STDOUT_DUP;
$^ = "STDOUT_TOP";
$= = 7; # Page length
$- = 0; # Lines left
my $ps = $^L; $^L = ""; # Catch the page separator
my $tm = 1; # Top margin (empty lines before first output)
my $bm = 2; # Bottom marging (empty lines between last text and footer)
my $lm = 4; # Left margin (indent in spaces)
# -----------------------------------------------------------------------
#
# execute the rest of the script in a child process. The parent reads the
# output from the child and compares it with <DATA>.
my @data = <DATA>;
select ((select (STDOUT), $| = 1)[0]); # flush STDOUT
my $opened = open FROM_CHILD, "-|";
unless (defined $opened) {
print "not ok $test - open gave $!\n"; exit 0;
}
if ($opened) {
# in parent here
print "ok $test - open\n"; $test++;
my $s = " " x $lm;
while (<FROM_CHILD>) {
unless (@data) {
print "not ok $test - too much output\n";
exit;
}
s/^/$s/;
my $exp = shift @data;
print + ($_ eq $exp ? "" : "not "), "ok ", $test++, " \n";
if ($_ ne $exp) {
s/\n/\\n/g for $_, $exp;
print "#expected: $exp\n#got: $_\n";
}
}
close FROM_CHILD;
print + (@data?"not ":""), "ok ", $test++, " - too litle output\n";
exit;
}
# in child here
select ((select (STDOUT), $| = 1)[0]);
$tm = "\n" x $tm;
$= -= $bm + 1; # count one for the trailing "----"
my $lastmin = 0;
my @E;
sub wryte
{
$lastmin = $-;
write;
} # wryte;
sub footer
{
$% == 1 and return "";
$lastmin < $= and print "\n" x $lastmin;
print "\n" x $bm, "----\n", $ps;
$lastmin = $-;
"";
} # footer
# Yes, this is sick ;-)
format TOP =
@* ~
@{[footer]}
@* ~
$tm
.
format ENTRY =
@ @<<<<~~
@{(shift @E)||["",""]}
.
format EOR =
- -----
.
sub has_format ($)
{
my $fmt = shift;
exists $::{$fmt} or return 0;
$^O eq "MSWin32" or return defined *{$::{$fmt}}{FORMAT};
open my $null, "> /dev/null" or die;
my $fh = select $null;
local $~ = $fmt;
eval "write";
select $fh;
$@?0:1;
} # has_format
$^ = has_format ("TOP") ? "TOP" : "EMPTY";
has_format ("ENTRY") or die "No format defined for ENTRY";
foreach my $e ( [ map { [ $_, "Test$_" ] } 1 .. 7 ],
[ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
@E = @$e;
local $~ = "ENTRY";
wryte;
has_format ("EOR") or next;
local $~ = "EOR";
wryte;
}
if (has_format ("EOF")) {
local $~ = "EOF";
wryte;
}
close STDOUT;
# That was test 48.
__END__
1 Test1
2 Test2
3 Test3
----
4 Test4
5 Test5
6 Test6
----
7 Test7
- -----
----
1 1tseT
2 2tseT
3 3tseT
----
4 4tseT
5 5tseT
- -----
--- NEW FILE: exists_sub.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
print "1..9\n";
sub t1;
sub t2 : locked;
sub t3 ();
sub t4 ($);
sub t5 {1;}
{
package P1;
sub tmc {1;}
package P2;
@ISA = 'P1';
}
print "not " unless exists &t1 && not defined &t1;
print "ok 1\n";
print "not " unless exists &t2 && not defined &t2;
print "ok 2\n";
print "not " unless exists &t3 && not defined &t3;
print "ok 3\n";
print "not " unless exists &t4 && not defined &t4;
print "ok 4\n";
print "not " unless exists &t5 && defined &t5;
print "ok 5\n";
P2::->tmc;
print "not " unless not exists &P2::tmc && not defined &P2::tmc;
print "ok 6\n";
my $ref;
$ref->{A}[0] = \&t4;
print "not " unless exists &{$ref->{A}[0]} && not defined &{$ref->{A}[0]};
print "ok 7\n";
undef &P1::tmc;
print "not " unless exists &P1::tmc && not defined &P1::tmc;
print "ok 8\n";
eval 'exists &t5()';
print "not " unless $@;
print "ok 9\n";
exit 0;
--- NEW FILE: subst_wamp.t ---
#!./perl
$dummy = defined $&; # Now we have it...
for $file ('op/subst.t', 't/op/subst.t', ':op:subst.t') {
if (-r $file) {
do ($^O eq 'MacOS' ? $file : "./$file");
exit;
}
}
die "Cannot find op/subst.t or t/op/subst.t\n";
--- NEW FILE: readline.t ---
#!./perl
BEGIN {
chdir 't';
@INC = '../lib';
require './test.pl';
}
plan tests => 13;
eval { for (\2) { $_ = <FH> } };
like($@, 'Modification of a read-only value attempted', '[perl #19566]');
{
open A,"+>a"; $a = 3;
is($a .= <A>, 3, '#21628 - $a .= <A> , A eof');
close A; $a = 4;
is($a .= <A>, 4, '#21628 - $a .= <A> , A closed');
unlink "a";
}
# 82 is chosen to exceed the length for sv_grow in do_readline (80)
foreach my $k (1, 82) {
my $result
= runperl (stdin => '', stderr => 1,
prog => "\$x = q(k) x $k; \$a{\$x} = qw(v); \$_ = <> foreach keys %a; print qw(end)",
);
$result =~ s/\n\z// if $^O eq 'VMS';
is ($result, "end", '[perl #21614] for length ' . length('k' x $k));
}
foreach my $k (1, 21) {
my $result
= runperl (stdin => ' rules', stderr => 1,
prog => "\$x = q(perl) x $k; \$a{\$x} = q(v); foreach (keys %a) {\$_ .= <>; print}",
);
$result =~ s/\n\z// if $^O eq 'VMS';
is ($result, ('perl' x $k) . " rules", 'rcatline to shared sv for length ' . length('perl' x $k));
}
# These COW tests are not going to show up anything on 5.8.x (No Copy On Write)
# but they do no harm, and it makes life easier to keep this file fully in
# sync with 5.9.x
foreach my $l (1, 82) {
my $k = $l;
$k = 'k' x $k;
my $copy = $k;
$k = <DATA>;
is ($k, "moo\n", 'catline to COW sv for length ' . length $copy);
}
foreach my $l (1, 21) {
my $k = $l;
$k = 'perl' x $k;
my $perl = $k;
$k .= <DATA>;
is ($k, "$perl rules\n", 'rcatline to COW sv for length ' . length $perl);
}
use strict;
use File::Spec;
open F, File::Spec->curdir and sysread F, $_, 1;
my $err = $! + 0;
close F;
SKIP: {
skip "you can read directories as plain files", 2 unless( $err );
$!=0;
open F, File::Spec->curdir and $_=<F>;
ok( $!==$err && !defined($_) => 'readline( DIRECTORY )' );
close F;
$!=0;
{ local $/;
open F, File::Spec->curdir and $_=<F>;
ok( $!==$err && !defined($_) => 'readline( DIRECTORY ) slurp mode' );
close F;
}
}
__DATA__
moo
moo
rules
rules
--- NEW FILE: re_tests ---
abc abc y $& abc
abc abc y $-[0] 0
abc abc y $+[0] 3
abc xbc n - -
abc axc n - -
abc abx n - -
abc xabcy y $& abc
abc xabcy y $-[0] 1
abc xabcy y $+[0] 4
abc ababc y $& abc
abc ababc y $-[0] 2
abc ababc y $+[0] 5
ab*c abc y $& abc
ab*c abc y $-[0] 0
ab*c abc y $+[0] 3
ab*bc abc y $& abc
ab*bc abc y $-[0] 0
ab*bc abc y $+[0] 3
ab*bc abbc y $& abbc
ab*bc abbc y $-[0] 0
ab*bc abbc y $+[0] 4
ab*bc abbbbc y $& abbbbc
ab*bc abbbbc y $-[0] 0
ab*bc abbbbc y $+[0] 6
.{1} abbbbc y $& a
.{1} abbbbc y $-[0] 0
.{1} abbbbc y $+[0] 1
.{3,4} abbbbc y $& abbb
.{3,4} abbbbc y $-[0] 0
.{3,4} abbbbc y $+[0] 4
ab{0,}bc abbbbc y $& abbbbc
ab{0,}bc abbbbc y $-[0] 0
ab{0,}bc abbbbc y $+[0] 6
ab+bc abbc y $& abbc
ab+bc abbc y $-[0] 0
ab+bc abbc y $+[0] 4
ab+bc abc n - -
ab+bc abq n - -
ab{1,}bc abq n - -
ab+bc abbbbc y $& abbbbc
ab+bc abbbbc y $-[0] 0
ab+bc abbbbc y $+[0] 6
ab{1,}bc abbbbc y $& abbbbc
ab{1,}bc abbbbc y $-[0] 0
ab{1,}bc abbbbc y $+[0] 6
ab{1,3}bc abbbbc y $& abbbbc
ab{1,3}bc abbbbc y $-[0] 0
ab{1,3}bc abbbbc y $+[0] 6
ab{3,4}bc abbbbc y $& abbbbc
ab{3,4}bc abbbbc y $-[0] 0
ab{3,4}bc abbbbc y $+[0] 6
ab{4,5}bc abbbbc n - -
ab?bc abbc y $& abbc
ab?bc abc y $& abc
ab{0,1}bc abc y $& abc
ab?bc abbbbc n - -
ab?c abc y $& abc
ab{0,1}c abc y $& abc
^abc$ abc y $& abc
^abc$ abcc n - -
^abc abcc y $& abc
^abc$ aabc n - -
abc$ aabc y $& abc
abc$ aabcd n - -
^ abc y $&
$ abc y $&
a.c abc y $& abc
a.c axc y $& axc
a.*c axyzc y $& axyzc
a.*c axyzd n - -
a[bc]d abc n - -
a[bc]d abd y $& abd
a[b-d]e abd n - -
a[b-d]e ace y $& ace
a[b-d] aac y $& ac
a[-b] a- y $& a-
a[b-] a- y $& a-
a[b-a] - c - Invalid [] range "b-a"
a[]b - c - Unmatched [
a[ - c - Unmatched [
a] a] y $& a]
a[]]b a]b y $& a]b
a[^bc]d aed y $& aed
a[^bc]d abd n - -
a[^-b]c adc y $& adc
a[^-b]c a-c n - -
a[^]b]c a]c n - -
a[^]b]c adc y $& adc
\ba\b a- y - -
\ba\b -a y - -
\ba\b -a- y - -
\by\b xy n - -
\by\b yz n - -
\by\b xyz n - -
\Ba\B a- n - -
\Ba\B -a n - -
\Ba\B -a- n - -
\By\b xy y - -
\By\b xy y $-[0] 1
\By\b xy y $+[0] 2
\By\b xy y - -
\by\B yz y - -
\By\B xyz y - -
\w a y - -
\w - n - -
\W a n - -
\W - y - -
a\sb a b y - -
a\sb a-b n - -
a\Sb a b n - -
a\Sb a-b y - -
\d 1 y - -
\d - n - -
\D 1 n - -
\D - y - -
[\w] a y - -
[\w] - n - -
[\W] a n - -
[\W] - y - -
a[\s]b a b y - -
a[\s]b a-b n - -
a[\S]b a b n - -
a[\S]b a-b y - -
[\d] 1 y - -
[\d] - n - -
[\D] 1 n - -
[\D] - y - -
ab|cd abc y $& ab
ab|cd abcd y $& ab
()ef def y $&-$1 ef-
()ef def y $-[0] 1
()ef def y $+[0] 3
()ef def y $-[1] 1
()ef def y $+[1] 1
*a - c - Quantifier follows nothing
(*)b - c - Quantifier follows nothing
$b b n - -
a\ - c - Search pattern not terminated
a\(b a(b y $&-$1 a(b-
a\(*b ab y $& ab
a\(*b a((b y $& a((b
a\\b a\b y $& a\b
abc) - c - Unmatched )
(abc - c - Unmatched (
((a)) abc y $&-$1-$2 a-a-a
((a)) abc y $-[0]-$-[1]-$-[2] 0-0-0
((a)) abc y $+[0]-$+[1]-$+[2] 1-1-1
((a)) abc b @- 0 0 0
((a)) abc b @+ 1 1 1
(a)b(c) abc y $&-$1-$2 abc-a-c
(a)b(c) abc y $-[0]-$-[1]-$-[2] 0-0-2
(a)b(c) abc y $+[0]-$+[1]-$+[2] 3-1-3
a+b+c aabbabc y $& abc
a{1,}b{1,}c aabbabc y $& abc
a** - c - Nested quantifiers
a.+?c abcabc y $& abc
(a+|b)* ab y $&-$1 ab-b
(a+|b)* ab y $-[0] 0
(a+|b)* ab y $+[0] 2
(a+|b)* ab y $-[1] 1
(a+|b)* ab y $+[1] 2
(a+|b){0,} ab y $&-$1 ab-b
(a+|b)+ ab y $&-$1 ab-b
(a+|b){1,} ab y $&-$1 ab-b
(a+|b)? ab y $&-$1 a-a
(a+|b){0,1} ab y $&-$1 a-a
)( - c - Unmatched )
[^ab]* cde y $& cde
abc n - -
a* y $&
([abc])*d abbbcd y $&-$1 abbbcd-c
([abc])*bcd abcd y $&-$1 abcd-a
a|b|c|d|e e y $& e
(a|b|c|d|e)f ef y $&-$1 ef-e
(a|b|c|d|e)f ef y $-[0] 0
(a|b|c|d|e)f ef y $+[0] 2
(a|b|c|d|e)f ef y $-[1] 0
(a|b|c|d|e)f ef y $+[1] 1
abcd*efg abcdefg y $& abcdefg
ab* xabyabbbz y $& ab
ab* xayabbbz y $& a
(ab|cd)e abcde y $&-$1 cde-cd
[abhgefdc]ij hij y $& hij
^(ab|cd)e abcde n x$1y xy
(abc|)ef abcdef y $&-$1 ef-
(a|b)c*d abcd y $&-$1 bcd-b
(ab|ab*)bc abc y $&-$1 abc-a
a([bc]*)c* abc y $&-$1 abc-bc
a([bc]*)(c*d) abcd y $&-$1-$2 abcd-bc-d
a([bc]*)(c*d) abcd y $-[0] 0
a([bc]*)(c*d) abcd y $+[0] 4
a([bc]*)(c*d) abcd y $-[1] 1
a([bc]*)(c*d) abcd y $+[1] 3
a([bc]*)(c*d) abcd y $-[2] 3
a([bc]*)(c*d) abcd y $+[2] 4
a([bc]+)(c*d) abcd y $&-$1-$2 abcd-bc-d
a([bc]*)(c+d) abcd y $&-$1-$2 abcd-b-cd
a([bc]*)(c+d) abcd y $-[0] 0
a([bc]*)(c+d) abcd y $+[0] 4
a([bc]*)(c+d) abcd y $-[1] 1
a([bc]*)(c+d) abcd y $+[1] 2
a([bc]*)(c+d) abcd y $-[2] 2
a([bc]*)(c+d) abcd y $+[2] 4
a[bcd]*dcdcde adcdcde y $& adcdcde
a[bcd]+dcdcde adcdcde n - -
(ab|a)b*c abc y $&-$1 abc-ab
(ab|a)b*c abc y $-[0] 0
(ab|a)b*c abc y $+[0] 3
(ab|a)b*c abc y $-[1] 0
(ab|a)b*c abc y $+[1] 2
((a)(b)c)(d) abcd y $1-$2-$3-$4 abc-a-b-d
((a)(b)c)(d) abcd y $-[0] 0
((a)(b)c)(d) abcd y $+[0] 4
((a)(b)c)(d) abcd y $-[1] 0
((a)(b)c)(d) abcd y $+[1] 3
((a)(b)c)(d) abcd y $-[2] 0
((a)(b)c)(d) abcd y $+[2] 1
((a)(b)c)(d) abcd y $-[3] 1
((a)(b)c)(d) abcd y $+[3] 2
((a)(b)c)(d) abcd y $-[4] 3
((a)(b)c)(d) abcd y $+[4] 4
[a-zA-Z_][a-zA-Z0-9_]* alpha y $& alpha
^a(bc+|b[eh])g|.h$ abh y $&-$1 bh-
(bc+d$|ef*g.|h?i(j|k)) effgz y $&-$1-$2 effgz-effgz-
(bc+d$|ef*g.|h?i(j|k)) ij y $&-$1-$2 ij-ij-j
(bc+d$|ef*g.|h?i(j|k)) effg n - -
(bc+d$|ef*g.|h?i(j|k)) bcdd n - -
(bc+d$|ef*g.|h?i(j|k)) reffgz y $&-$1-$2 effgz-effgz-
((((((((((a)))))))))) a y $10 a
((((((((((a)))))))))) a y $-[0] 0
((((((((((a)))))))))) a y $+[0] 1
((((((((((a)))))))))) a y $-[10] 0
((((((((((a)))))))))) a y $+[10] 1
((((((((((a))))))))))\10 aa y $& aa
((((((((((a))))))))))${bang} aa n - -
((((((((((a))))))))))${bang} a! y $& a!
(((((((((a))))))))) a y $& a
multiple words of text uh-uh n - -
multiple words multiple words, yeah y $& multiple words
(.*)c(.*) abcde y $&-$1-$2 abcde-ab-de
\((.*), (.*)\) (a, b) y ($2, $1) (b, a)
[k] ab n - -
abcd abcd y $&-\$&-\\$& abcd-$&-\abcd
a(bc)d abcd y $1-\$1-\\$1 bc-$1-\bc
a[-]?c ac y $& ac
(abc)\1 abcabc y $1 abc
([a-c]*)\1 abcabc y $1 abc
\1 - c - Reference to nonexistent group
\2 - c - Reference to nonexistent group
(a)|\1 a y - -
(a)|\1 x n - -
(a)|\2 - c - Reference to nonexistent group
(([a-c])b*?\2)* ababbbcbc y $&-$1-$2 ababb-bb-b
(([a-c])b*?\2){3} ababbbcbc y $&-$1-$2 ababbbcbc-cbc-c
((\3|b)\2(a)x)+ aaxabxbaxbbx n - -
((\3|b)\2(a)x)+ aaaxabaxbaaxbbax y $&-$1-$2-$3 bbax-bbax-b-a
((\3|b)\2(a)){2,} bbaababbabaaaaabbaaaabba y $&-$1-$2-$3 bbaaaabba-bba-b-a
(a)|(b) b y $-[0] 0
(a)|(b) b y $+[0] 1
(a)|(b) b y x$-[1] x
(a)|(b) b y x$+[1] x
(a)|(b) b y $-[2] 0
(a)|(b) b y $+[2] 1
'abc'i ABC y $& ABC
'abc'i XBC n - -
'abc'i AXC n - -
'abc'i ABX n - -
'abc'i XABCY y $& ABC
'abc'i ABABC y $& ABC
'ab*c'i ABC y $& ABC
'ab*bc'i ABC y $& ABC
'ab*bc'i ABBC y $& ABBC
'ab*?bc'i ABBBBC y $& ABBBBC
'ab{0,}?bc'i ABBBBC y $& ABBBBC
'ab+?bc'i ABBC y $& ABBC
'ab+bc'i ABC n - -
'ab+bc'i ABQ n - -
'ab{1,}bc'i ABQ n - -
'ab+bc'i ABBBBC y $& ABBBBC
'ab{1,}?bc'i ABBBBC y $& ABBBBC
'ab{1,3}?bc'i ABBBBC y $& ABBBBC
'ab{3,4}?bc'i ABBBBC y $& ABBBBC
'ab{4,5}?bc'i ABBBBC n - -
'ab??bc'i ABBC y $& ABBC
'ab??bc'i ABC y $& ABC
'ab{0,1}?bc'i ABC y $& ABC
'ab??bc'i ABBBBC n - -
'ab??c'i ABC y $& ABC
'ab{0,1}?c'i ABC y $& ABC
'^abc$'i ABC y $& ABC
'^abc$'i ABCC n - -
'^abc'i ABCC y $& ABC
'^abc$'i AABC n - -
'abc$'i AABC y $& ABC
'^'i ABC y $&
'$'i ABC y $&
'a.c'i ABC y $& ABC
'a.c'i AXC y $& AXC
'a.*?c'i AXYZC y $& AXYZC
'a.*c'i AXYZD n - -
'a[bc]d'i ABC n - -
'a[bc]d'i ABD y $& ABD
'a[b-d]e'i ABD n - -
'a[b-d]e'i ACE y $& ACE
'a[b-d]'i AAC y $& AC
'a[-b]'i A- y $& A-
'a[b-]'i A- y $& A-
'a[b-a]'i - c - Invalid [] range "b-a"
'a[]b'i - c - Unmatched [
'a['i - c - Unmatched [
'a]'i A] y $& A]
'a[]]b'i A]B y $& A]B
'a[^bc]d'i AED y $& AED
'a[^bc]d'i ABD n - -
'a[^-b]c'i ADC y $& ADC
'a[^-b]c'i A-C n - -
'a[^]b]c'i A]C n - -
'a[^]b]c'i ADC y $& ADC
'ab|cd'i ABC y $& AB
'ab|cd'i ABCD y $& AB
'()ef'i DEF y $&-$1 EF-
'*a'i - c - Quantifier follows nothing
'(*)b'i - c - Quantifier follows nothing
'$b'i B n - -
'a\'i - c - Search pattern not terminated
'a\(b'i A(B y $&-$1 A(B-
'a\(*b'i AB y $& AB
'a\(*b'i A((B y $& A((B
'a\\b'i A\B y $& A\B
'abc)'i - c - Unmatched )
'(abc'i - c - Unmatched (
'((a))'i ABC y $&-$1-$2 A-A-A
'(a)b(c)'i ABC y $&-$1-$2 ABC-A-C
'a+b+c'i AABBABC y $& ABC
'a{1,}b{1,}c'i AABBABC y $& ABC
'a**'i - c - Nested quantifiers
'a.+?c'i ABCABC y $& ABC
'a.*?c'i ABCABC y $& ABC
'a.{0,5}?c'i ABCABC y $& ABC
'(a+|b)*'i AB y $&-$1 AB-B
'(a+|b){0,}'i AB y $&-$1 AB-B
'(a+|b)+'i AB y $&-$1 AB-B
'(a+|b){1,}'i AB y $&-$1 AB-B
'(a+|b)?'i AB y $&-$1 A-A
'(a+|b){0,1}'i AB y $&-$1 A-A
'(a+|b){0,1}?'i AB y $&-$1 -
')('i - c - Unmatched )
'[^ab]*'i CDE y $& CDE
'abc'i n - -
'a*'i y $&
'([abc])*d'i ABBBCD y $&-$1 ABBBCD-C
'([abc])*bcd'i ABCD y $&-$1 ABCD-A
'a|b|c|d|e'i E y $& E
'(a|b|c|d|e)f'i EF y $&-$1 EF-E
'abcd*efg'i ABCDEFG y $& ABCDEFG
'ab*'i XABYABBBZ y $& AB
'ab*'i XAYABBBZ y $& A
'(ab|cd)e'i ABCDE y $&-$1 CDE-CD
'[abhgefdc]ij'i HIJ y $& HIJ
'^(ab|cd)e'i ABCDE n x$1y XY
'(abc|)ef'i ABCDEF y $&-$1 EF-
'(a|b)c*d'i ABCD y $&-$1 BCD-B
'(ab|ab*)bc'i ABC y $&-$1 ABC-A
'a([bc]*)c*'i ABC y $&-$1 ABC-BC
'a([bc]*)(c*d)'i ABCD y $&-$1-$2 ABCD-BC-D
'a([bc]+)(c*d)'i ABCD y $&-$1-$2 ABCD-BC-D
'a([bc]*)(c+d)'i ABCD y $&-$1-$2 ABCD-B-CD
'a[bcd]*dcdcde'i ADCDCDE y $& ADCDCDE
'a[bcd]+dcdcde'i ADCDCDE n - -
'(ab|a)b*c'i ABC y $&-$1 ABC-AB
'((a)(b)c)(d)'i ABCD y $1-$2-$3-$4 ABC-A-B-D
'[a-zA-Z_][a-zA-Z0-9_]*'i ALPHA y $& ALPHA
'^a(bc+|b[eh])g|.h$'i ABH y $&-$1 BH-
'(bc+d$|ef*g.|h?i(j|k))'i EFFGZ y $&-$1-$2 EFFGZ-EFFGZ-
'(bc+d$|ef*g.|h?i(j|k))'i IJ y $&-$1-$2 IJ-IJ-J
'(bc+d$|ef*g.|h?i(j|k))'i EFFG n - -
'(bc+d$|ef*g.|h?i(j|k))'i BCDD n - -
'(bc+d$|ef*g.|h?i(j|k))'i REFFGZ y $&-$1-$2 EFFGZ-EFFGZ-
'((((((((((a))))))))))'i A y $10 A
'((((((((((a))))))))))\10'i AA y $& AA
'((((((((((a))))))))))${bang}'i AA n - -
'((((((((((a))))))))))${bang}'i A! y $& A!
'(((((((((a)))))))))'i A y $& A
'(?:(?:(?:(?:(?:(?:(?:(?:(?:(a))))))))))'i A y $1 A
'(?:(?:(?:(?:(?:(?:(?:(?:(?:(a|b|c))))))))))'i C y $1 C
'multiple words of text'i UH-UH n - -
'multiple words'i MULTIPLE WORDS, YEAH y $& MULTIPLE WORDS
'(.*)c(.*)'i ABCDE y $&-$1-$2 ABCDE-AB-DE
'\((.*), (.*)\)'i (A, B) y ($2, $1) (B, A)
'[k]'i AB n - -
'abcd'i ABCD y $&-\$&-\\$& ABCD-$&-\ABCD
'a(bc)d'i ABCD y $1-\$1-\\$1 BC-$1-\BC
'a[-]?c'i AC y $& AC
'(abc)\1'i ABCABC y $1 ABC
'([a-c]*)\1'i ABCABC y $1 ABC
a(?!b). abad y $& ad
a(?=d). abad y $& ad
a(?=c|d). abad y $& ad
a(?:b|c|d)(.) ace y $1 e
a(?:b|c|d)*(.) ace y $1 e
a(?:b|c|d)+?(.) ace y $1 e
a(?:b|c|d)+?(.) acdbcdbe y $1 d
a(?:b|c|d)+(.) acdbcdbe y $1 e
a(?:b|c|d){2}(.) acdbcdbe y $1 b
a(?:b|c|d){4,5}(.) acdbcdbe y $1 b
a(?:b|c|d){4,5}?(.) acdbcdbe y $1 d
((foo)|(bar))* foobar y $1-$2-$3 bar-foo-bar
:(?: - c - Sequence (? incomplete
a(?:b|c|d){6,7}(.) acdbcdbe y $1 e
a(?:b|c|d){6,7}?(.) acdbcdbe y $1 e
a(?:b|c|d){5,6}(.) acdbcdbe y $1 e
a(?:b|c|d){5,6}?(.) acdbcdbe y $1 b
a(?:b|c|d){5,7}(.) acdbcdbe y $1 e
a(?:b|c|d){5,7}?(.) acdbcdbe y $1 b
a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce
^(.+)?B AB y $1 A
^([^a-z])|(\^)$ . y $1 .
^[<>]& <&OUT y $& <&
^(a\1?){4}$ aaaaaaaaaa y $1 aaaa
^(a\1?){4}$ aaaaaaaaa n - -
^(a\1?){4}$ aaaaaaaaaaa n - -
^(a(?(1)\1)){4}$ aaaaaaaaaa y $1 aaaa
^(a(?(1)\1)){4}$ aaaaaaaaa n - -
^(a(?(1)\1)){4}$ aaaaaaaaaaa n - -
((a{4})+) aaaaaaaaa y $1 aaaaaaaa
(((aa){2})+) aaaaaaaaaa y $1 aaaaaaaa
(((a{2}){2})+) aaaaaaaaaa y $1 aaaaaaaa
(?:(f)(o)(o)|(b)(a)(r))* foobar y $1:$2:$3:$4:$5:$6 f:o:o:b:a:r
(?<=a)b ab y $& b
(?<=a)b cb n - -
(?<=a)b b n - -
(?<!c)b ab y $& b
(?<!c)b cb n - -
(?<!c)b b y - -
(?<!c)b b y $& b
(?<%)b - c - Sequence (?<%...) not recognized
(?:..)*a aba y $& aba
(?:..)*?a aba y $& a
^(?:b|a(?=(.)))*\1 abc y $& ab
^(){3,5} abc y a$1 a
^(a+)*ax aax y $1 a
^((a|b)+)*ax aax y $1 a
^((a|bc)+)*ax aax y $1 a
(a|x)*ab cab y y$1 y
(a)*ab cab y y$1 y
(?:(?i)a)b ab y $& ab
((?i)a)b ab y $&:$1 ab:a
(?:(?i)a)b Ab y $& Ab
((?i)a)b Ab y $&:$1 Ab:A
(?:(?i)a)b aB n - -
((?i)a)b aB n - -
(?i:a)b ab y $& ab
((?i:a))b ab y $&:$1 ab:a
(?i:a)b Ab y $& Ab
((?i:a))b Ab y $&:$1 Ab:A
(?i:a)b aB n - -
((?i:a))b aB n - -
'(?:(?-i)a)b'i ab y $& ab
'((?-i)a)b'i ab y $&:$1 ab:a
'(?:(?-i)a)b'i aB y $& aB
'((?-i)a)b'i aB y $&:$1 aB:a
'(?:(?-i)a)b'i Ab n - -
'((?-i)a)b'i Ab n - -
'(?:(?-i)a)b'i aB y $& aB
'((?-i)a)b'i aB y $1 a
'(?:(?-i)a)b'i AB n - -
'((?-i)a)b'i AB n - -
'(?-i:a)b'i ab y $& ab
'((?-i:a))b'i ab y $&:$1 ab:a
'(?-i:a)b'i aB y $& aB
'((?-i:a))b'i aB y $&:$1 aB:a
'(?-i:a)b'i Ab n - -
'((?-i:a))b'i Ab n - -
'(?-i:a)b'i aB y $& aB
'((?-i:a))b'i aB y $1 a
'(?-i:a)b'i AB n - -
'((?-i:a))b'i AB n - -
'((?-i:a.))b'i a\nB n - -
'((?s-i:a.))b'i a\nB y $1 a\n
'((?s-i:a.))b'i B\nB n - -
(?:c|d)(?:)(?:a(?:)(?:b)(?:b(?:))(?:b(?:)(?:b))) cabbbb y $& cabbbb
(?:c|d)(?:)(?:aaaaaaaa(?:)(?:bbbbbbbb)(?:bbbbbbbb(?:))(?:bbbbbbbb(?:)(?:bbbbbbbb))) caaaaaaaabbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb y $& caaaaaaaabbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
'(ab)\d\1'i Ab4ab y $1 Ab
'(ab)\d\1'i ab4Ab y $1 ab
foo\w*\d{4}baz foobar1234baz y $& foobar1234baz
a(?{})b cabd y $& ab
a(?{)b - c - Sequence (?{...}) not terminated or not {}-balanced
a(?{{})b - c - Sequence (?{...}) not terminated or not {}-balanced
a(?{}})b - c -
a(?{"{"})b - c - Sequence (?{...}) not terminated or not {}-balanced
a(?{"\{"})b cabd y $& ab
a(?{"{"}})b - c - Unmatched right curly bracket
a(?{$bl="\{"}).b caxbd y $bl {
x(~~)*(?:(?:F)?)? x~~ y - -
^a(?#xxx){3}c aaac y $& aaac
'^a (?#xxx) (?#yyy) {3}c'x aaac y $& aaac
(?<![cd])b dbcb n - -
(?<![cd])[ab] dbaacb y $& a
(?<!(c|d))b dbcb n - -
(?<!(c|d))[ab] dbaacb y $& a
(?<!cd)[ab] cdaccb y $& b
^(?:a?b?)*$ a-- n - -
((?s)^a(.))((?m)^b$) a\nb\nc\n y $1;$2;$3 a\n;\n;b
((?m)^b$) a\nb\nc\n y $1 b
(?m)^b a\nb\n y $& b
(?m)^(b) a\nb\n y $1 b
((?m)^b) a\nb\n y $1 b
\n((?m)^b) a\nb\n y $1 b
((?s).)c(?!.) a\nb\nc\n y $1 \n
((?s).)c(?!.) a\nb\nc\n y $1:$& \n:\nc
((?s)b.)c(?!.) a\nb\nc\n y $1 b\n
((?s)b.)c(?!.) a\nb\nc\n y $1:$& b\n:b\nc
^b a\nb\nc\n n - -
()^b a\nb\nc\n n - -
((?m)^b) a\nb\nc\n y $1 b
(?(1)a|b) a n - -
(?(1)b|a) a y $& a
(x)?(?(1)a|b) a n - -
(x)?(?(1)b|a) a y $& a
()?(?(1)b|a) a y $& a
()(?(1)b|a) a n - -
()?(?(1)a|b) a y $& a
^(\()?blah(?(1)(\)))$ (blah) y $2 )
^(\()?blah(?(1)(\)))$ blah y ($2) ()
^(\()?blah(?(1)(\)))$ blah) n - -
^(\()?blah(?(1)(\)))$ (blah n - -
^(\(+)?blah(?(1)(\)))$ (blah) y $2 )
^(\(+)?blah(?(1)(\)))$ blah y ($2) ()
^(\(+)?blah(?(1)(\)))$ blah) n - -
^(\(+)?blah(?(1)(\)))$ (blah n - -
(?(1?)a|b) a c - Switch condition not recognized
(?(1)a|b|c) a c - Switch (?(condition)... contains too many branches
(?(?{0})a|b) a n - -
(?(?{0})b|a) a y $& a
(?(?{1})b|a) a n - -
(?(?{1})a|b) a y $& a
(?(?!a)a|b) a n - -
(?(?!a)b|a) a y $& a
(?(?=a)b|a) a n - -
(?(?=a)a|b) a y $& a
(?=(a+?))(\1ab) aaab y $2 aab
^(?=(a+?))\1ab aaab n - -
(\w+:)+ one: y $1 one:
$(?<=^(a)) a y $1 a
(?=(a+?))(\1ab) aaab y $2 aab
^(?=(a+?))\1ab aaab n - -
([\w:]+::)?(\w+)$ abcd: n - -
([\w:]+::)?(\w+)$ abcd y $1-$2 -abcd
([\w:]+::)?(\w+)$ xy:z:::abcd y $1-$2 xy:z:::-abcd
^[^bcd]*(c+) aexycd y $1 c
(a*)b+ caab y $1 aa
([\w:]+::)?(\w+)$ abcd: n - -
([\w:]+::)?(\w+)$ abcd y $1-$2 -abcd
([\w:]+::)?(\w+)$ xy:z:::abcd y $1-$2 xy:z:::-abcd
^[^bcd]*(c+) aexycd y $1 c
(?{$a=2})a*aa(?{local$a=$a+1})k*c(?{$b=$a}) yaaxxaaaacd y $b 3
(?{$a=2})(a(?{local$a=$a+1}))*aak*c(?{$b=$a}) yaaxxaaaacd y $b 4
(>a+)ab aaab n - -
(?>a+)b aaab y - -
([[:]+) a:[b]: y $1 :[
([[=]+) a=[b]= y $1 =[
([[.]+) a.[b]. y $1 .[
[a[:xyz: - c - Unmatched [
[a[:xyz:] - c - POSIX class [:xyz:] unknown
[a[:]b[:c] abc y $& abc
([a[:xyz:]b]+) pbaq c - POSIX class [:xyz:] unknown
[a[:]b[:c] abc y $& abc
([[:alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd
([[:alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy
([[:ascii:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- ${nulnul}
([[:cntrl:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${nulnul}
([[:digit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 01
([[:graph:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__--
([[:lower:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 cd
([[:print:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__--
([[:punct:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 __--
([[:space:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1
([[:word:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__
([[:upper:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 AB
([[:xdigit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01
([[:^alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 01
([[:^alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 __-- ${nulnul}${ffff}
([[:^ascii:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${ffff}
([[:^cntrl:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__--
([[:^digit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd
([[:^lower:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 AB
([[:^print:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${nulnul}${ffff}
([[:^punct:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy
([[:^space:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__--
([[:^word:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 -- ${nulnul}${ffff}
([[:^upper:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 cd01
([[:^xdigit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 Xy__-- ${nulnul}${ffff}
[[:foo:]] - c - POSIX class [:foo:] unknown
[[:^foo:]] - c - POSIX class [:^foo:] unknown
((?>a+)b) aaab y $1 aaab
(?>(a+))b aaab y $1 aaa
((?>[^()]+)|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x
(?<=x+)y - c - Variable length lookbehind not implemented
a{37,17} - c - Can't do {n,m} with n > m
\Z a\nb\n y $-[0] 3
\z a\nb\n y $-[0] 4
$ a\nb\n y $-[0] 3
\Z b\na\n y $-[0] 3
\z b\na\n y $-[0] 4
$ b\na\n y $-[0] 3
\Z b\na y $-[0] 3
\z b\na y $-[0] 3
$ b\na y $-[0] 3
'\Z'm a\nb\n y $-[0] 3
'\z'm a\nb\n y $-[0] 4
'$'m a\nb\n y $-[0] 1
'\Z'm b\na\n y $-[0] 3
'\z'm b\na\n y $-[0] 4
'$'m b\na\n y $-[0] 1
'\Z'm b\na y $-[0] 3
'\z'm b\na y $-[0] 3
'$'m b\na y $-[0] 1
a\Z a\nb\n n - -
a\z a\nb\n n - -
a$ a\nb\n n - -
a\Z b\na\n y $-[0] 2
a\z b\na\n n - -
a$ b\na\n y $-[0] 2
a\Z b\na y $-[0] 2
a\z b\na y $-[0] 2
a$ b\na y $-[0] 2
'a\Z'm a\nb\n n - -
'a\z'm a\nb\n n - -
'a$'m a\nb\n y $-[0] 0
'a\Z'm b\na\n y $-[0] 2
'a\z'm b\na\n n - -
'a$'m b\na\n y $-[0] 2
'a\Z'm b\na y $-[0] 2
'a\z'm b\na y $-[0] 2
'a$'m b\na y $-[0] 2
aa\Z aa\nb\n n - -
aa\z aa\nb\n n - -
aa$ aa\nb\n n - -
aa\Z b\naa\n y $-[0] 2
aa\z b\naa\n n - -
aa$ b\naa\n y $-[0] 2
aa\Z b\naa y $-[0] 2
aa\z b\naa y $-[0] 2
aa$ b\naa y $-[0] 2
'aa\Z'm aa\nb\n n - -
'aa\z'm aa\nb\n n - -
'aa$'m aa\nb\n y $-[0] 0
'aa\Z'm b\naa\n y $-[0] 2
'aa\z'm b\naa\n n - -
'aa$'m b\naa\n y $-[0] 2
'aa\Z'm b\naa y $-[0] 2
'aa\z'm b\naa y $-[0] 2
'aa$'m b\naa y $-[0] 2
aa\Z ac\nb\n n - -
aa\z ac\nb\n n - -
aa$ ac\nb\n n - -
aa\Z b\nac\n n - -
aa\z b\nac\n n - -
aa$ b\nac\n n - -
aa\Z b\nac n - -
aa\z b\nac n - -
aa$ b\nac n - -
'aa\Z'm ac\nb\n n - -
'aa\z'm ac\nb\n n - -
'aa$'m ac\nb\n n - -
'aa\Z'm b\nac\n n - -
'aa\z'm b\nac\n n - -
'aa$'m b\nac\n n - -
'aa\Z'm b\nac n - -
'aa\z'm b\nac n - -
'aa$'m b\nac n - -
aa\Z ca\nb\n n - -
aa\z ca\nb\n n - -
aa$ ca\nb\n n - -
aa\Z b\nca\n n - -
aa\z b\nca\n n - -
aa$ b\nca\n n - -
aa\Z b\nca n - -
aa\z b\nca n - -
aa$ b\nca n - -
'aa\Z'm ca\nb\n n - -
'aa\z'm ca\nb\n n - -
'aa$'m ca\nb\n n - -
'aa\Z'm b\nca\n n - -
'aa\z'm b\nca\n n - -
'aa$'m b\nca\n n - -
'aa\Z'm b\nca n - -
'aa\z'm b\nca n - -
'aa$'m b\nca n - -
ab\Z ab\nb\n n - -
ab\z ab\nb\n n - -
ab$ ab\nb\n n - -
ab\Z b\nab\n y $-[0] 2
ab\z b\nab\n n - -
ab$ b\nab\n y $-[0] 2
ab\Z b\nab y $-[0] 2
ab\z b\nab y $-[0] 2
ab$ b\nab y $-[0] 2
'ab\Z'm ab\nb\n n - -
'ab\z'm ab\nb\n n - -
'ab$'m ab\nb\n y $-[0] 0
'ab\Z'm b\nab\n y $-[0] 2
'ab\z'm b\nab\n n - -
'ab$'m b\nab\n y $-[0] 2
'ab\Z'm b\nab y $-[0] 2
'ab\z'm b\nab y $-[0] 2
'ab$'m b\nab y $-[0] 2
ab\Z ac\nb\n n - -
ab\z ac\nb\n n - -
ab$ ac\nb\n n - -
ab\Z b\nac\n n - -
ab\z b\nac\n n - -
ab$ b\nac\n n - -
ab\Z b\nac n - -
ab\z b\nac n - -
ab$ b\nac n - -
'ab\Z'm ac\nb\n n - -
'ab\z'm ac\nb\n n - -
'ab$'m ac\nb\n n - -
'ab\Z'm b\nac\n n - -
'ab\z'm b\nac\n n - -
'ab$'m b\nac\n n - -
'ab\Z'm b\nac n - -
'ab\z'm b\nac n - -
'ab$'m b\nac n - -
ab\Z ca\nb\n n - -
ab\z ca\nb\n n - -
ab$ ca\nb\n n - -
ab\Z b\nca\n n - -
ab\z b\nca\n n - -
ab$ b\nca\n n - -
ab\Z b\nca n - -
ab\z b\nca n - -
ab$ b\nca n - -
'ab\Z'm ca\nb\n n - -
'ab\z'm ca\nb\n n - -
'ab$'m ca\nb\n n - -
'ab\Z'm b\nca\n n - -
'ab\z'm b\nca\n n - -
'ab$'m b\nca\n n - -
'ab\Z'm b\nca n - -
'ab\z'm b\nca n - -
'ab$'m b\nca n - -
abb\Z abb\nb\n n - -
abb\z abb\nb\n n - -
abb$ abb\nb\n n - -
abb\Z b\nabb\n y $-[0] 2
abb\z b\nabb\n n - -
abb$ b\nabb\n y $-[0] 2
abb\Z b\nabb y $-[0] 2
abb\z b\nabb y $-[0] 2
abb$ b\nabb y $-[0] 2
'abb\Z'm abb\nb\n n - -
'abb\z'm abb\nb\n n - -
'abb$'m abb\nb\n y $-[0] 0
'abb\Z'm b\nabb\n y $-[0] 2
'abb\z'm b\nabb\n n - -
'abb$'m b\nabb\n y $-[0] 2
'abb\Z'm b\nabb y $-[0] 2
'abb\z'm b\nabb y $-[0] 2
'abb$'m b\nabb y $-[0] 2
abb\Z ac\nb\n n - -
abb\z ac\nb\n n - -
abb$ ac\nb\n n - -
abb\Z b\nac\n n - -
abb\z b\nac\n n - -
abb$ b\nac\n n - -
abb\Z b\nac n - -
abb\z b\nac n - -
abb$ b\nac n - -
'abb\Z'm ac\nb\n n - -
'abb\z'm ac\nb\n n - -
'abb$'m ac\nb\n n - -
'abb\Z'm b\nac\n n - -
'abb\z'm b\nac\n n - -
'abb$'m b\nac\n n - -
'abb\Z'm b\nac n - -
'abb\z'm b\nac n - -
'abb$'m b\nac n - -
abb\Z ca\nb\n n - -
abb\z ca\nb\n n - -
abb$ ca\nb\n n - -
abb\Z b\nca\n n - -
abb\z b\nca\n n - -
abb$ b\nca\n n - -
abb\Z b\nca n - -
abb\z b\nca n - -
abb$ b\nca n - -
'abb\Z'm ca\nb\n n - -
'abb\z'm ca\nb\n n - -
'abb$'m ca\nb\n n - -
'abb\Z'm b\nca\n n - -
'abb\z'm b\nca\n n - -
'abb$'m b\nca\n n - -
'abb\Z'm b\nca n - -
'abb\z'm b\nca n - -
'abb$'m b\nca n - -
(^|x)(c) ca y $2 c
a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz x n - -
a(?{$a=2;$b=3;($b)=$a})b yabz y $b 2
round\(((?>[^()]+))\) _I(round(xs * sz),1) y $1 xs * sz
'((?x:.) )' x y $1- x -
'((?-x:.) )'x x y $1- x-
foo.bart foo.bart y - -
'^d[x][x][x]'m abcd\ndxxx y - -
.X(.+)+X bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
.X(.+)+XX bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
.XX(.+)+X bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
.X(.+)+X bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
.X(.+)+XX bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
.XX(.+)+X bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
.X(.+)+[X] bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
.X(.+)+[X][X] bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
.XX(.+)+[X] bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
.X(.+)+[X] bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
.X(.+)+[X][X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
.XX(.+)+[X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
.[X](.+)+[X] bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
.[X](.+)+[X][X] bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
.[X][X](.+)+[X] bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - -
.[X](.+)+[X] bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
.[X](.+)+[X][X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
.[X][X](.+)+[X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - -
tt+$ xxxtt y - -
([a-\d]+) za-9z y $1 a-9
([\d-z]+) a0-za y $1 0-z
([\d-\s]+) a0- z y $1 0-
([a-[:digit:]]+) za-9z y $1 a-9
([[:digit:]-z]+) =0-z= y $1 0-z
([[:digit:]-[:alpha:]]+) =0-z= y $1 0-z
\GX.*X aaaXbX n - -
(\d+\.\d+) 3.1415926 y $1 3.1415926
(\ba.{0,10}br) have a web browser y $1 a web br
'\.c(pp|xx|c)?$'i Changes n - -
'\.c(pp|xx|c)?$'i IO.c y - -
'(\.c(pp|xx|c)?$)'i IO.c y $1 .c
^([a-z]:) C:/ n - -
'^\S\s+aa$'m \nx aa y - -
(^|a)b ab y - -
^([ab]*?)(b)?(c)$ abac y -$2- --
(\w)?(abc)\1b abcab n - -
^(?:.,){2}c a,b,c y - -
^(.,){2}c a,b,c y $1 b,
^(?:[^,]*,){2}c a,b,c y - -
^([^,]*,){2}c a,b,c y $1 b,
^([^,]*,){3}d aaa,b,c,d y $1 c,
^([^,]*,){3,}d aaa,b,c,d y $1 c,
^([^,]*,){0,3}d aaa,b,c,d y $1 c,
^([^,]{1,3},){3}d aaa,b,c,d y $1 c,
^([^,]{1,3},){3,}d aaa,b,c,d y $1 c,
^([^,]{1,3},){0,3}d aaa,b,c,d y $1 c,
^([^,]{1,},){3}d aaa,b,c,d y $1 c,
^([^,]{1,},){3,}d aaa,b,c,d y $1 c,
^([^,]{1,},){0,3}d aaa,b,c,d y $1 c,
^([^,]{0,3},){3}d aaa,b,c,d y $1 c,
^([^,]{0,3},){3,}d aaa,b,c,d y $1 c,
^([^,]{0,3},){0,3}d aaa,b,c,d y $1 c,
(?i) y - -
'(?!\A)x'm a\nxb\n y - -
^(a(b)?)+$ aba y -$1-$2- -a--
^(aa(bb)?)+$ aabbaa y -$1-$2- -aa--
'^.{9}abc.*\n'm 123\nabcabcabcabc\n y - -
^(a)?a$ a y -$1- --
^(a)?(?(1)a|b)+$ a n - -
^(a\1?)(a\1?)(a\2?)(a\3?)$ aaaaaa y $1,$2,$3,$4 a,aa,a,aa
^(a\1?){4}$ aaaaaa y $1 aa
^(0+)?(?:x(1))? x1 y - -
^([0-9a-fA-F]+)(?:x([0-9a-fA-F]+)?)(?:x([0-9a-fA-F]+))? 012cxx0190 y - -
^(b+?|a){1,2}c bbbac y $1 a
^(b+?|a){1,2}c bbbbac y $1 a
\((\w\. \w+)\) cd. (A. Tw) y -$1- -A. Tw-
((?:aaaa|bbbb)cccc)? aaaacccc y - -
((?:aaaa|bbbb)cccc)? bbbbcccc y - -
(a)?(a)+ a y $1:$2 :a -
(ab)?(ab)+ ab y $1:$2 :ab -
(abc)?(abc)+ abc y $1:$2 :abc -
'b\s^'m a\nb\n n - -
\ba a y - -
^(a(??{"(?!)"})|(a)(?{1}))b ab y $2 a # [ID 20010811.006]
ab(?i)cd AbCd n - - # [ID 20010809.023]
ab(?i)cd abCd y - -
(A|B)*(?(1)(CD)|(CD)) CD y $2-$3 -CD
(A|B)*(?(1)(CD)|(CD)) ABCD y $2-$3 CD-
(A|B)*?(?(1)(CD)|(CD)) CD y $2-$3 -CD # [ID 20010803.016]
(A|B)*?(?(1)(CD)|(CD)) ABCD y $2-$3 CD-
'^(o)(?!.*\1)'i Oo n - -
(.*)\d+\1 abc12bc y $1 bc
(?m:(foo\s*$)) foo\n bar y $1 foo
(.*)c abcd y $1 ab
(.*)(?=c) abcd y $1 ab
(.*)(?=c)c abcd yB $1 ab
(.*)(?=b|c) abcd y $1 ab
(.*)(?=b|c)c abcd y $1 ab
(.*)(?=c|b) abcd y $1 ab
(.*)(?=c|b)c abcd y $1 ab
(.*)(?=[bc]) abcd y $1 ab
(.*)(?=[bc])c abcd yB $1 ab
(.*)(?<=b) abcd y $1 ab
(.*)(?<=b)c abcd y $1 ab
(.*)(?<=b|c) abcd y $1 abc
(.*)(?<=b|c)c abcd y $1 ab
(.*)(?<=c|b) abcd y $1 abc
(.*)(?<=c|b)c abcd y $1 ab
(.*)(?<=[bc]) abcd y $1 abc
(.*)(?<=[bc])c abcd y $1 ab
(.*?)c abcd y $1 ab
(.*?)(?=c) abcd y $1 ab
(.*?)(?=c)c abcd yB $1 ab
(.*?)(?=b|c) abcd y $1 a
(.*?)(?=b|c)c abcd y $1 ab
(.*?)(?=c|b) abcd y $1 a
(.*?)(?=c|b)c abcd y $1 ab
(.*?)(?=[bc]) abcd y $1 a
(.*?)(?=[bc])c abcd yB $1 ab
(.*?)(?<=b) abcd y $1 ab
(.*?)(?<=b)c abcd y $1 ab
(.*?)(?<=b|c) abcd y $1 ab
(.*?)(?<=b|c)c abcd y $1 ab
(.*?)(?<=c|b) abcd y $1 ab
(.*?)(?<=c|b)c abcd y $1 ab
(.*?)(?<=[bc]) abcd y $1 ab
(.*?)(?<=[bc])c abcd y $1 ab
2(]*)?$\1 2 y $& 2
(??{}) x y - -
a(b)?? abc y <$1> <> # undef [perl #16773]
(\d{1,3}\.){3,} 128.134.142.8 y <$1> <142.> # [perl #18019]
^.{3,4}(.+)\1\z foobarbar y $1 bar # 16 tests for [perl #23171]
^(?:f|o|b){3,4}(.+)\1\z foobarbar y $1 bar
^.{3,4}((?:b|a|r)+)\1\z foobarbar y $1 bar
^(?:f|o|b){3,4}((?:b|a|r)+)\1\z foobarbar y $1 bar
^.{3,4}(.+?)\1\z foobarbar y $1 bar
^(?:f|o|b){3,4}(.+?)\1\z foobarbar y $1 bar
^.{3,4}((?:b|a|r)+?)\1\z foobarbar y $1 bar
^(?:f|o|b){3,4}((?:b|a|r)+?)\1\z foobarbar y $1 bar
^.{2,3}?(.+)\1\z foobarbar y $1 bar
^(?:f|o|b){2,3}?(.+)\1\z foobarbar y $1 bar
^.{2,3}?((?:b|a|r)+)\1\z foobarbar y $1 bar
^(?:f|o|b){2,3}?((?:b|a|r)+)\1\z foobarbar y $1 bar
^.{2,3}?(.+?)\1\z foobarbar y $1 bar
^(?:f|o|b){2,3}?(.+?)\1\z foobarbar y $1 bar
^.{2,3}?((?:b|a|r)+?)\1\z foobarbar y $1 bar
^(?:f|o|b){2,3}?((?:b|a|r)+?)\1\z foobarbar y $1 bar
.*a(?!(b|cd)*e).*f ......abef n - - # [perl #23030]
x(?# x c - Sequence (?#... not terminated
:x(?#: x c - Sequence (?#... not terminated
(WORDS|WORD)S WORDS y $1 WORD
(X.|WORDS|X.|WORD)S WORDS y $1 WORD
(WORDS|WORLD|WORD)S WORDS y $1 WORD
(X.|WORDS|WORD|Y.)S WORDS y $1 WORD
(foo|fool|x.|money|parted)$ fool y $1 fool
(x.|foo|fool|x.|money|parted|y.)$ fool y $1 fool
(foo|fool|money|parted)$ fool y $1 fool
(foo|fool|x.|money|parted)$ fools n - -
(x.|foo|fool|x.|money|parted|y.)$ fools n - -
(foo|fool|money|parted)$ fools n - -
(a|aa|aaa|aaaa|aaaaa|aaaaaa)(b|c) aaaaaaaaaaaaaaab y $1$2 aaaaaab
(a|aa|aaa|aaaa|aaaaa|aaaaaa)(??{$1&&""})(b|c) aaaaaaaaaaaaaaab y $1$2 aaaaaab
(a|aa|aaa|aaaa|aaaaa|aaaaaa)(??{$1&&"foo"})(b|c) aaaaaaaaaaaaaaab n - -
^(a*?)(?!(aa|aaaa)*$) aaaaaaaaaaaaaaaaaaaa y $1 a # [perl #34195]
^(a*?)(?!(aa|aaaa)*$)(?=a\z) aaaaaaaa y $1 aaaaaaa
^(.)\s+.$(?(1)) A B y $1 A # [perl #37688]
--- NEW FILE: eval.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
print "1..91\n";
eval 'print "ok 1\n";';
if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}
eval "\$foo\n = # this is a comment\n'ok 3';";
print $foo,"\n";
eval "\$foo\n = # this is a comment\n'ok 4\n';";
print $foo;
print eval '
$foo =;'; # this tests for a call through yyerror()
if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
print eval '$foo = /'; # this tests for a call through fatal()
if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
print eval '"ok 7\n";';
# calculate a factorial with recursive evals
$foo = 5;
$fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
$ans = eval $fact;
if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}
$foo = 5;
$fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
$ans = eval $fact;
if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
open(try,'>Op.eval');
print try 'print "ok 10\n"; unlink "Op.eval";',"\n";
close try;
do './Op.eval'; print $@;
# Test the singlequoted eval optimizer
$i = 11;
for (1..3) {
eval 'print "ok ", $i++, "\n"';
}
eval {
print "ok 14\n";
die "ok 16\n";
1;
} || print "ok 15\n$@";
# check whether eval EXPR determines value of EXPR correctly
{
my @a = qw(a b c d);
my @b = eval @a;
print "@b" eq '4' ? "ok 17\n" : "not ok 17\n";
print $@ ? "not ok 18\n" : "ok 18\n";
my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
my $b;
@a = eval $a;
print "@a" eq 'A' ? "ok 19\n" : "# $b\nnot ok 19\n";
print $b eq 'A' ? "ok 20\n" : "# $b\nnot ok 20\n";
$_ = eval $a;
print $b eq 'S' ? "ok 21\n" : "# $b\nnot ok 21\n";
eval $a;
print $b eq 'V' ? "ok 22\n" : "# $b\nnot ok 22\n";
$b = 'wrong';
$x = sub {
my $b = "right";
print eval('"$b"') eq $b ? "ok 23\n" : "not ok 23\n";
};
&$x();
}
my $b = 'wrong';
my $X = sub {
my $b = "right";
print eval('"$b"') eq $b ? "ok 24\n" : "not ok 24\n";
};
&$X();
# check navigation of multiple eval boundaries to find lexicals
my $x = 25;
eval <<'EOT'; die if $@;
print "# $x\n"; # clone into eval's pad
sub do_eval1 {
eval $_[0]; die if $@;
}
EOT
do_eval1('print "ok $x\n"');
$x++;
do_eval1('eval q[print "ok $x\n"]');
$x++;
do_eval1('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
$x++;
# calls from within eval'' should clone outer lexicals
eval <<'EOT'; die if $@;
sub do_eval2 {
eval $_[0]; die if $@;
}
do_eval2('print "ok $x\n"');
$x++;
do_eval2('eval q[print "ok $x\n"]');
$x++;
do_eval2('sub { print "# $x\n"; eval q[print "ok $x\n"] }->()');
$x++;
EOT
# calls outside eval'' should NOT clone lexicals from called context
$main::ok = 'not ok';
my $ok = 'ok';
eval <<'EOT'; die if $@;
# $x unbound here
sub do_eval3 {
eval $_[0]; die if $@;
}
EOT
{
my $ok = 'not ok';
do_eval3('print "$ok ' . $x++ . '\n"');
do_eval3('eval q[print "$ok ' . $x++ . '\n"]');
do_eval3('sub { eval q[print "$ok ' . $x++ . '\n"] }->()');
}
# can recursive subroutine-call inside eval'' see its own lexicals?
sub recurse {
my $l = shift;
if ($l < $x) {
++$l;
eval 'print "# level $l\n"; recurse($l);';
die if $@;
}
else {
print "ok $l\n";
}
}
{
local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ };
recurse($x-5);
}
$x++;
# do closures created within eval bind correctly?
eval <<'EOT';
sub create_closure {
my $self = shift;
return sub {
print $self;
};
}
EOT
create_closure("ok $x\n")->();
$x++;
# does lexical search terminate correctly at subroutine boundary?
$main::r = "ok $x\n";
sub terminal { eval 'print $r' }
{
my $r = "not ok $x\n";
eval 'terminal($r)';
}
$x++;
# Have we cured panic which occurred with require/eval in die handler ?
$SIG{__DIE__} = sub { eval {1}; die shift };
eval { die "ok ".$x++,"\n" };
print $@;
# does scalar eval"" pop stack correctly?
{
my $c = eval "(1,2)x10";
print $c eq '2222222222' ? "ok $x\n" : "# $c\nnot ok $x\n";
$x++;
}
# return from eval {} should clear $@ correctly
{
my $status = eval {
eval { die };
print "# eval { return } test\n";
return; # removing this changes behavior
};
print "not " if $@;
print "ok $x\n";
$x++;
}
# ditto for eval ""
{
my $status = eval q{
eval q{ die };
print "# eval q{ return } test\n";
return; # removing this changes behavior
};
print "not " if $@;
print "ok $x\n";
$x++;
}
# Check that eval catches bad goto calls
# (BUG ID 20010305.003)
{
eval {
eval { goto foo; };
print ($@ ? "ok 41\n" : "not ok 41\n");
last;
foreach my $i (1) {
foo: print "not ok 41\n";
print "# jumped into foreach\n";
}
};
print "not ok 41\n" if $@;
}
# Make sure that "my $$x" is forbidden
# 20011224 MJD
{
eval q{my $$x};
print $@ ? "ok 42\n" : "not ok 42\n";
eval q{my @$x};
print $@ ? "ok 43\n" : "not ok 43\n";
eval q{my %$x};
print $@ ? "ok 44\n" : "not ok 44\n";
eval q{my $$$x};
print $@ ? "ok 45\n" : "not ok 45\n";
}
# [ID 20020623.002] eval "" doesn't clear $@
{
$@ = 5;
eval q{};
print length($@) ? "not ok 46\t# \$\@ = '$@'\n" : "ok 46\n";
}
# DAPM Nov-2002. Perl should now capture the full lexical context during
# evals.
$::zzz = $::zzz = 0;
my $zzz = 1;
eval q{
sub fred1 {
eval q{ print eval '$zzz' == 1 ? 'ok' : 'not ok', " $_[0]\n"}
}
fred1(47);
{ my $zzz = 2; fred1(48) }
};
eval q{
sub fred2 {
print eval('$zzz') == 1 ? 'ok' : 'not ok', " $_[0]\n";
}
};
fred2(49);
{ my $zzz = 2; fred2(50) }
# sort() starts a new context stack. Make sure we can still find
# the lexically enclosing sub
sub do_sort {
my $zzz = 2;
my @a = sort
{ print eval('$zzz') == 2 ? 'ok' : 'not ok', " 51\n"; $a <=> $b }
2, 1;
}
do_sort();
# more recursion and lexical scope leak tests
eval q{
my $r = -1;
my $yyy = 9;
sub fred3 {
my $l = shift;
my $r = -2;
return 1 if $l < 1;
return 0 if eval '$zzz' != 1;
return 0 if $yyy != 9;
return 0 if eval '$yyy' != 9;
return 0 if eval '$l' != $l;
return $l * fred3($l-1);
}
my $r = fred3(5);
print $r == 120 ? 'ok' : 'not ok', " 52\n";
$r = eval'fred3(5)';
print $r == 120 ? 'ok' : 'not ok', " 53\n";
$r = 0;
eval '$r = fred3(5)';
print $r == 120 ? 'ok' : 'not ok', " 54\n";
$r = 0;
{ my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
print $r == 120 ? 'ok' : 'not ok', " 55\n";
};
my $r = fred3(5);
print $r == 120 ? 'ok' : 'not ok', " 56\n";
$r = eval'fred3(5)';
print $r == 120 ? 'ok' : 'not ok', " 57\n";
$r = 0;
eval'$r = fred3(5)';
print $r == 120 ? 'ok' : 'not ok', " 58\n";
$r = 0;
{ my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
print $r == 120 ? 'ok' : 'not ok', " 59\n";
# check that goto &sub within evals doesn't leak lexical scope
my $yyy = 2;
my $test = 60;
sub fred4 {
my $zzz = 3;
print +($zzz == 3 && eval '$zzz' == 3) ? 'ok' : 'not ok', " $test\n";
$test++;
print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
$test++;
}
eval q{
fred4();
sub fred5 {
my $zzz = 4;
print +($zzz == 4 && eval '$zzz' == 4) ? 'ok' : 'not ok', " $test\n";
$test++;
print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
$test++;
goto &fred4;
}
fred5();
};
fred5();
{ my $yyy = 88; my $zzz = 99; fred5(); }
eval q{ my $yyy = 888; my $zzz = 999; fred5(); };
# [perl #9728] used to dump core
{
$eval = eval 'sub { eval "sub { %S }" }';
$eval->({});
print "ok $test\n";
$test++;
}
# evals that appear in the DB package should see the lexical scope of the
# thing outside DB that called them (usually the debugged code), rather
# than the usual surrounding scope
$test=79;
our $x = 1;
{
my $x=2;
sub db1 { $x; eval '$x' }
sub DB::db2 { $x; eval '$x' }
package DB;
sub db3 { eval '$x' }
sub DB::db4 { eval '$x' }
sub db5 { my $x=4; eval '$x' }
package main;
sub db6 { my $x=4; eval '$x' }
}
{
my $x = 3;
print db1() == 2 ? 'ok' : 'not ok', " $test\n"; $test++;
print DB::db2() == 2 ? 'ok' : 'not ok', " $test\n"; $test++;
print DB::db3() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
print DB::db4() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
print DB::db5() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
print db6() == 4 ? 'ok' : 'not ok', " $test\n"; $test++;
}
require './test.pl';
$NO_ENDING = 1;
# [perl #19022] used to end up with shared hash warnings
# The program should generate no output, so anything we see is on stderr
my $got = runperl (prog => '$h{a}=1; foreach my $k (keys %h) {eval qq{\$k}}',
stderr => 1);
if ($got eq '') {
print "ok $test\n";
} else {
print "not ok $test\n";
_diag ("# Got '$got'\n");
}
$test++;
# And a buggy way of fixing #19022 made this fail - $k became undef after the
# eval for a build with copy on write
{
my %h;
$h{a}=1;
foreach my $k (keys %h) {
if (defined $k and $k eq 'a') {
print "ok $test\n";
} else {
print "not $test # got ", _q ($k), "\n";
}
$test++;
eval "\$k";
if (defined $k and $k eq 'a') {
print "ok $test\n";
} else {
print "not $test # got ", _q ($k), "\n";
}
$test++;
}
}
sub Foo {} print Foo(eval {});
print "ok ",$test++," - #20798 (used to dump core)\n";
# check for context in string eval
{
my(@r,$r,$c);
sub context { defined(wantarray) ? (wantarray ? ($c='A') : ($c='S')) : ($c='V') }
my $code = q{ context() };
@r = qw( a b );
$r = 'ab';
@r = eval $code;
print "@r$c" eq 'AA' ? "ok " : "# '@r$c' ne 'AA'\nnot ok ", $test++, "\n";
$r = eval $code;
print "$r$c" eq 'SS' ? "ok " : "# '$r$c' ne 'SS'\nnot ok ", $test++, "\n";
eval $code;
print $c eq 'V' ? "ok " : "# '$c' ne 'V'\nnot ok ", $test++, "\n";
}
--- NEW FILE: local.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
require './test.pl';
}
plan tests => 81;
my $list_assignment_supported = 1;
#mg.c says list assignment not supported on VMS, EPOC, and SYMBIAN.
$list_assignment_supported = 0 if ($^O eq 'VMS');
sub foo {
local($a, $b) = @_;
local($c, $d);
$c = "c 3";
$d = "d 4";
{ local($a,$c) = ("a 9", "c 10"); ($x, $y) = ($a, $c); }
is($a, "a 1");
is($b, "b 2");
$c, $d;
}
$a = "a 5";
$b = "b 6";
$c = "c 7";
$d = "d 8";
my @res;
@res = &foo("a 1","b 2");
is($res[0], "c 3");
is($res[1], "d 4");
is($a, "a 5");
is($b, "b 6");
is($c, "c 7");
is($d, "d 8");
is($x, "a 9");
is($y, "c 10");
# same thing, only with arrays and associative arrays
sub foo2 {
local($a, @b) = @_;
local(@c, %d);
@c = "c 3";
$d{''} = "d 4";
{ local($a, at c) = ("a 19", "c 20"); ($x, $y) = ($a, @c); }
is($a, "a 1");
is("@b", "b 2");
$c[0], $d{''};
}
$a = "a 5";
@b = "b 6";
@c = "c 7";
$d{''} = "d 8";
@res = &foo2("a 1","b 2");
is($res[0], "c 3");
is($res[1], "d 4");
is($a, "a 5");
is("@b", "b 6");
is($c[0], "c 7");
is($d{''}, "d 8");
is($x, "a 19");
is($y, "c 20");
eval 'local($$e)';
like($@, qr/Can't localize through a reference/);
eval '$e = []; local(@$e)';
like($@, qr/Can't localize through a reference/);
eval '$e = {}; local(%$e)';
like($@, qr/Can't localize through a reference/);
# Array and hash elements
@a = ('a', 'b', 'c');
{
local($a[1]) = 'foo';
local($a[2]) = $a[2];
is($a[1], 'foo');
is($a[2], 'c');
undef @a;
}
is($a[1], 'b');
is($a[2], 'c');
ok(!defined $a[0]);
@a = ('a', 'b', 'c');
{
local($a[1]) = "X";
shift @a;
}
is($a[0].$a[1], "Xb");
{
my $d = "@a";
local @a = @a;
is("@a", $d);
}
%h = ('a' => 1, 'b' => 2, 'c' => 3);
{
local($h{'a'}) = 'foo';
local($h{'b'}) = $h{'b'};
is($h{'a'}, 'foo');
is($h{'b'}, 2);
local($h{'c'});
delete $h{'c'};
}
is($h{'a'}, 1);
is($h{'b'}, 2);
{
my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h);
local %h = %h;
is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d);
}
is($h{'c'}, 3);
# check for scope leakage
$a = 'outer';
if (1) { local $a = 'inner' }
is($a, 'outer');
# see if localization works when scope unwinds
local $m = 5;
eval {
for $m (6) {
local $m = 7;
die "bye";
}
};
is($m, 5);
# see if localization works on tied arrays
{
package TA;
sub TIEARRAY { bless [], $_[0] }
sub STORE { print "# STORE [@_]\n"; $_[0]->[$_[1]] = $_[2] }
sub FETCH { my $v = $_[0]->[$_[1]]; print "# FETCH [@_=$v]\n"; $v }
sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); }
sub FETCHSIZE { scalar(@{$_[0]}) }
sub SHIFT { shift (@{$_[0]}) }
sub EXTEND {}
}
tie @a, 'TA';
@a = ('a', 'b', 'c');
{
local($a[1]) = 'foo';
local($a[2]) = $a[2];
is($a[1], 'foo');
is($a[2], 'c');
@a = ();
}
is($a[1], 'b');
is($a[2], 'c');
ok(!defined $a[0]);
{
my $d = "@a";
local @a = @a;
is("@a", $d);
}
{
package TH;
sub TIEHASH { bless {}, $_[0] }
sub STORE { print "# STORE [@_]\n"; $_[0]->{$_[1]} = $_[2] }
sub FETCH { my $v = $_[0]->{$_[1]}; print "# FETCH [@_=$v]\n"; $v }
sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->{$_[1]}; }
sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; }
sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); }
sub FIRSTKEY { print "# FIRSTKEY [@_]\n"; keys %{$_[0]}; each %{$_[0]} }
sub NEXTKEY { print "# NEXTKEY [@_]\n"; each %{$_[0]} }
}
# see if localization works on tied hashes
tie %h, 'TH';
%h = ('a' => 1, 'b' => 2, 'c' => 3);
{
local($h{'a'}) = 'foo';
local($h{'b'}) = $h{'b'};
local($h{'y'});
local($h{'z'}) = 33;
is($h{'a'}, 'foo');
is($h{'b'}, 2);
local($h{'c'});
delete $h{'c'};
}
is($h{'a'}, 1);
is($h{'b'}, 2);
is($h{'c'}, 3);
# local() should preserve the existenceness of tied hash elements
ok(! exists $h{'y'});
ok(! exists $h{'z'});
TODO: {
todo_skip("Localize entire tied hash");
my $d = join("\n", map { "$_=>$h{$_}" } sort keys %h);
local %h = %h;
is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d);
}
@a = ('a', 'b', 'c');
{
local($a[1]) = "X";
shift @a;
}
is($a[0].$a[1], "Xb");
# now try the same for %SIG
$SIG{TERM} = 'foo';
$SIG{INT} = \&foo;
$SIG{__WARN__} = $SIG{INT};
{
local($SIG{TERM}) = $SIG{TERM};
local($SIG{INT}) = $SIG{INT};
local($SIG{__WARN__}) = $SIG{__WARN__};
is($SIG{TERM}, 'main::foo');
is($SIG{INT}, \&foo);
is($SIG{__WARN__}, \&foo);
local($SIG{INT});
delete $SIG{__WARN__};
}
is($SIG{TERM}, 'main::foo');
is($SIG{INT}, \&foo);
is($SIG{__WARN__}, \&foo);
{
my $d = join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG);
local %SIG = %SIG;
is(join("\n", map { "$_=>$SIG{$_}" } sort keys %SIG), $d);
}
# and for %ENV
$ENV{_X_} = 'a';
$ENV{_Y_} = 'b';
$ENV{_Z_} = 'c';
{
local($ENV{_A_});
local($ENV{_B_}) = 'foo';
local($ENV{_X_}) = 'foo';
local($ENV{_Y_}) = $ENV{_Y_};
is($ENV{_X_}, 'foo');
is($ENV{_Y_}, 'b');
local($ENV{_Z_});
delete $ENV{_Z_};
}
is($ENV{_X_}, 'a');
is($ENV{_Y_}, 'b');
is($ENV{_Z_}, 'c');
# local() should preserve the existenceness of %ENV elements
ok(! exists $ENV{_A_});
ok(! exists $ENV{_B_});
SKIP: {
skip("Can't make list assignment to \%ENV on this system")
unless $list_assignment_supported;
my $d = join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV);
local %ENV = %ENV;
is(join("\n", map { "$_=>$ENV{$_}" } sort keys %ENV), $d);
}
# does implicit localization in foreach skip magic?
$_ = "o 0,o 1,";
my $iter = 0;
while (/(o.+?),/gc) {
is($1, "o $iter");
foreach (1..1) { $iter++ }
if ($iter > 2) { fail("endless loop"); last; }
}
{
package UnderScore;
sub TIESCALAR { bless \my $self, shift }
sub FETCH { die "read \$_ forbidden" }
sub STORE { die "write \$_ forbidden" }
tie $_, __PACKAGE__;
my @tests = (
"Nesting" => sub { print '#'; for (1..3) { print }
print "\n" }, 1,
"Reading" => sub { print }, 0,
"Matching" => sub { $x = /badness/ }, 0,
"Concat" => sub { $_ .= "a" }, 0,
"Chop" => sub { chop }, 0,
"Filetest" => sub { -x }, 0,
"Assignment" => sub { $_ = "Bad" }, 0,
# XXX whether next one should fail is debatable
"Local \$_" => sub { local $_ = 'ok?'; print }, 0,
"for local" => sub { for("#ok?\n"){ print } }, 1,
);
while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) {
eval { &$code };
main::ok(($ok xor $@), "Underscore '$name'");
}
untie $_;
}
{
# BUG 20001205.22
my %x;
$x{a} = 1;
{ local $x{b} = 1; }
ok(! exists $x{b});
{ local @x{c,d,e}; }
ok(! exists $x{c});
}
--- NEW FILE: cmp.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
# 2s complement assumption. Won't break test, just makes the internals of
# the SVs less interesting if were not on 2s complement system.
my $uv_max = ~0;
my $uv_maxm1 = ~0 ^ 1;
my $uv_big = $uv_max;
$uv_big = ($uv_big - 20000) | 1;
my ($iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, $iv_small);
$iv_max = $uv_max; # Do copy, *then* divide
$iv_max /= 2;
$iv_min = $iv_max;
{
use integer;
$iv0 = 2 - 2;
$iv1 = 3 - 2;
$ivm1 = 2 - 3;
$iv_max -= 1;
$iv_min += 0;
$iv_big = $iv_max - 3;
$iv_small = $iv_min + 2;
}
my $uv_bigi = $iv_big;
$uv_bigi |= 0x0;
my @array = qw(perl rules);
# Seems one needs to perform the maths on 'Inf' to get the NV correctly primed.
@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1, 3.14, 1e37, 0.632120558, -.5,
'Inf'+1, '-Inf'-1, 0x0, 0x1, 0x5, 0xFFFFFFFF, $uv_max, $uv_maxm1,
$uv_big, $uv_bigi, $iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big,
$iv_small, \$array[0], \$array[0], \$array[1], \$^X);
$expect = 7 * ($#FOO+2) * ($#FOO+1);
print "1..$expect\n";
sub nok ($$$$$$$$) {
my ($test, $left, $threeway, $right, $result, $i, $j, $boolean) = @_;
$result = defined $result ? "'$result'" : 'undef';
print "not ok $test # ($left <=> $right) gives: $result \$i=$i \$j=$j, $boolean disagrees\n";
}
my $ok = 0;
for my $i (0..$#FOO) {
for my $j ($i..$#FOO) {
$ok++;
# Comparison routines may convert these internally, which would change
# what is used to determine the comparison on later runs. Hence copy
my ($i1, $i2, $i3, $i4, $i5, $i6, $i7, $i8, $i9, $i10,
$i11, $i12, $i13, $i14, $i15, $i16, $i17) =
($FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i],
$FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i],
$FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i]);
my ($j1, $j2, $j3, $j4, $j5, $j6, $j7, $j8, $j9, $j10,
$j11, $j12, $j13, $j14, $j15, $j16, $j17) =
($FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j],
$FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j],
$FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j]);
my $cmp = $i1 <=> $j1;
if (!defined($cmp) ? !($i2 < $j2)
: ($cmp == -1 && $i2 < $j2 ||
$cmp == 0 && !($i2 < $j2) ||
$cmp == 1 && !($i2 < $j2)))
{
print "ok $ok\n";
}
else {
nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<');
}
$ok++;
if (!defined($cmp) ? !($i4 == $j4)
: ($cmp == -1 && !($i4 == $j4) ||
$cmp == 0 && $i4 == $j4 ||
$cmp == 1 && !($i4 == $j4)))
{
print "ok $ok\n";
}
else {
nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '==');
}
$ok++;
if (!defined($cmp) ? !($i5 > $j5)
: ($cmp == -1 && !($i5 > $j5) ||
$cmp == 0 && !($i5 > $j5) ||
$cmp == 1 && ($i5 > $j5)))
{
print "ok $ok\n";
}
else {
nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '>');
}
$ok++;
if (!defined($cmp) ? !($i6 >= $j6)
: ($cmp == -1 && !($i6 >= $j6) ||
$cmp == 0 && $i6 >= $j6 ||
$cmp == 1 && $i6 >= $j6))
{
print "ok $ok\n";
}
else {
nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '>=');
}
$ok++;
# OK, so the docs are wrong it seems. NaN != NaN
if (!defined($cmp) ? ($i7 != $j7)
: ($cmp == -1 && $i7 != $j7 ||
$cmp == 0 && !($i7 != $j7) ||
$cmp == 1 && $i7 != $j7))
{
print "ok $ok\n";
}
else {
nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '!=');
}
$ok++;
if (!defined($cmp) ? !($i8 <= $j8)
: ($cmp == -1 && $i8 <= $j8 ||
$cmp == 0 && $i8 <= $j8 ||
$cmp == 1 && !($i8 <= $j8)))
{
print "ok $ok\n";
}
else {
nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<=');
}
$ok++;
my $pmc = $j16 <=> $i16; # cmp it in reverse
# Should give -ve of other answer, or undef for NaNs
# a + -a should be zero. not zero is truth. which avoids using ==
if (defined($cmp) ? !($cmp + $pmc) : !defined $pmc)
{
print "ok $ok\n";
}
else {
nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<=> transposed');
}
# String comparisons
$ok++;
$cmp = $i9 cmp $j9;
if ($cmp == -1 && $i10 lt $j10 ||
$cmp == 0 && !($i10 lt $j10) ||
$cmp == 1 && !($i10 lt $j10))
{
print "ok $ok\n";
}
else {
nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'lt');
}
$ok++;
if ($cmp == -1 && !($i11 eq $j11) ||
$cmp == 0 && ($i11 eq $j11) ||
$cmp == 1 && !($i11 eq $j11))
{
print "ok $ok\n";
}
else {
nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'eq');
}
$ok++;
if ($cmp == -1 && !($i12 gt $j12) ||
$cmp == 0 && !($i12 gt $j12) ||
$cmp == 1 && ($i12 gt $j12))
{
print "ok $ok\n";
}
else {
nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'gt');
}
$ok++;
if ($cmp == -1 && $i13 le $j13 ||
$cmp == 0 && ($i13 le $j13) ||
$cmp == 1 && !($i13 le $j13))
{
print "ok $ok\n";
}
else {
nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'le');
}
$ok++;
if ($cmp == -1 && ($i14 ne $j14) ||
$cmp == 0 && !($i14 ne $j14) ||
$cmp == 1 && ($i14 ne $j14))
{
print "ok $ok\n";
}
else {
nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'ne');
}
$ok++;
if ($cmp == -1 && !($i15 ge $j15) ||
$cmp == 0 && ($i15 ge $j15) ||
$cmp == 1 && ($i15 ge $j15))
{
print "ok $ok\n";
}
else {
nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'ge');
}
$ok++;
$pmc = $j17 cmp $i17; # cmp it in reverse
# Should give -ve of other answer
# a + -a should be zero. not zero is truth. which avoids using ==
if (!($cmp + $pmc))
{
print "ok $ok\n";
}
else {
nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, 'cmp transposed');
}
}
}
More information about the dslinux-commit
mailing list