diff options
Diffstat (limited to 'contrib/perl5/t/op')
105 files changed, 0 insertions, 16827 deletions
diff --git a/contrib/perl5/t/op/64bitint.t b/contrib/perl5/t/op/64bitint.t deleted file mode 100755 index 88fbc55..0000000 --- a/contrib/perl5/t/op/64bitint.t +++ /dev/null @@ -1,297 +0,0 @@ -#./perl - -BEGIN { - eval { my $q = pack "q", 0 }; - if ($@) { - print "1..0\n# 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 -no warnings qw(overflow portable); - -print "1..55\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"; - -# eof diff --git a/contrib/perl5/t/op/anonsub.t b/contrib/perl5/t/op/anonsub.t deleted file mode 100755 index 17889d9..0000000 --- a/contrib/perl5/t/op/anonsub.t +++ /dev/null @@ -1,93 +0,0 @@ -#!./perl - -chdir 't' if -d 't'; -@INC = '../lib'; -$Is_VMS = $^O eq 'VMS'; -$Is_MSWin32 = $^O eq 'MSWin32'; -$ENV{PERL5LIB} = "../lib" unless $Is_VMS; - -$|=1; - -undef $/; -@prgs = split "\n########\n", <DATA>; -print "1..", 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; - my $results = $Is_VMS ? - `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` : - $Is_MSWin32 ? - `.\\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"; -} - -__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 diff --git a/contrib/perl5/t/op/append.t b/contrib/perl5/t/op/append.t deleted file mode 100755 index 5aa4bf9..0000000 --- a/contrib/perl5/t/op/append.t +++ /dev/null @@ -1,59 +0,0 @@ -#!./perl - -# $RCSfile: append.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:36 $ - -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 -{ -# Character 'b' occurs at codepoint 130 decimal or \202 octal -# under an EBCDIC coded character set. -# my($a, $ab) = ("a", "a\000b"); - my($a, $ab) = ("\141", "\141\000\142"); - my($u, $ub) = map pack("U0a*", $_), $a, $ab; - my $t1 = $a; $t1 .= $ab; - print $t1 =~ /\142/ ? "ok 6\n" : "not ok 6\t# $t1\n"; - my $t2 = $a; $t2 .= $ub; - print $t2 =~ /\142/ ? "ok 7\n" : "not ok 7\t# $t2\n"; - my $t3 = $u; $t3 .= $ab; - print $t3 =~ /\142/ ? "ok 8\n" : "not ok 8\t# $t3\n"; - my $t4 = $u; $t4 .= $ub; - print $t4 =~ /\142/ ? "ok 9\n" : "not ok 9\t# $t4\n"; - my $t5 = $a; $t5 = $ab . $t5; - print $t5 =~ /\142/ ? "ok 10\n" : "not ok 10\t# $t5\n"; - my $t6 = $a; $t6 = $ub . $t6; - print $t6 =~ /\142/ ? "ok 11\n" : "not ok 11\t# $t6\n"; - my $t7 = $u; $t7 = $ab . $t7; - print $t7 =~ /\142/ ? "ok 12\n" : "not ok 12\t# $t7\n"; - my $t8 = $u; $t8 = $ub . $t8; - print $t8 =~ /\142/ ? "ok 13\n" : "not ok 13\t# $t8\n"; -} diff --git a/contrib/perl5/t/op/args.t b/contrib/perl5/t/op/args.t deleted file mode 100755 index ce2c398..0000000 --- a/contrib/perl5/t/op/args.t +++ /dev/null @@ -1,75 +0,0 @@ -#!./perl - -print "1..9\n"; - -# test various operations on @_ - -my $ord = 0; -sub new1 { bless \@_ } -{ - my $x = new1("x"); - my $y = new1("y"); - ++$ord; - print "# got [@$y], expected [y]\nnot " unless "@$y" eq "y"; - print "ok $ord\n"; - ++$ord; - print "# got [@$x], expected [x]\nnot " unless "@$x" eq "x"; - print "ok $ord\n"; -} - -sub new2 { splice @_, 0, 0, "a", "b", "c"; return \@_ } -{ - my $x = new2("x"); - my $y = new2("y"); - ++$ord; - print "# got [@$x], expected [a b c x]\nnot " unless "@$x" eq "a b c x"; - print "ok $ord\n"; - ++$ord; - print "# got [@$y], expected [a b c y]\nnot " unless "@$y" eq "a b c y"; - print "ok $ord\n"; -} - -sub new3 { goto &new1 } -{ - my $x = new3("x"); - my $y = new3("y"); - ++$ord; - print "# got [@$y], expected [y]\nnot " unless "@$y" eq "y"; - print "ok $ord\n"; - ++$ord; - print "# got [@$x], expected [x]\nnot " unless "@$x" eq "x"; - print "ok $ord\n"; -} - -sub new4 { goto &new2 } -{ - my $x = new4("x"); - my $y = new4("y"); - ++$ord; - print "# got [@$x], expected [a b c x]\nnot " unless "@$x" eq "a b c x"; - print "ok $ord\n"; - ++$ord; - print "# got [@$y], expected [a b c y]\nnot " unless "@$y" eq "a b c y"; - print "ok $ord\n"; -} - -# 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() } -++$ord; -print "ok $ord\n"; diff --git a/contrib/perl5/t/op/arith.t b/contrib/perl5/t/op/arith.t deleted file mode 100755 index 5b04f93..0000000 --- a/contrib/perl5/t/op/arith.t +++ /dev/null @@ -1,30 +0,0 @@ -#!./perl - -print "1..12\n"; - -sub try ($$) { - print +($_[1] ? "ok" : "not ok"), " $_[0]\n"; -} - -try 1, 13 % 4 == 1; -try 2, -13 % 4 == 3; -try 3, 13 % -4 == -3; -try 4, -13 % -4 == -1; - -my $limit = 1e6; - -# Division (and modulo) of floating point numbers -# seem to be rather sloppy in Cray. -$limit = 1e8 if $^O eq 'unicos'; - -try 5, abs( 13e21 % 4e21 - 1e21) < $limit; -try 6, abs(-13e21 % 4e21 - 3e21) < $limit; -try 7, abs( 13e21 % -4e21 - -3e21) < $limit; -try 8, abs(-13e21 % -4e21 - -1e21) < $limit; - -# UVs should behave properly - -try 9, 4063328477 % 65535 == 27407; -try 10, 4063328477 % 4063328476 == 1; -try 11, 4063328477 % 2031664238 == 1; -try 12, 2031664238 % 4063328477 == 2031664238; diff --git a/contrib/perl5/t/op/array.t b/contrib/perl5/t/op/array.t deleted file mode 100755 index 7cc84e3..0000000 --- a/contrib/perl5/t/op/array.t +++ /dev/null @@ -1,231 +0,0 @@ -#!./perl - -print "1..70\n"; - -# -# @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them -# - -@ary = (1,2,3,4,5); -if (join('',@ary) eq '12345') {print "ok 1\n";} else {print "not ok 1\n";} - -$tmp = $ary[$#ary]; --$#ary; -if ($tmp == 5) {print "ok 2\n";} else {print "not ok 2\n";} -if ($#ary == 3) {print "ok 3\n";} else {print "not ok 3\n";} -if (join('',@ary) eq '1234') {print "ok 4\n";} else {print "not ok 4\n";} - -$[ = 1; -@ary = (1,2,3,4,5); -if (join('',@ary) eq '12345') {print "ok 5\n";} else {print "not ok 5\n";} - -$tmp = $ary[$#ary]; --$#ary; -if ($tmp == 5) {print "ok 6\n";} else {print "not ok 6\n";} -if ($#ary == 4) {print "ok 7\n";} else {print "not ok 7\n";} -if (join('',@ary) eq '1234') {print "ok 8\n";} else {print "not ok 8\n";} - -if ($ary[5] eq '') {print "ok 9\n";} else {print "not ok 9\n";} - -$#ary += 1; # see if element 5 gone for good -if ($#ary == 5) {print "ok 10\n";} else {print "not ok 10\n";} -if (defined $ary[5]) {print "not ok 11\n";} else {print "ok 11\n";} - -$[ = 0; -@foo = (); -$r = join(',', $#foo, @foo); -if ($r eq "-1") {print "ok 12\n";} else {print "not ok 12 $r\n";} -$foo[0] = '0'; -$r = join(',', $#foo, @foo); -if ($r eq "0,0") {print "ok 13\n";} else {print "not ok 13 $r\n";} -$foo[2] = '2'; -$r = join(',', $#foo, @foo); -if ($r eq "2,0,,2") {print "ok 14\n";} else {print "not ok 14 $r\n";} -@bar = (); -$bar[0] = '0'; -$bar[1] = '1'; -$r = join(',', $#bar, @bar); -if ($r eq "1,0,1") {print "ok 15\n";} else {print "not ok 15 $r\n";} -@bar = (); -$r = join(',', $#bar, @bar); -if ($r eq "-1") {print "ok 16\n";} else {print "not ok 16 $r\n";} -$bar[0] = '0'; -$r = join(',', $#bar, @bar); -if ($r eq "0,0") {print "ok 17\n";} else {print "not ok 17 $r\n";} -$bar[2] = '2'; -$r = join(',', $#bar, @bar); -if ($r eq "2,0,,2") {print "ok 18\n";} else {print "not ok 18 $r\n";} -reset 'b'; -@bar = (); -$bar[0] = '0'; -$r = join(',', $#bar, @bar); -if ($r eq "0,0") {print "ok 19\n";} else {print "not ok 19 $r\n";} -$bar[2] = '2'; -$r = join(',', $#bar, @bar); -if ($r eq "2,0,,2") {print "ok 20\n";} else {print "not ok 20 $r\n";} - -$foo = 'now is the time'; -if (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)) { - if ($F1 eq 'now' && $F2 eq 'is' && $Etc eq 'the time') { - print "ok 21\n"; - } - else { - print "not ok 21\n"; - } -} -else { - print "not ok 21\n"; -} - -$foo = 'lskjdf'; -if ($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))) { - print "not ok 22 $cnt $F1:$F2:$Etc\n"; -} -else { - print "ok 22\n"; -} - -%foo = ('blurfl','dyick','foo','bar','etc.','etc.'); -%bar = %foo; -print $bar{'foo'} eq 'bar' ? "ok 23\n" : "not ok 23\n"; -%bar = (); -print $bar{'foo'} eq '' ? "ok 24\n" : "not ok 24\n"; -(%bar,$a,$b) = (%foo,'how','now'); -print $bar{'foo'} eq 'bar' ? "ok 25\n" : "not ok 25\n"; -print $bar{'how'} eq 'now' ? "ok 26\n" : "not ok 26\n"; -@bar{keys %foo} = values %foo; -print $bar{'foo'} eq 'bar' ? "ok 27\n" : "not ok 27\n"; -print $bar{'how'} eq 'now' ? "ok 28\n" : "not ok 28\n"; - -@foo = grep(/e/,split(' ','now is the time for all good men to come to')); -print join(' ',@foo) eq 'the time men come' ? "ok 29\n" : "not ok 29\n"; - -@foo = grep(!/e/,split(' ','now is the time for all good men to come to')); -print join(' ',@foo) eq 'now is for all good to to' ? "ok 30\n" : "not ok 30\n"; - -$foo = join('',('a','b','c','d','e','f')[0..5]); -print $foo eq 'abcdef' ? "ok 31\n" : "not ok 31\n"; - -$foo = join('',('a','b','c','d','e','f')[0..1]); -print $foo eq 'ab' ? "ok 32\n" : "not ok 32\n"; - -$foo = join('',('a','b','c','d','e','f')[6]); -print $foo eq '' ? "ok 33\n" : "not ok 33\n"; - -@foo = ('a','b','c','d','e','f')[0,2,4]; -@bar = ('a','b','c','d','e','f')[1,3,5]; -$foo = join('',(@foo,@bar)[0..5]); -print $foo eq 'acebdf' ? "ok 34\n" : "not ok 34\n"; - -$foo = ('a','b','c','d','e','f')[0,2,4]; -print $foo eq 'e' ? "ok 35\n" : "not ok 35\n"; - -$foo = ('a','b','c','d','e','f')[1]; -print $foo eq 'b' ? "ok 36\n" : "not ok 36\n"; - -@foo = ( 'foo', 'bar', 'burbl'); -push(foo, 'blah'); -print $#foo == 3 ? "ok 37\n" : "not ok 37\n"; - -# various AASSIGN_COMMON checks (see newASSIGNOP() in op.c) - -$test = 37; -sub t { ++$test; print "not " unless $_[0]; print "ok $test\n"; } - -@foo = @foo; -t("@foo" eq "foo bar burbl blah"); # 38 - -(undef,@foo) = @foo; -t("@foo" eq "bar burbl blah"); # 39 - -@foo = ('XXX',@foo, 'YYY'); -t("@foo" eq "XXX bar burbl blah YYY"); # 40 - -@foo = @foo = qw(foo b\a\r bu\\rbl blah); -t("@foo" eq 'foo b\a\r bu\\rbl blah'); # 41 - -@bar = @foo = qw(foo bar); # 42 -t("@foo" eq "foo bar"); -t("@bar" eq "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; - t("@bee" eq "foo bar burbl blah"); # 44 - { - local (undef,@bee) = @bee; - t("@bee" eq "bar burbl blah"); # 45 - { - local @bee = ('XXX',@bee,'YYY'); - t("@bee" eq "XXX bar burbl blah YYY"); # 46 - { - local @bee = local(@bee) = qw(foo bar burbl blah); - t("@bee" eq "foo bar burbl blah"); # 47 - { - local (@bim) = local(@bee) = qw(foo bar); - t("@bee" eq "foo bar"); # 48 - t("@bim" eq "foo bar"); # 49 - } - t("@bee" eq "foo bar burbl blah"); # 50 - } - t("@bee" eq "XXX bar burbl blah YYY"); # 51 - } - t("@bee" eq "bar burbl blah"); # 52 - } - t("@bee" eq "foo bar burbl blah"); # 53 -} - -# try the same with my -{ - - my @bee = @bee; - t("@bee" eq "foo bar burbl blah"); # 54 - { - my (undef,@bee) = @bee; - t("@bee" eq "bar burbl blah"); # 55 - { - my @bee = ('XXX',@bee,'YYY'); - t("@bee" eq "XXX bar burbl blah YYY"); # 56 - { - my @bee = my @bee = qw(foo bar burbl blah); - t("@bee" eq "foo bar burbl blah"); # 57 - { - my (@bim) = my(@bee) = qw(foo bar); - t("@bee" eq "foo bar"); # 58 - t("@bim" eq "foo bar"); # 59 - } - t("@bee" eq "foo bar burbl blah"); # 60 - } - t("@bee" eq "XXX bar burbl blah YYY"); # 61 - } - t("@bee" eq "bar burbl blah"); # 62 - } - t("@bee" eq "foo bar burbl blah"); # 63 -} - -# make sure reification behaves -my $t = 63; -sub reify { $_[1] = ++$t; print "@_\n"; } -reify('ok'); -reify('ok'); - -# qw() is no more a runtime split, it's compiletime. -print "not " unless qw(foo bar snorfle)[2] eq 'snorfle'; -print "ok 66\n"; - -@ary = (12,23,34,45,56); - -print "not " unless shift(@ary) == 12; -print "ok 67\n"; - -print "not " unless pop(@ary) == 56; -print "ok 68\n"; - -print "not " unless push(@ary,56) == 4; -print "ok 69\n"; - -print "not " unless unshift(@ary,12) == 5; -print "ok 70\n"; diff --git a/contrib/perl5/t/op/assignwarn.t b/contrib/perl5/t/op/assignwarn.t deleted file mode 100755 index aff433c..0000000 --- a/contrib/perl5/t/op/assignwarn.t +++ /dev/null @@ -1,73 +0,0 @@ -#!./perl - -# -# Verify which OP= operators warn if their targets are undefined. -# Based on redef.t, contributed by Graham Barr <Graham.Barr@tiuk.ti.com> -# -- Robin Barker <rmb@cise.npl.co.uk> -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use strict; -use warnings; - -my $warn = ""; -$SIG{q(__WARN__)} = sub { print $warn; $warn .= join("",@_) }; - -sub ok { print $_[1] ? "ok " : "not ok ", $_[0], "\n"; } - -sub uninitialized { $warn =~ s/Use of uninitialized value[^\n]+\n//s; } - -print "1..32\n"; - -{ my $x; $x ++; ok 1, ! uninitialized; } -{ my $x; $x --; ok 2, ! uninitialized; } -{ my $x; ++ $x; ok 3, ! uninitialized; } -{ my $x; -- $x; ok 4, ! uninitialized; } - -{ my $x; $x **= 1; ok 5, uninitialized; } - -{ my $x; $x += 1; ok 6, ! uninitialized; } -{ my $x; $x -= 1; ok 7, ! uninitialized; } - -{ my $x; $x .= 1; ok 8, ! uninitialized; } - -{ my $x; $x *= 1; ok 9, uninitialized; } -{ my $x; $x /= 1; ok 10, uninitialized; } -{ my $x; $x %= 1; ok 11, uninitialized; } - -{ my $x; $x x= 1; ok 12, uninitialized; } - -{ my $x; $x &= 1; ok 13, uninitialized; } -{ my $x; $x |= 1; ok 14, ! uninitialized; } -{ my $x; $x ^= 1; ok 15, ! uninitialized; } - -{ my $x; $x &&= 1; ok 16, ! uninitialized; } -{ my $x; $x ||= 1; ok 17, ! uninitialized; } - -{ my $x; $x <<= 1; ok 18, uninitialized; } -{ my $x; $x >>= 1; ok 19, uninitialized; } - -{ my $x; $x &= "x"; ok 20, uninitialized; } -{ my $x; $x |= "x"; ok 21, ! uninitialized; } -{ my $x; $x ^= "x"; ok 22, ! uninitialized; } - -{ use integer; my $x; $x += 1; ok 23, ! uninitialized; } -{ use integer; my $x; $x -= 1; ok 24, ! uninitialized; } - -{ use integer; my $x; $x *= 1; ok 25, uninitialized; } -{ use integer; my $x; $x /= 1; ok 26, uninitialized; } -{ use integer; my $x; $x %= 1; ok 27, uninitialized; } - -{ use integer; my $x; $x ++; ok 28, ! uninitialized; } -{ use integer; my $x; $x --; ok 29, ! uninitialized; } -{ use integer; my $x; ++ $x; ok 30, ! uninitialized; } -{ use integer; my $x; -- $x; ok 31, ! uninitialized; } - -ok 32, $warn eq ''; - -# If we got any errors that we were not expecting, then print them -print map "#$_\n", split /\n/, $warn if length $warn; diff --git a/contrib/perl5/t/op/attrs.t b/contrib/perl5/t/op/attrs.t deleted file mode 100755 index 2702004..0000000 --- a/contrib/perl5/t/op/attrs.t +++ /dev/null @@ -1,176 +0,0 @@ -#!./perl -w - -# Regression tests for attributes.pm and the C< : attrs> syntax. - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -sub NTESTS () ; - -my ($test, $ntests); -BEGIN {$ntests=0} -$test=0; -my $failed = 0; - -print "1..".NTESTS."\n"; - -$SIG{__WARN__} = sub { die @_ }; - -sub mytest { - if (!$@ ne !$_[0] || $_[0] && $@ !~ $_[0]) { - if ($@) { - my $x = $@; - $x =~ s/\n.*\z//s; - print "# Got: $x\n" - } - else { - print "# Got unexpected success\n"; - } - if ($_[0]) { - print "# Expected: $_[0]\n"; - } - else { - print "# Expected success\n"; - } - $failed = 1; - print "not "; - } - elsif (@_ == 3 && $_[1] ne $_[2]) { - print "# Got: $_[1]\n"; - print "# Expected: $_[2]\n"; - $failed = 1; - print "not "; - } - print "ok ",++$test,"\n"; -} - -eval 'sub t1 ($) : locked { $_[0]++ }'; -mytest; -BEGIN {++$ntests} - -eval 'sub t2 : locked { $_[0]++ }'; -mytest; -BEGIN {++$ntests} - -eval 'sub t3 ($) : locked ;'; -mytest; -BEGIN {++$ntests} - -eval 'sub t4 : locked ;'; -mytest; -BEGIN {++$ntests} - -my $anon1; -eval '$anon1 = sub ($) : locked:method { $_[0]++ }'; -mytest; -BEGIN {++$ntests} - -my $anon2; -eval '$anon2 = sub : locked : method { $_[0]++ }'; -mytest; -BEGIN {++$ntests} - -my $anon3; -eval '$anon3 = sub : method { $_[0]->[1] }'; -mytest; -BEGIN {++$ntests} - -eval 'sub e1 ($) : plugh ;'; -mytest qr/^Invalid CODE attributes?: ["']?plugh["']? at/; -BEGIN {++$ntests} - -eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; -mytest qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; -BEGIN {++$ntests} - -eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; -mytest qr/Unterminated attribute parameter in attribute list at/; -BEGIN {++$ntests} - -eval 'sub e4 ($) : plugh + xyzzy ;'; -mytest qr/Invalid separator character '[+]' in attribute list at/; -BEGIN {++$ntests} - -eval 'my main $x : = 0;'; -mytest; -BEGIN {++$ntests} - -eval 'my $x : = 0;'; -mytest; -BEGIN {++$ntests} - -eval 'my $x ;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x) : = 0;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x) ;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x) : ;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x,$y) : = 0;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x,$y) ;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x,$y) : ;'; -mytest; -BEGIN {++$ntests} - -eval 'my ($x,$y) : plugh;'; -mytest qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; -BEGIN {++$ntests} - -sub A::MODIFY_SCALAR_ATTRIBUTES { return } -eval 'my A $x : plugh;'; -mytest qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; -BEGIN {++$ntests} - -eval 'my A $x : plugh plover;'; -mytest qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; -BEGIN {++$ntests} - -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 : locked'; -mytest qr/^X at /; -BEGIN {++$ntests} - -my @attrs = eval 'attributes::get \&Y::bar'; -mytest '', "@attrs", "locked"; -BEGIN {++$ntests} - -@attrs = eval 'attributes::get $anon1'; -mytest '', "@attrs", "locked method"; -BEGIN {++$ntests} - -sub Z::DESTROY { } -sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' } -my $thunk = eval 'bless +sub : method locked { 1 }, "Z"'; -mytest '', ref($thunk), "Z"; -BEGIN {++$ntests} - -@attrs = eval 'attributes::get $thunk'; -mytest '', "@attrs", "locked method Z"; -BEGIN {++$ntests} - - -# Other tests should be added above this line - -sub NTESTS () { $ntests } - -exit $failed; diff --git a/contrib/perl5/t/op/auto.t b/contrib/perl5/t/op/auto.t deleted file mode 100755 index 2eb0097..0000000 --- a/contrib/perl5/t/op/auto.t +++ /dev/null @@ -1,52 +0,0 @@ -#!./perl - -# $RCSfile: auto.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:39 $ - -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";} diff --git a/contrib/perl5/t/op/avhv.t b/contrib/perl5/t/op/avhv.t deleted file mode 100755 index 5b91fd2..0000000 --- a/contrib/perl5/t/op/avhv.t +++ /dev/null @@ -1,178 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -require Tie::Array; - -package 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; - -print "1..28\n"; - -$sch = { - 'abc' => 1, - 'def' => 2, - 'jkl' => 3, -}; - -# basic normal array -$a = []; -$a->[0] = $sch; - -$a->{'abc'} = 'ABC'; -$a->{'def'} = 'DEF'; -$a->{'jkl'} = 'JKL'; - -@keys = keys %$a; -@values = values %$a; - -if ($#keys == 2 && $#values == 2) {print "ok 1\n";} else {print "not ok 1\n";} - -$i = 0; # stop -w complaints - -while (($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; - } -} - -if ($i == 3) {print "ok 2\n";} else {print "not ok 2\n";} - -# quick check with tied array -tie @fake, 'Tie::StdArray'; -$a = \@fake; -$a->[0] = $sch; - -$a->{'abc'} = 'ABC'; -if ($a->{'abc'} eq 'ABC') {print "ok 3\n";} else {print "not ok 3\n";} - -# quick check with tied array -tie @fake, 'Tie::BasicArray'; -$a = \@fake; -$a->[0] = $sch; - -$a->{'abc'} = 'ABC'; -if ($a->{'abc'} eq 'ABC') {print "ok 4\n";} else {print "not ok 4\n";} - -# quick check with tied array & tied hash -require Tie::Hash; -tie %fake, Tie::StdHash; -%fake = %$sch; -$a->[0] = \%fake; - -$a->{'abc'} = 'ABC'; -if ($a->{'abc'} eq 'ABC') {print "ok 5\n";} else {print "not ok 5\n";} - -# hash slice -my $slice = join('', 'x',@$a{'abc','def'},'x'); -print "not " if $slice ne 'xABCx'; -print "ok 6\n"; - -# evaluation in scalar context -my $avhv = [{}]; -print "not " if %$avhv; -print "ok 7\n"; - -push @$avhv, "a"; -print "not " if %$avhv; -print "ok 8\n"; - -$avhv = []; -eval { $a = %$avhv }; -print "not " unless $@ and $@ =~ /^Can't coerce array into hash/; -print "ok 9\n"; - -$avhv = [{foo=>1, bar=>2}]; -print "not " unless %$avhv =~ m,^\d+/\d+,; -print "ok 10\n"; - -# check if defelem magic works -sub f { - print "not " unless $_[0] eq 'a'; - $_[0] = 'b'; - print "ok 11\n"; -} -$a = [{key => 1}, 'a']; -f($a->{key}); -print "not " unless $a->[1] eq 'b'; -print "ok 12\n"; - -# check if exists() is behaving properly -$avhv = [{foo=>1,bar=>2,pants=>3}]; -print "not " if exists $avhv->{bar}; -print "ok 13\n"; - -$avhv->{pants} = undef; -print "not " unless exists $avhv->{pants}; -print "ok 14\n"; -print "not " if exists $avhv->{bar}; -print "ok 15\n"; - -$avhv->{bar} = 10; -print "not " unless exists $avhv->{bar} and $avhv->{bar} == 10; -print "ok 16\n"; - -$v = delete $avhv->{bar}; -print "not " unless $v == 10; -print "ok 17\n"; - -print "not " if exists $avhv->{bar}; -print "ok 18\n"; - -$avhv->{foo} = 'xxx'; -$avhv->{bar} = 'yyy'; -$avhv->{pants} = 'zzz'; -@x = delete @{$avhv}{'foo','pants'}; -print "# @x\nnot " unless "@x" eq "xxx zzz"; -print "ok 19\n"; - -print "not " unless "$avhv->{bar}" eq "yyy"; -print "ok 20\n"; - -# hash assignment -%$avhv = (); -print "not " unless ref($avhv->[0]) eq 'HASH'; -print "ok 21\n"; - -%hv = %$avhv; -print "not " if grep defined, values %hv; -print "ok 22\n"; -print "not " if grep ref, keys %hv; -print "ok 23\n"; - -%$avhv = (foo => 29, pants => 2, bar => 0); -print "not " unless "@$avhv[1..3]" eq '29 0 2'; -print "ok 24\n"; - -my $extra; -my @extra; -($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!"); -print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and $extra eq 'moo'; -print "ok 25\n"; - -%$avhv = (); -(%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!"); -print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and !defined $extra; -print "ok 26\n"; - -@extra = qw(whatever and stuff); -%$avhv = (); -(%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!"); -print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and @extra == 0; -print "ok 27\n"; - -%$avhv = (); -(@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!"); -print "not " unless ref $avhv->[0] eq 'HASH' and @extra == 6; -print "ok 28\n"; diff --git a/contrib/perl5/t/op/bop.t b/contrib/perl5/t/op/bop.t deleted file mode 100755 index 0354f00..0000000 --- a/contrib/perl5/t/op/bop.t +++ /dev/null @@ -1,171 +0,0 @@ -#!./perl - -# -# test the bit operators '&', '|', '^', '~', '<<', and '>>' -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..44\n"; - -# numerics -print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n"); -print ((0xdead | 0xbeef) == 0xfeef ? "ok 2\n" : "not ok 2\n"); -print ((0xdead ^ 0xbeef) == 0x6042 ? "ok 3\n" : "not ok 3\n"); -print ((~0xdead & 0xbeef) == 0x2042 ? "ok 4\n" : "not ok 4\n"); - -# shifts -print ((257 << 7) == 32896 ? "ok 5\n" : "not ok 5\n"); -print ((33023 >> 7) == 257 ? "ok 6\n" : "not ok 6\n"); - -# signed vs. unsigned -print ((~0 > 0 && do { use integer; ~0 } == -1) - ? "ok 7\n" : "not ok 7\n"); - -my $bits = 0; -for (my $i = ~0; $i; $i >>= 1) { ++$bits; } -my $cusp = 1 << ($bits - 1); - -print ((($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0) - ? "ok 8\n" : "not ok 8\n"); -print ((($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0) - ? "ok 9\n" : "not ok 9\n"); -print ((($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0) - ? "ok 10\n" : "not ok 10\n"); -print (((1 << ($bits - 1)) == $cusp && - do { use integer; 1 << ($bits - 1) } == -$cusp) - ? "ok 11\n" : "not ok 11\n"); -print ((($cusp >> 1) == ($cusp / 2) && - do { use integer; abs($cusp >> 1) } == ($cusp / 2)) - ? "ok 12\n" : "not ok 12\n"); - -$Aaz = chr(ord("A") & ord("z")); -$Aoz = chr(ord("A") | ord("z")); -$Axz = chr(ord("A") ^ ord("z")); - -# short strings -print (("AAAAA" & "zzzzz") eq ($Aaz x 5) ? "ok 13\n" : "not ok 13\n"); -print (("AAAAA" | "zzzzz") eq ($Aoz x 5) ? "ok 14\n" : "not ok 14\n"); -print (("AAAAA" ^ "zzzzz") eq ($Axz x 5) ? "ok 15\n" : "not ok 15\n"); - -# long strings -$foo = "A" x 150; -$bar = "z" x 75; -$zap = "A" x 75; -# & truncates -print (($foo & $bar) eq ($Aaz x 75 ) ? "ok 16\n" : "not ok 16\n"); -# | does not truncate -print (($foo | $bar) eq ($Aoz x 75 . $zap) ? "ok 17\n" : "not ok 17\n"); -# ^ does not truncate -print (($foo ^ $bar) eq ($Axz x 75 . $zap) ? "ok 18\n" : "not ok 18\n"); - -# -print "ok \xFF\xFF\n" & "ok 19\n"; -print "ok 20\n" | "ok \0\0\n"; -print "o\000 \0001\000" ^ "\000k\0002\000\n"; - -# -print "ok \x{FF}\x{FF}\n" & "ok 22\n"; -print "ok 23\n" | "ok \x{0}\x{0}\n"; -print "o\x{0} \x{0}4\x{0}" ^ "\x{0}k\x{0}2\x{0}\n"; - -# -print "ok 25\n" if sprintf("%vd", v4095 & v801) eq 801; -print "ok 26\n" if sprintf("%vd", v4095 | v801) eq 4095; -print "ok 27\n" if sprintf("%vd", v4095 ^ v801) eq 3294; - -# -print "ok 28\n" if sprintf("%vd", v4095.801.4095 & v801.4095) eq '801.801'; -print "ok 29\n" if sprintf("%vd", v4095.801.4095 | v801.4095) eq '4095.4095.4095'; -print "ok 30\n" if sprintf("%vd", v801.4095 ^ v4095.801.4095) eq '3294.3294.4095'; -# -print "ok 31\n" if sprintf("%vd", v120.300 & v200.400) eq '72.256'; -print "ok 32\n" if sprintf("%vd", v120.300 | v200.400) eq '248.444'; -print "ok 33\n" if sprintf("%vd", v120.300 ^ v200.400) eq '176.188'; -# -my $a = v120.300; -my $b = v200.400; -$a ^= $b; -print "ok 34\n" if sprintf("%vd", $a) eq '176.188'; -my $a = v120.300; -my $b = v200.400; -$a |= $b; -print "ok 35\n" if sprintf("%vd", $a) eq '248.444'; - -# -# UTF8 ~ behaviour -# - -my @not36; - -for (0x100...0xFFF) { - $a = ~(chr $_); - push @not36, sprintf("%#03X", $_) - if $a ne chr(~$_) or length($a) != 1 or ~$a ne chr($_); -} -if (@not36) { - print "# test 36 failed\n"; - print "not "; -} -print "ok 36\n"; - -my @not37; - -for my $i (0xEEE...0xF00) { - for my $j (0x0..0x120) { - $a = ~(chr ($i) . chr $j); - 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); - } -} -if (@not37) { - print "# test 37 failed\n"; - print "not "; -} -print "ok 37\n"; - -print "not " unless ~chr(~0) eq "\0"; -print "ok 38\n"; - -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)); - } -} -if (@not39) { - print "# test 39 failed\n"; - print "not "; -} -print "ok 39\n"; - -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)); - } -} -if (@not40) { - print "# test 40 failed\n"; - print "not "; -} -print "ok 40\n"; - -# More variations on 19 and 22. -print "ok \xFF\x{FF}\n" & "ok 41\n"; -print "ok \x{FF}\xFF\n" & "ok 42\n"; - -# Tests to see if you really can do casts negative floats to unsigned properly -$neg1 = -1.0; -print ((~ $neg1 == 0) ? "ok 43\n" : "not ok 43\n"); -$neg7 = -7.0; -print ((~ $neg7 == 6) ? "ok 44\n" : "not ok 44\n"); diff --git a/contrib/perl5/t/op/chars.t b/contrib/perl5/t/op/chars.t deleted file mode 100755 index efdea02..0000000 --- a/contrib/perl5/t/op/chars.t +++ /dev/null @@ -1,74 +0,0 @@ -#!./perl - -print "1..33\n"; - -# because of ebcdic.c these should be the same on asciiish -# and ebcdic machines. -# Peter Prymmer <pvhp@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"; diff --git a/contrib/perl5/t/op/chop.t b/contrib/perl5/t/op/chop.t deleted file mode 100755 index 1b55f11..0000000 --- a/contrib/perl5/t/op/chop.t +++ /dev/null @@ -1,118 +0,0 @@ -#!./perl - -print "1..37\n"; - -# optimized - -$_ = 'abc'; -$c = do foo(); -if ($c . $_ eq 'cab') {print "ok 1\n";} else {print "not ok 1 $c$_\n";} - -# unoptimized - -$_ = 'abc'; -$c = chop($_); -if ($c . $_ eq 'cab') {print "ok 2\n";} else {print "not ok 2\n";} - -sub foo { - chop; -} - -@foo = ("hi \n","there\n","!\n"); -@bar = @foo; -chop(@bar); -print join('',@bar) eq 'hi there!' ? "ok 3\n" : "not ok 3\n"; - -$foo = "\n"; -chop($foo,@foo); -print join('',$foo,@foo) eq 'hi there!' ? "ok 4\n" : "not ok 4\n"; - -$_ = "foo\n\n"; -print chomp() == 1 ? "ok 5\n" : "not ok 5\n"; -print $_ eq "foo\n" ? "ok 6\n" : "not ok 6\n"; - -$_ = "foo\n"; -print chomp() == 1 ? "ok 7\n" : "not ok 7\n"; -print $_ eq "foo" ? "ok 8\n" : "not ok 8\n"; - -$_ = "foo"; -print chomp() == 0 ? "ok 9\n" : "not ok 9\n"; -print $_ eq "foo" ? "ok 10\n" : "not ok 10\n"; - -$_ = "foo"; -$/ = "oo"; -print chomp() == 2 ? "ok 11\n" : "not ok 11\n"; -print $_ eq "f" ? "ok 12\n" : "not ok 12\n"; - -$_ = "bar"; -$/ = "oo"; -print chomp() == 0 ? "ok 13\n" : "not ok 13\n"; -print $_ eq "bar" ? "ok 14\n" : "not ok 14\n"; - -$_ = "f\n\n\n\n\n"; -$/ = ""; -print chomp() == 5 ? "ok 15\n" : "not ok 15\n"; -print $_ eq "f" ? "ok 16\n" : "not ok 16\n"; - -$_ = "f\n\n"; -$/ = ""; -print chomp() == 2 ? "ok 17\n" : "not ok 17\n"; -print $_ eq "f" ? "ok 18\n" : "not ok 18\n"; - -$_ = "f\n"; -$/ = ""; -print chomp() == 1 ? "ok 19\n" : "not ok 19\n"; -print $_ eq "f" ? "ok 20\n" : "not ok 20\n"; - -$_ = "f"; -$/ = ""; -print chomp() == 0 ? "ok 21\n" : "not ok 21\n"; -print $_ eq "f" ? "ok 22\n" : "not ok 22\n"; - -$_ = "xx"; -$/ = "xx"; -print chomp() == 2 ? "ok 23\n" : "not ok 23\n"; -print $_ eq "" ? "ok 24\n" : "not ok 24\n"; - -$_ = "axx"; -$/ = "xx"; -print chomp() == 2 ? "ok 25\n" : "not ok 25\n"; -print $_ eq "a" ? "ok 26\n" : "not ok 26\n"; - -$_ = "axx"; -$/ = "yy"; -print chomp() == 0 ? "ok 27\n" : "not ok 27\n"; -print $_ eq "axx" ? "ok 28\n" : "not ok 28\n"; - -# This case once mistakenly behaved like paragraph mode. -$_ = "ab\n"; -$/ = \3; -print chomp() == 0 ? "ok 29\n" : "not ok 29\n"; -print $_ eq "ab\n" ? "ok 30\n" : "not ok 30\n"; - -# Go Unicode. - -$_ = "abc\x{1234}"; -chop; -print $_ eq "abc" ? "ok 31\n" : "not ok 31\n"; - -$_ = "abc\x{1234}d"; -chop; -print $_ eq "abc\x{1234}" ? "ok 32\n" : "not ok 32\n"; - -$_ = "\x{1234}\x{2345}"; -chop; -print $_ eq "\x{1234}" ? "ok 33\n" : "not ok 33\n"; - -my @stuff = qw(this that); -print chop(@stuff[0,1]) eq 't' ? "ok 34\n" : "not ok 34\n"; - -# bug id 20010305.012 -@stuff = qw(ab cd ef); -print chop(@stuff = @stuff) eq 'f' ? "ok 35\n" : "not ok 35\n"; - -@stuff = qw(ab cd ef); -print chop(@stuff[0, 2]) eq 'f' ? "ok 36\n" : "not ok 36\n"; - -my %stuff = (1..4); -print chop(@stuff{1, 3}) eq '4' ? "ok 37\n" : "not ok 37\n"; diff --git a/contrib/perl5/t/op/closure.t b/contrib/perl5/t/op/closure.t deleted file mode 100755 index 5f3245f..0000000 --- a/contrib/perl5/t/op/closure.t +++ /dev/null @@ -1,507 +0,0 @@ -#!./perl -# -*- Mode: Perl -*- -# closure.t: -# Original written by Ulrich Pfeifer on 2 Jan 1997. -# Greatly extended by Tom Phoenix <rootbeer@teleport.com> on 28 Jan 1997. -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Config; - -print "1..171\n"; - -my $test = 1; -sub test (&) { - print ((&{$_[0]})?"ok $test\n":"not ok $test\n"); - $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@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"; - - $code .= <<"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 \$result = &{\$_[0]}; - print "not " unless \$result; - print "ok \$test\\n"; - \$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') { - # 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 './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 = (($^O eq 'VMS') ? "MCR $^X" - : ($^O eq 'MSWin32') ? '.\perl' - : './perl'); - $cmd .= " -w $cmdfile 2>$errfile"; - if ($^O eq 'VMS' or $^O eq 'MSWin32') { - # 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 - -} - diff --git a/contrib/perl5/t/op/cmp.t b/contrib/perl5/t/op/cmp.t deleted file mode 100755 index 4a7e68d..0000000 --- a/contrib/perl5/t/op/cmp.t +++ /dev/null @@ -1,35 +0,0 @@ -#!./perl - -@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1); - -$expect = ($#FOO+2) * ($#FOO+1); -print "1..$expect\n"; - -my $ok = 0; -for my $i (0..$#FOO) { - for my $j ($i..$#FOO) { - $ok++; - my $cmp = $FOO[$i] <=> $FOO[$j]; - if (!defined($cmp) || - $cmp == -1 && $FOO[$i] < $FOO[$j] || - $cmp == 0 && $FOO[$i] == $FOO[$j] || - $cmp == 1 && $FOO[$i] > $FOO[$j]) - { - print "ok $ok\n"; - } - else { - print "not ok $ok ($FOO[$i] <=> $FOO[$j]) gives: '$cmp'\n"; - } - $ok++; - $cmp = $FOO[$i] cmp $FOO[$j]; - if ($cmp == -1 && $FOO[$i] lt $FOO[$j] || - $cmp == 0 && $FOO[$i] eq $FOO[$j] || - $cmp == 1 && $FOO[$i] gt $FOO[$j]) - { - print "ok $ok\n"; - } - else { - print "not ok $ok ($FOO[$i] cmp $FOO[$j]) gives '$cmp'\n"; - } - } -} diff --git a/contrib/perl5/t/op/concat.t b/contrib/perl5/t/op/concat.t deleted file mode 100755 index 76074e0..0000000 --- a/contrib/perl5/t/op/concat.t +++ /dev/null @@ -1,100 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..11\n"; - -($a, $b, $c) = qw(foo bar); - -print "not " unless "$a" eq "foo"; -print "ok 1\n"; - -print "not " unless "$a$b" eq "foobar"; -print "ok 2\n"; - -print "not " unless "$c$a$c" eq "foo"; -print "ok 3\n"; - -# Okay, so that wasn't very challenging. Let's go Unicode. - -my $test = 4; - -{ - # bug id 20000819.004 - - $_ = $dx = "\x{10f2}"; - s/($dx)/$dx$1/; - { - use bytes; - print "not " unless $_ eq "$dx$dx"; - print "ok $test\n"; - $test++; - } - - $_ = $dx = "\x{10f2}"; - s/($dx)/$1$dx/; - { - use bytes; - print "not " unless $_ eq "$dx$dx"; - print "ok $test\n"; - $test++; - } - - $dx = "\x{10f2}"; - $_ = "\x{10f2}\x{10f2}"; - s/($dx)($dx)/$1$2/; - { - use bytes; - print "not " unless $_ eq "$dx$dx"; - print "ok $test\n"; - $test++; - } -} - -{ - # bug id 20000901.092 - # test that undef left and right of utf8 results in a valid string - - my $a; - $a .= "\x{1ff}"; - print "not " unless $a eq "\x{1ff}"; - print "ok $test\n"; - $test++; -} - -{ - # ID 20001020.006 - - "x" =~ /(.)/; # unset $2 - - # Without the fix this 5.7.0 would croak: - # Modification of a read-only value attempted at ... - "$2\x{1234}"; - - print "ok $test\n"; - $test++; - - # For symmetry with the above. - "\x{1234}$2"; - - print "ok $test\n"; - $test++; - - *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 ... - "$pi\x{1234}"; - - print "ok $test\n"; - $test++; - - # For symmetry with the above. - "\x{1234}$pi"; - - print "ok $test\n"; - $test++; -} diff --git a/contrib/perl5/t/op/cond.t b/contrib/perl5/t/op/cond.t deleted file mode 100755 index 427efb4..0000000 --- a/contrib/perl5/t/op/cond.t +++ /dev/null @@ -1,12 +0,0 @@ -#!./perl - -# $RCSfile: cond.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:41 $ - -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"; diff --git a/contrib/perl5/t/op/context.t b/contrib/perl5/t/op/context.t deleted file mode 100755 index 4625441..0000000 --- a/contrib/perl5/t/op/context.t +++ /dev/null @@ -1,18 +0,0 @@ -#!./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; diff --git a/contrib/perl5/t/op/defins.t b/contrib/perl5/t/op/defins.t deleted file mode 100755 index 33c74ea..0000000 --- a/contrib/perl5/t/op/defins.t +++ /dev/null @@ -1,147 +0,0 @@ -#!./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'; - -print "not " if $warns; -print "ok 1\n"; - -open(FILE,">./0"); -print FILE "1\n"; -print FILE "0"; -close(FILE); - -open(FILE,"<./0"); -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,'.'); -$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("./0"); - -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"; - diff --git a/contrib/perl5/t/op/delete.t b/contrib/perl5/t/op/delete.t deleted file mode 100755 index 10a218b..0000000 --- a/contrib/perl5/t/op/delete.t +++ /dev/null @@ -1,123 +0,0 @@ -#!./perl - -print "1..36\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('',@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"; -} diff --git a/contrib/perl5/t/op/die.t b/contrib/perl5/t/op/die.t deleted file mode 100755 index cf4f8b0..0000000 --- a/contrib/perl5/t/op/die.t +++ /dev/null @@ -1,43 +0,0 @@ -#!./perl - -print "1..10\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"; -} diff --git a/contrib/perl5/t/op/die_exit.t b/contrib/perl5/t/op/die_exit.t deleted file mode 100755 index a389946..0000000 --- a/contrib/perl5/t/op/die_exit.t +++ /dev/null @@ -1,59 +0,0 @@ -#!./perl - -# -# Verify that C<die> return the return code -# -- Robin Barker <rmb@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; -} - -my $perl = -e '../perl' ? '../perl' : -e './perl' ? './perl' : 'perl'; - -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"; - -foreach my $test (1 .. $max) { - my($bang, $query, $code) = @{$tests{$test}}; - $code ||= 'die;'; - my $exit = - ($^O eq 'MSWin32' - ? system qq($perl -e "\$! = $bang; \$? = $query; $code" 2> nul) - : system qq($perl -e '\$! = $bang; \$? = $query; $code' 2> /dev/null)); - - printf "# 0x%04x 0x%04x 0x%04x\n", $exit, $bang, $query; - print "not " unless $exit == (($bang || ($query >> 8) || 255) << 8); - print "ok $test\n"; -} - diff --git a/contrib/perl5/t/op/do.t b/contrib/perl5/t/op/do.t deleted file mode 100755 index 87ec08d..0000000 --- a/contrib/perl5/t/op/do.t +++ /dev/null @@ -1,44 +0,0 @@ -#!./perl - -# $RCSfile: do.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:45 $ - -sub foo1 -{ - print $_[0]; - 'value'; -} - -sub foo2 -{ - shift; - print $_[0]; - $x = 'value'; - $x; -} - -print "1..15\n"; - -$_[0] = "not ok 1\n"; -$result = do foo1("ok 1\n"); -print "#2\t:$result: eq :value:\n"; -if ($result EQ 'value') { print "ok 2\n"; } else { print "not ok 2\n"; } -if ($_[0] EQ "not ok 1\n") { print "ok 3\n"; } else { print "not ok 3\n"; } - -$_[0] = "not ok 4\n"; -$result = do foo2("not ok 4\n","ok 4\n","not ok 4\n"); -print "#5\t:$result: eq :value:\n"; -if ($result EQ 'value') { print "ok 5\n"; } else { print "not ok 5\n"; } -if ($_[0] EQ "not ok 4\n") { print "ok 6\n"; } else { print "not ok 6\n"; } - -$result = do{print "ok 7\n"; 'value';}; -print "#8\t:$result: eq :value:\n"; -if ($result EQ 'value') { print "ok 8\n"; } else { print "not ok 8\n"; } - -sub blather { - print @_; -} - -do blather("ok 9\n","ok 10\n"); -@x = ("ok 11\n", "ok 12\n"); -@y = ("ok 14\n", "ok 15\n"); -do blather(@x,"ok 13\n",@y); diff --git a/contrib/perl5/t/op/each.t b/contrib/perl5/t/op/each.t deleted file mode 100755 index 879c0d0..0000000 --- a/contrib/perl5/t/op/each.t +++ /dev/null @@ -1,133 +0,0 @@ -#!./perl - -print "1..19\n"; - -$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; - -if ($#keys == 29 && $#values == 29) {print "ok 1\n";} else {print "not ok 1\n";} - -$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; - } -} - -if ($i == 30) {print "ok 2\n";} else {print "not ok 2\n";} - -@keys = ('blurfl', keys(%h), 'dyick'); -if ($#keys == 31) {print "ok 3\n";} else {print "not ok 3\n";} - -$size = ((split('/',scalar %h))[1]); -keys %h = $size * 5; -$newsize = ((split('/',scalar %h))[1]); -if ($newsize == $size * 8) {print "ok 4\n";} else {print "not ok 4\n";} -keys %h = 1; -$size = ((split('/',scalar %h))[1]); -if ($size == $newsize) {print "ok 5\n";} else {print "not ok 5\n";} -%h = (1,1); -$size = ((split('/',scalar %h))[1]); -if ($size == $newsize) {print "ok 6\n";} else {print "not ok 6\n";} -undef %h; -%h = (1,1); -$size = ((split('/',scalar %h))[1]); -if ($size == 8) {print "ok 7\n";} else {print "not ok 7\n";} - -# test scalar each -%hash = 1..20; -$total = 0; -$total += $key while $key = each %hash; -print "# Scalar each is bad.\nnot " unless $total == 100; -print "ok 8\n"; - -for (1..3) { @foo = each %hash } -keys %hash; -$total = 0; -$total += $key while $key = each %hash; -print "# Scalar keys isn't resetting the iterator.\nnot " if $total != 100; -print "ok 9\n"; - -for (1..3) { @foo = each %hash } -$total = 0; -$total += $key while $key = each %hash; -print "# Iterator of each isn't being maintained.\nnot " if $total == 100; -print "ok 10\n"; - -for (1..3) { @foo = each %hash } -values %hash; -$total = 0; -$total += $key while $key = each %hash; -print "# Scalar values isn't resetting the iterator.\nnot " if $total != 100; -print "ok 11\n"; - -$size = (split('/', scalar %hash))[1]; -keys(%hash) = $size / 2; -print "not " if $size != (split('/', scalar %hash))[1]; -print "ok 12\n"; -keys(%hash) = $size + 100; -print "not " if $size == (split('/', scalar %hash))[1]; -print "ok 13\n"; - -print "not " if keys(%hash) != 10; -print "ok 14\n"; - -print keys(hash) != 10 ? "not ok 15\n" : "ok 15\n"; - -$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++; - } -} -if ($i == 5) { print "ok 16\n" } else { print "not ok\n" } - -{ - package Obj; - sub DESTROY { print "ok 18\n"; } - { - my $h = { A => bless [], __PACKAGE__ }; - while (my($k,$v) = each %$h) { - print "ok 17\n" if $k eq 'A' and ref($v) eq 'Obj'; - } - } - print "ok 19\n"; -} - diff --git a/contrib/perl5/t/op/eval.t b/contrib/perl5/t/op/eval.t deleted file mode 100755 index 1838923..0000000 --- a/contrib/perl5/t/op/eval.t +++ /dev/null @@ -1,208 +0,0 @@ -#!./perl - -print "1..40\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 { 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 { eval q[print "ok $x\n"] }->()'); -$x++; -EOT - -# calls outside eval'' should NOT clone lexicals from called context - -$main::x = 'ok'; -eval <<'EOT'; die if $@; - # $x unbound here - sub do_eval3 { - eval $_[0]; die if $@; - } -EOT -do_eval3('print "$x ' . $x . '\n"'); -$x++; -do_eval3('eval q[print "$x ' . $x . '\n"]'); -$x++; -do_eval3('sub { eval q[print "$x ' . $x . '\n"] }->()'); -$x++; - -# 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++; -} diff --git a/contrib/perl5/t/op/exec.t b/contrib/perl5/t/op/exec.t deleted file mode 100755 index 23e9ec1..0000000 --- a/contrib/perl5/t/op/exec.t +++ /dev/null @@ -1,48 +0,0 @@ -#!./perl - -$| = 1; # flush stdout - -$ENV{LC_ALL} = 'C'; # Forge English error messages. -$ENV{LANGUAGE} = 'C'; # Ditto in GNU. - -if ($^O eq 'MSWin32') { - # XXX the system tests could be written to use ./perl and so work on Win32 - print "1..0 # Skip: shh, win32\n"; - exit(0); -} - -print "1..8\n"; - -if ($^O ne 'os2') { - print "not ok 1\n" if system "echo ok \\1"; # shell interpreted -} -else { - print "ok 1 # skipped: bug/feature of pdksh\n"; # shell interpreted -} -print "not ok 2\n" if system "echo ok 2"; # split and directly called -print "not ok 3\n" if system "echo", "ok", "3"; # directly called - -# these should probably be rewritten to match the examples in perlfunc.pod -if (system "true") {print "not ok 4\n";} else {print "ok 4\n";} - -if ($^O eq 'mpeix') { - print "ok 5 # skipped: status broken on MPE/iX\n"; -} else { - if ((system "/bin/sh -c 'exit 1'") != 256) { print "not "; } - print "ok 5\n"; -} - -$rc = system "lskdfj"; -if ($rc == 255 << 8 or $rc == -1 and - ( - $! == 2 or - $! =~ /\bno\b.*\bfile/i or - $! == 13 or - $! =~ /permission denied/i - ) - ) - {print "ok 6\n";} else {print "not ok 6\n";} - -unless (exec "lskdjfalksdjfdjfkls") {print "ok 7\n";} else {print "not ok 7\n";} - -exec "echo","ok","8"; diff --git a/contrib/perl5/t/op/exists_sub.t b/contrib/perl5/t/op/exists_sub.t deleted file mode 100755 index d4aa292..0000000 --- a/contrib/perl5/t/op/exists_sub.t +++ /dev/null @@ -1,46 +0,0 @@ -#!./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; diff --git a/contrib/perl5/t/op/exp.t b/contrib/perl5/t/op/exp.t deleted file mode 100755 index 5efc9ba..0000000 --- a/contrib/perl5/t/op/exp.t +++ /dev/null @@ -1,27 +0,0 @@ -#!./perl - -# $RCSfile: exp.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:50 $ - -print "1..6\n"; - -# compile time evaluation - -$s = sqrt(2); -if (substr($s,0,5) eq '1.414') {print "ok 1\n";} else {print "not ok 1\n";} - -$s = exp(1); -if (substr($s,0,7) eq '2.71828') {print "ok 2\n";} else {print "not ok 2\n";} - -if (exp(log(1)) == 1) {print "ok 3\n";} else {print "not ok 3\n";} - -# run time evaluation - -$x1 = 1; -$x2 = 2; -$s = sqrt($x2); -if (substr($s,0,5) eq '1.414') {print "ok 4\n";} else {print "not ok 4\n";} - -$s = exp($x1); -if (substr($s,0,7) eq '2.71828') {print "ok 5\n";} else {print "not ok 5\n";} - -if (exp(log($x1)) == 1) {print "ok 6\n";} else {print "not ok 6\n";} diff --git a/contrib/perl5/t/op/fh.t b/contrib/perl5/t/op/fh.t deleted file mode 100755 index 86e405a..0000000 --- a/contrib/perl5/t/op/fh.t +++ /dev/null @@ -1,26 +0,0 @@ -#!./perl - -print "1..5\n"; - -my $test = 0; - -# symbolic filehandles should only result in glob entries with FH constructors - -$|=1; -my $a = "SYM000"; -print "not " if defined(fileno($a)) or defined *{$a}; -++$test; print "ok $test\n"; - -select select $a; -print "not " unless defined *{$a}; -++$test; print "ok $test\n"; - -$a++; -print "not " if close $a or defined *{$a}; -++$test; print "ok $test\n"; - -print "not " unless open($a, ">&STDOUT") and defined *{$a}; -++$test; print $a "ok $test\n"; - -print "not " unless close $a; -++$test; print $a "not "; print "ok $test\n"; diff --git a/contrib/perl5/t/op/filetest.t b/contrib/perl5/t/op/filetest.t deleted file mode 100755 index f757c79..0000000 --- a/contrib/perl5/t/op/filetest.t +++ /dev/null @@ -1,71 +0,0 @@ -#!./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'; -} - -use Config; -print "1..10\n"; - -print "not " unless -d 'op'; -print "ok 1\n"; - -print "not " unless -f 'TEST'; -print "ok 2\n"; - -print "not " if -f 'op'; -print "ok 3\n"; - -print "not " if -d 'TEST'; -print "ok 4\n"; - -print "not " unless -r 'TEST'; -print "ok 5\n"; - -# make sure TEST is r-x -eval { chmod 0555, 'TEST' }; -$bad_chmod = $@; - -$oldeuid = $>; # root can read and write anything -eval '$> = 1'; # so switch uid (may not be implemented) - -print "# oldeuid = $oldeuid, euid = $>\n"; - -if (!$Config{d_seteuid}) { - print "ok 6 #skipped, no seteuid\n"; -} -elsif ($bad_chmod) { - print "#[$@]\nok 6 #skipped\n"; -} -else { - print "not " if -w 'TEST'; - print "ok 6\n"; -} - -# 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...) -print "not " unless -r 'op'; -print "ok 7\n"; - -# this would fail for the euid 1 -# (unless we have unpacked the source code as uid 1...) -if ($Config{d_seteuid}) { - print "not " unless -w 'op'; - print "ok 8\n"; -} else { - print "ok 8 #skipped, no seteuid\n"; -} - -print "not " unless -x 'op'; # Hohum. Are directories -x everywhere? -print "ok 9\n"; - -print "not " unless "@{[grep -r, qw(foo io noo op zoo)]}" eq "io op"; -print "ok 10\n"; diff --git a/contrib/perl5/t/op/flip.t b/contrib/perl5/t/op/flip.t deleted file mode 100755 index 99b22ef..0000000 --- a/contrib/perl5/t/op/flip.t +++ /dev/null @@ -1,36 +0,0 @@ -#!./perl - -# $RCSfile: flip.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:52 $ - -print "1..10\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'); - -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; - print "ok 10\n" unless 1 .. 10; -} diff --git a/contrib/perl5/t/op/fork.t b/contrib/perl5/t/op/fork.t deleted file mode 100755 index 88b6b4b..0000000 --- a/contrib/perl5/t/op/fork.t +++ /dev/null @@ -1,423 +0,0 @@ -#!./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' and $Config{useithreads} - and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/)) - { - 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 <>"' : '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`; - } - 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') { - $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 diff --git a/contrib/perl5/t/op/glob.t b/contrib/perl5/t/op/glob.t deleted file mode 100755 index fc0ba77..0000000 --- a/contrib/perl5/t/op/glob.t +++ /dev/null @@ -1,40 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..6\n"; - -@oops = @ops = <op/*>; - -if ($^O eq 'MSWin32') { - map { $files{lc($_)}++ } <op/*>; - map { delete $files{"op/$_"} } split /[\s\n]/, `cmd /c "dir /b /l op & dir /b /l /ah op 2>nul"`, -} -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"; - -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 -$_ = "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"; diff --git a/contrib/perl5/t/op/goto.t b/contrib/perl5/t/op/goto.t deleted file mode 100755 index 96bb8dd..0000000 --- a/contrib/perl5/t/op/goto.t +++ /dev/null @@ -1,126 +0,0 @@ -#!./perl - -# "This IS structured code. It's just randomly structured." - -print "1..16\n"; - -while ($?) { - $foo = 1; - label1: - $foo = 2; - goto label2; -} continue { - $foo = 0; - goto label4; - label3: - $foo = 4; - goto label4; -} -goto label1; - -$foo = 3; - -label2: -print "#1\t:$foo: == 2\n"; -if ($foo == 2) {print "ok 1\n";} else {print "not ok 1\n";} -goto label3; - -label4: -print "#2\t:$foo: == 4\n"; -if ($foo == 4) {print "ok 2\n";} else {print "not ok 2\n";} - -$PERL = ($^O eq 'MSWin32') ? '.\perl' : './perl'; -$CMD = qq[$PERL -e "goto foo;" 2>&1 ]; -$x = `$CMD`; - -if ($x =~ /label/) {print "ok 3\n";} else {print "not ok 3\n";} - -sub foo { - goto bar; - print "not ok 4\n"; - return; -bar: - print "ok 4\n"; -} - -&foo; - -sub bar { - $x = 'bypass'; - eval "goto $x"; -} - -&bar; -exit; - -FINALE: -print "ok 13\n"; - -# does goto LABEL handle block contexts correctly? - -my $cond = 1; -for (1) { - if ($cond == 1) { - $cond = 0; - goto OTHER; - } - elsif ($cond == 0) { - OTHER: - $cond = 2; - print "ok 14\n"; - goto THIRD; - } - else { - THIRD: - print "ok 15\n"; - } -} -print "ok 16\n"; -exit; - -bypass: -print "ok 5\n"; - -# Test autoloading mechanism. - -sub two { - ($pack, $file, $line) = caller; # Should indicate original call stats. - print "@_ $pack $file $line" eq "1 2 3 main $FILE $LINE" - ? "ok 7\n" - : "not ok 7\n"; -} - -sub one { - eval <<'END'; - sub one { print "ok 6\n"; goto &two; print "not ok 6\n"; } -END - goto &one; -} - -$FILE = __FILE__; -$LINE = __LINE__ + 1; -&one(1,2,3); - -$wherever = NOWHERE; -eval { goto $wherever }; -print $@ =~ /Can't find label NOWHERE/ ? "ok 8\n" : "not ok 8\n"; - -# see if a modified @_ propagates -{ - package Foo; - sub DESTROY { my $s = shift; print "ok $s->[0]\n"; } - sub show { print "# @_\nnot ok $_[0][0]\n" if @_ != 5; } - sub start { push @_, 1, "foo", {}; goto &show; } - for (9..11) { start(bless([$_]), 'bar'); } -} - -sub auto { - goto &loadit; -} - -sub AUTOLOAD { print @_ } - -auto("ok 12\n"); - -$wherever = FINALE; -goto $wherever; diff --git a/contrib/perl5/t/op/goto_xs.t b/contrib/perl5/t/op/goto_xs.t deleted file mode 100755 index cf2cafd..0000000 --- a/contrib/perl5/t/op/goto_xs.t +++ /dev/null @@ -1,98 +0,0 @@ -#!./perl -# tests for "goto &sub"-ing into XSUBs - -# $RCSfile$$Revision$$Date$ - -# 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. - -chdir 't' if -d 't'; -@INC = '../lib'; -$ENV{PERL5LIB} = "../lib"; - -# turn warnings into fatal errors -$SIG{__WARN__} = sub { die "WARNING: @_" } ; - -BEGIN { $| = 1; } -eval 'require Fcntl' - or do { print "1..0\n# Fcntl 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,0); -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,0); -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,0); -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,0); -print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n"); -$ret = goto_name1($VALID,0); -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,0); -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,0); -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,0); -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,0); -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,0); -print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n"); diff --git a/contrib/perl5/t/op/grent.t b/contrib/perl5/t/op/grent.t deleted file mode 100755 index 211dc91..0000000 --- a/contrib/perl5/t/op/grent.t +++ /dev/null @@ -1,168 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - eval {my @n = getgrgid 0}; - if ($@ && $@ =~ /(The \w+ function is unimplemented)/) { - print "1..0 # Skip: $1\n"; - exit 0; - } - 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>)) { - $where = "NIS group"; - 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"; - undef $reason; - last; - } - } - } - - if (not defined $where) { # Try local. - my $GR = "/etc/group"; - if (-f $GR && open(GR, $GR) && defined(<GR>)) { - undef $reason; - $where = $GR; - } - } - if ($reason) { - print "1..0 # Skip: $reason\n"; - exit 0; - } -} - -# By now the GR filehandle should be open and full of juicy group entries. - -print "1..2\n"; - -# 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; - -setgrent(); -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(); - -if (keys %perfect == 0) { - $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 - print "not "; - $not = 1; -} else { - $not = 0; -} -print "ok ", $tst++; -print "\t# (not necessarily serious: run t/op/grent.t by itself)" if $not; -print "\n"; - -# 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(); - -print "not " unless "@gr1" eq "@gr2"; -print "ok ", $tst++, "\n"; - -close(GR); diff --git a/contrib/perl5/t/op/grep.t b/contrib/perl5/t/op/grep.t deleted file mode 100755 index 3a7f8ad..0000000 --- a/contrib/perl5/t/op/grep.t +++ /dev/null @@ -1,99 +0,0 @@ -#!./perl - -# -# grep() and map() tests -# - -print "1..27\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++; -} diff --git a/contrib/perl5/t/op/groups.t b/contrib/perl5/t/op/groups.t deleted file mode 100755 index 082d2d1..0000000 --- a/contrib/perl5/t/op/groups.t +++ /dev/null @@ -1,143 +0,0 @@ -#!./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 - -sub quit { - print "1..0 # Skip: no `id` or `groups`\n"; - exit 0; -} - -quit() if $^O eq 'MSWin32' 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 -# luser may belong to, using the 'perlbug' program. -EOM - } - last GROUPS; - } - # Okay, not today. - quit(); -} - -unless (eval { getgrgid(0); 1 }) { - print "1..0 # Skip: getgrgid() not implemented\n"; - exit 0; -} - -# 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); -@basegroup{$pwgid,$pwgnam} = (1,1); - -$seen{$pwgid}++; - -for (split(' ', $()) { - next if $seen{$_}++; - ($group) = getgrgid($_); - if (defined $group) { - push(@gr, $group); - } - else { - push(@gr, $_); - } -} - -if ($^O =~ /^(?:uwin|solaris)$/) { - # Or anybody else who can have spaces in group names. - $gr1 = join(' ', grep(!$did{$_}++, sort split(' ', join(' ', @gr)))); -} else { - $gr1 = join(' ', sort @gr); -} - -$gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups))); - -if ($gr1 eq $gr2) { - print "ok 1\n"; -} -else { - 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"; -} diff --git a/contrib/perl5/t/op/gv.t b/contrib/perl5/t/op/gv.t deleted file mode 100755 index 8311244..0000000 --- a/contrib/perl5/t/op/gv.t +++ /dev/null @@ -1,176 +0,0 @@ -#!./perl - -# -# various typeglob tests -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use warnings; - -print "1..40\n"; - -# type coersion on assignment -$foo = 'foo'; -$bar = *main::foo; -$bar = $foo; -print ref(\$bar) eq 'SCALAR' ? "ok 1\n" : "not ok 1\n"; -$foo = *main::bar; - -# type coersion (not) on misc ops - -if ($foo) { - print ref(\$foo) eq 'GLOB' ? "ok 2\n" : "not ok 2\n"; -} - -unless ($foo =~ /abcd/) { - print ref(\$foo) eq 'GLOB' ? "ok 3\n" : "not ok 3\n"; -} - -if ($foo eq '*main::bar') { - print ref(\$foo) eq 'GLOB' ? "ok 4\n" : "not ok 4\n"; -} - -# type coersion on substitutions that match -$a = *main::foo; -$b = $a; -$a =~ s/^X//; -print ref(\$a) eq 'GLOB' ? "ok 5\n" : "not ok 5\n"; -$a =~ s/^\*//; -print $a eq 'main::foo' ? "ok 6\n" : "not ok 6\n"; -print ref(\$b) eq 'GLOB' ? "ok 7\n" : "not ok 7\n"; - -# typeglobs as lvalues -substr($foo, 0, 1) = "XXX"; -print ref(\$foo) eq 'SCALAR' ? "ok 8\n" : "not ok 8\n"; -print $foo eq 'XXXmain::bar' ? "ok 9\n" : "not ok 9\n"; - -# returning glob values -sub foo { - local($bar) = *main::foo; - $foo = *main::bar; - return ($foo, $bar); -} - -($fuu, $baa) = foo(); -if (defined $fuu) { - print ref(\$fuu) eq 'GLOB' ? "ok 10\n" : "not ok 10\n"; -} - -if (defined $baa) { - print ref(\$baa) eq 'GLOB' ? "ok 11\n" : "not ok 11\n"; -} - -# 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; } -print exists $Foo::{'Bar::'} ? "ok 12\n" : "not ok 12\n"; -print $Foo::{'Bar::'} eq '*Foo::Bar::' ? "ok 13\n" : "not ok 13\n"; - -# test undef operator clearing out entire glob -$foo = 'stuff'; -@foo = qw(more stuff); -%foo = qw(even more random stuff); -undef *foo; -print +($foo || @foo || %foo) ? "not ok" : "ok", " 14\n"; - -# test warnings from assignment of undef to glob -{ - my $msg; - local $SIG{__WARN__} = sub { $msg = $_[0] }; - use warnings; - *foo = 'bar'; - print $msg ? "not ok" : "ok", " 15\n"; - *foo = undef; - print $msg ? "ok" : "not ok", " 16\n"; -} - -# test *glob{THING} syntax -$x = "ok 17\n"; -@x = ("ok 18\n"); -%x = ("ok 19" => "\n"); -sub x { "ok 20\n" } -print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}}; -*x = *STDOUT; -print *{*x{GLOB}} eq "*main::STDOUT" ? "ok 21\n" : "not ok 21\n"; -print {*x{IO}} "ok 22\n"; -print {*x{FILEHANDLE}} "ok 23\n"; - -# test if defined() doesn't create any new symbols - -{ - my $test = 23; - - my $a = "SYM000"; - print "not " if defined *{$a}; - ++$test; print "ok $test\n"; - - print "not " if defined @{$a} or defined *{$a}; - ++$test; print "ok $test\n"; - - print "not " if defined %{$a} or defined *{$a}; - ++$test; print "ok $test\n"; - - print "not " if defined ${$a} or defined *{$a}; - ++$test; print "ok $test\n"; - - print "not " if defined &{$a} or defined *{$a}; - ++$test; print "ok $test\n"; - - *{$a} = sub { print "ok $test\n" }; - print "not " unless defined &{$a} and defined *{$a}; - ++$test; &{$a}; -} - -# although it *should* if you're talking about magicals - -{ - my $test = 29; - - my $a = "]"; - print "not " unless defined ${$a}; - ++$test; print "ok $test\n"; - print "not " unless defined *{$a}; - ++$test; print "ok $test\n"; - - $a = "1"; - "o" =~ /(o)/; - print "not " unless ${$a}; - ++$test; print "ok $test\n"; - print "not " unless defined *{$a}; - ++$test; print "ok $test\n"; - $a = "2"; - print "not " if ${$a}; - ++$test; print "ok $test\n"; - print "not " unless defined *{$a}; - ++$test; print "ok $test\n"; - $a = "1x"; - print "not " if defined ${$a}; - ++$test; print "ok $test\n"; - print "not " if defined *{$a}; - ++$test; print "ok $test\n"; - $a = "11"; - "o" =~ /(((((((((((o)))))))))))/; - print "not " unless ${$a}; - ++$test; print "ok $test\n"; - print "not " unless defined *{$a}; - ++$test; print "ok $test\n"; -} - - -# does pp_readline() handle glob-ness correctly? - -{ - my $g = *foo; - $g = <DATA>; - print $g; -} - -__END__ -ok 40 diff --git a/contrib/perl5/t/op/hashwarn.t b/contrib/perl5/t/op/hashwarn.t deleted file mode 100755 index 8466a71..0000000 --- a/contrib/perl5/t/op/hashwarn.t +++ /dev/null @@ -1,77 +0,0 @@ -#!./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@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/'; -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_msg; - 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; - - 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"; -} diff --git a/contrib/perl5/t/op/inc.t b/contrib/perl5/t/op/inc.t deleted file mode 100755 index f59115e..0000000 --- a/contrib/perl5/t/op/inc.t +++ /dev/null @@ -1,97 +0,0 @@ -#!./perl - -print "1..12\n"; - -# 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. - -$a = 2147483647; -$c=$a++; -if ($a == 2147483648) - {print "ok 1\n"} -else - {print "not ok 1\n";} - -$a = 2147483647; -$c=++$a; -if ($a == 2147483648) - {print "ok 2\n"} -else - {print "not ok 2\n";} - -$a = 2147483647; -$a=$a+1; -if ($a == 2147483648) - {print "ok 3\n"} -else - {print "not ok 3\n";} - -$a = -2147483648; -$c=$a--; -if ($a == -2147483649) - {print "ok 4\n"} -else - {print "not ok 4\n";} - -$a = -2147483648; -$c=--$a; -if ($a == -2147483649) - {print "ok 5\n"} -else - {print "not ok 5\n";} - -$a = -2147483648; -$a=$a-1; -if ($a == -2147483649) - {print "ok 6\n"} -else - {print "not ok 6\n";} - -$a = 2147483648; -$a = -$a; -$c=$a--; -if ($a == -2147483649) - {print "ok 7\n"} -else - {print "not ok 7\n";} - -$a = 2147483648; -$a = -$a; -$c=--$a; -if ($a == -2147483649) - {print "ok 8\n"} -else - {print "not ok 8\n";} - -$a = 2147483648; -$a = -$a; -$a=$a-1; -if ($a == -2147483649) - {print "ok 9\n"} -else - {print "not ok 9\n";} - -$a = 2147483648; -$b = -$a; -$c=$b--; -if ($b == -$a-1) - {print "ok 10\n"} -else - {print "not ok 10\n";} - -$a = 2147483648; -$b = -$a; -$c=--$b; -if ($b == -$a-1) - {print "ok 11\n"} -else - {print "not ok 11\n";} - -$a = 2147483648; -$b = -$a; -$b=$b-1; -if ($b == -(++$a)) - {print "ok 12\n"} -else - {print "not ok 12\n";} diff --git a/contrib/perl5/t/op/index.t b/contrib/perl5/t/op/index.t deleted file mode 100755 index 0b08f08..0000000 --- a/contrib/perl5/t/op/index.t +++ /dev/null @@ -1,42 +0,0 @@ -#!./perl - -# $RCSfile: index.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:59 $ - -print "1..20\n"; - - -$foo = 'Now is the time for all good men to come to the aid of their country.'; - -$first = substr($foo,0,index($foo,'the')); -print ($first eq "Now is " ? "ok 1\n" : "not ok 1\n"); - -$last = substr($foo,rindex($foo,'the'),100); -print ($last eq "their country." ? "ok 2\n" : "not ok 2\n"); - -$last = substr($foo,index($foo,'Now'),2); -print ($last eq "No" ? "ok 3\n" : "not ok 3\n"); - -$last = substr($foo,rindex($foo,'Now'),2); -print ($last eq "No" ? "ok 4\n" : "not ok 4\n"); - -$last = substr($foo,index($foo,'.'),100); -print ($last eq "." ? "ok 5\n" : "not ok 5\n"); - -$last = substr($foo,rindex($foo,'.'),100); -print ($last eq "." ? "ok 6\n" : "not ok 6\n"); - -print index("ababa","a",-1) == 0 ? "ok 7\n" : "not ok 7\n"; -print index("ababa","a",0) == 0 ? "ok 8\n" : "not ok 8\n"; -print index("ababa","a",1) == 2 ? "ok 9\n" : "not ok 9\n"; -print index("ababa","a",2) == 2 ? "ok 10\n" : "not ok 10\n"; -print index("ababa","a",3) == 4 ? "ok 11\n" : "not ok 11\n"; -print index("ababa","a",4) == 4 ? "ok 12\n" : "not ok 12\n"; -print index("ababa","a",5) == -1 ? "ok 13\n" : "not ok 13\n"; - -print rindex("ababa","a",-1) == -1 ? "ok 14\n" : "not ok 14\n"; -print rindex("ababa","a",0) == 0 ? "ok 15\n" : "not ok 15\n"; -print rindex("ababa","a",1) == 0 ? "ok 16\n" : "not ok 16\n"; -print rindex("ababa","a",2) == 2 ? "ok 17\n" : "not ok 17\n"; -print rindex("ababa","a",3) == 2 ? "ok 18\n" : "not ok 18\n"; -print rindex("ababa","a",4) == 4 ? "ok 19\n" : "not ok 19\n"; -print rindex("ababa","a",5) == 4 ? "ok 20\n" : "not ok 20\n"; diff --git a/contrib/perl5/t/op/int.t b/contrib/perl5/t/op/int.t deleted file mode 100755 index 7d675a4..0000000 --- a/contrib/perl5/t/op/int.t +++ /dev/null @@ -1,36 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..7\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"; diff --git a/contrib/perl5/t/op/join.t b/contrib/perl5/t/op/join.t deleted file mode 100755 index 0f849fd..0000000 --- a/contrib/perl5/t/op/join.t +++ /dev/null @@ -1,67 +0,0 @@ -#!./perl - -print "1..14\n"; - -@x = (1, 2, 3); -if (join(':',@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"; -} - diff --git a/contrib/perl5/t/op/length.t b/contrib/perl5/t/op/length.t deleted file mode 100755 index ceb005e..0000000 --- a/contrib/perl5/t/op/length.t +++ /dev/null @@ -1,85 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..13\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 = "\x{80}"; - - print "not " unless length($a) == 1; - print "ok 6\n"; - $test++; - - use bytes; - print "not " unless $a eq "\xc2\x80" && 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; - 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; - 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; - print "not " unless $a eq "\xc2\x80\xc4\x80" && length($a) == 4; - print "ok 13\n"; - $test++; -} diff --git a/contrib/perl5/t/op/lex_assign.t b/contrib/perl5/t/op/lex_assign.t deleted file mode 100755 index d761f73..0000000 --- a/contrib/perl5/t/op/lex_assign.t +++ /dev/null @@ -1,325 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -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 "","","",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 diff --git a/contrib/perl5/t/op/lfs.t b/contrib/perl5/t/op/lfs.t deleted file mode 100755 index 0a1c399..0000000 --- a/contrib/perl5/t/op/lfs.t +++ /dev/null @@ -1,272 +0,0 @@ -# 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 t/lib/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 @_; -} - -print "# checking whether we have sparse files...\n"; - -# Known have-nots. -if ($^O eq 'MSWin32' || $^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 $^0, 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 "big"; # be paranoid about leaving 5 gig files lying around -} - -# eof diff --git a/contrib/perl5/t/op/list.t b/contrib/perl5/t/op/list.t deleted file mode 100755 index 4d7a2d5..0000000 --- a/contrib/perl5/t/op/list.t +++ /dev/null @@ -1,89 +0,0 @@ -#!./perl - -print "1..28\n"; - -@foo = (1, 2, 3, 4); -if ($foo[0] == 1 && $foo[3] == 4) {print "ok 1\n";} else {print "not ok 1\n";} - -$_ = join(':',@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(':',@foo,@bar) eq '1:1') {print "ok 12\n";} else {print "not ok 12\n";} - -@foo = (); -@foo = 1+2+3; -if (join(':',@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('',@a) eq '123') {print "ok 17\n";} else {print "not ok 17\n";} - -@a = ($x == $x || (4,5,6)); -if (join('',@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"; -} diff --git a/contrib/perl5/t/op/local.t b/contrib/perl5/t/op/local.t deleted file mode 100755 index cf606b7..0000000 --- a/contrib/perl5/t/op/local.t +++ /dev/null @@ -1,234 +0,0 @@ -#!./perl - -print "1..69\n"; - -sub foo { - local($a, $b) = @_; - local($c, $d); - $c = "ok 3\n"; - $d = "ok 4\n"; - { local($a,$c) = ("ok 9\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 { - local($a, @b) = @_; - local(@c, %d); - @c = "ok 13\n"; - $d{''} = "ok 14\n"; - { local($a,@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,@b,@c,%d,$x,$y; - -eval 'local($$e)'; -print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 21\n"; - -eval 'local(@$e)'; -print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 22\n"; - -eval 'local(%$e)'; -print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 23\n"; - -# Array and hash elements - -@a = ('a', 'b', 'c'); -{ - local($a[1]) = 'foo'; - local($a[2]) = $a[2]; - print +($a[1] eq 'foo') ? "" : "not ", "ok 24\n"; - print +($a[2] eq 'c') ? "" : "not ", "ok 25\n"; - undef @a; -} -print +($a[1] eq 'b') ? "" : "not ", "ok 26\n"; -print +($a[2] eq 'c') ? "" : "not ", "ok 27\n"; -print +(!defined $a[0]) ? "" : "not ", "ok 28\n"; - -@a = ('a', 'b', 'c'); -{ - local($a[1]) = "X"; - shift @a; -} -print +($a[0].$a[1] eq "Xb") ? "" : "not ", "ok 29\n"; - -%h = ('a' => 1, 'b' => 2, 'c' => 3); -{ - local($h{'a'}) = 'foo'; - local($h{'b'}) = $h{'b'}; - print +($h{'a'} eq 'foo') ? "" : "not ", "ok 30\n"; - print +($h{'b'} == 2) ? "" : "not ", "ok 31\n"; - local($h{'c'}); - delete $h{'c'}; -} -print +($h{'a'} == 1) ? "" : "not ", "ok 32\n"; -print +($h{'b'} == 2) ? "" : "not ", "ok 33\n"; -print +($h{'c'} == 3) ? "" : "not ", "ok 34\n"; - -# check for scope leakage -$a = 'outer'; -if (1) { local $a = 'inner' } -print +($a eq 'outer') ? "" : "not ", "ok 35\n"; - -# see if localization works when scope unwinds -local $m = 5; -eval { - for $m (6) { - local $m = 7; - die "bye"; - } -}; -print $m == 5 ? "" : "not ", "ok 36\n"; - -# 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]; - print +($a[1] eq 'foo') ? "" : "not ", "ok 37\n"; - print +($a[2] eq 'c') ? "" : "not ", "ok 38\n"; - @a = (); -} -print +($a[1] eq 'b') ? "" : "not ", "ok 39\n"; -print +($a[2] eq 'c') ? "" : "not ", "ok 40\n"; -print +(!defined $a[0]) ? "" : "not ", "ok 41\n"; - -{ - 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 DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; } - sub CLEAR { print "# CLEAR [@_]\n"; %{$_[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'}; - print +($h{'a'} eq 'foo') ? "" : "not ", "ok 42\n"; - print +($h{'b'} == 2) ? "" : "not ", "ok 43\n"; - local($h{'c'}); - delete $h{'c'}; -} -print +($h{'a'} == 1) ? "" : "not ", "ok 44\n"; -print +($h{'b'} == 2) ? "" : "not ", "ok 45\n"; -print +($h{'c'} == 3) ? "" : "not ", "ok 46\n"; - -@a = ('a', 'b', 'c'); -{ - local($a[1]) = "X"; - shift @a; -} -print +($a[0].$a[1] eq "Xb") ? "" : "not ", "ok 47\n"; - -# 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__}; - print +($SIG{TERM} eq 'main::foo') ? "" : "not ", "ok 48\n"; - print +($SIG{INT} eq \&foo) ? "" : "not ", "ok 49\n"; - print +($SIG{__WARN__} eq \&foo) ? "" : "not ", "ok 50\n"; - local($SIG{INT}); - delete $SIG{__WARN__}; -} -print +($SIG{TERM} eq 'main::foo') ? "" : "not ", "ok 51\n"; -print +($SIG{INT} eq \&foo) ? "" : "not ", "ok 52\n"; -print +($SIG{__WARN__} eq \&foo) ? "" : "not ", "ok 53\n"; - -# and for %ENV - -$ENV{_X_} = 'a'; -$ENV{_Y_} = 'b'; -$ENV{_Z_} = 'c'; -{ - local($ENV{_X_}) = 'foo'; - local($ENV{_Y_}) = $ENV{_Y_}; - print +($ENV{_X_} eq 'foo') ? "" : "not ", "ok 54\n"; - print +($ENV{_Y_} eq 'b') ? "" : "not ", "ok 55\n"; - local($ENV{_Z_}); - delete $ENV{_Z_}; -} -print +($ENV{_X_} eq 'a') ? "" : "not ", "ok 56\n"; -print +($ENV{_Y_} eq 'b') ? "" : "not ", "ok 57\n"; -print +($ENV{_Z_} eq 'c') ? "" : "not ", "ok 58\n"; - -# does implicit localization in foreach skip magic? - -$_ = "ok 59,ok 60,"; -my $iter = 0; -while (/(o.+?),/gc) { - print "$1\n"; - foreach (1..1) { $iter++ } - if ($iter > 2) { print "not ok 60\n"; last; } -} - -{ - package UnderScore; - sub TIESCALAR { bless \my $self, shift } - sub FETCH { die "read \$_ forbidden" } - sub STORE { die "write \$_ forbidden" } - tie $_, __PACKAGE__; - my $t = 61; - 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) ) { - print "# Testing $name\n"; - eval { &$code }; - print(($ok xor $@) ? "ok $t\n" : "not ok $t\n"); - ++$t; - } - untie $_; -} - diff --git a/contrib/perl5/t/op/lop.t b/contrib/perl5/t/op/lop.t deleted file mode 100755 index d57271a..0000000 --- a/contrib/perl5/t/op/lop.t +++ /dev/null @@ -1,44 +0,0 @@ -#!./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"; diff --git a/contrib/perl5/t/op/magic.t b/contrib/perl5/t/op/magic.t deleted file mode 100755 index c2a8211..0000000 --- a/contrib/perl5/t/op/magic.t +++ /dev/null @@ -1,228 +0,0 @@ -#!./perl - -BEGIN { - $| = 1; - chdir 't' if -d 't'; - @INC = '../lib'; - $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; -} - -use warnings; - -sub ok { - my ($n, $result, $info) = @_; - if ($result) { - print "ok $n\n"; - } - else { - print "not ok $n\n"; - print "# $info\n" if $info; - } -} - -$Is_MSWin32 = $^O eq 'MSWin32'; -$Is_VMS = $^O eq 'VMS'; -$Is_Dos = $^O eq 'dos'; -$Is_os2 = $^O eq 'os2'; -$Is_Cygwin = $^O eq 'cygwin'; -$PERL = ($Is_MSWin32 ? '.\perl' : './perl'); - -print "1..35\n"; - -eval '$ENV{"FOO"} = "hi there";'; # check that ENV is inited inside eval -if ($Is_MSWin32) { ok 1, `cmd /x /c set FOO` eq "FOO=hi there\n"; } -else { ok 1, `echo \$FOO` eq "hi there\n"; } - -unlink 'ajslkdfpqjsjfk'; -$! = 0; -open(FOO,'ajslkdfpqjsjfk'); -ok 2, $!, $!; -close FOO; # just mention it, squelch used-only-once - -if ($Is_MSWin32 || $Is_Dos) { - ok "3 # skipped",1; - ok "4 # skipped",1; -} -else { - # the next tests are embedded inside system simply because sh spits out - # a newline onto stderr when a child process kills itself with SIGINT. - system './perl', '-e', <<'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\n"; - - sub ok3 { - if (($x = pop(@_)) eq "INT") { - print "ok 3\n"; - } - else { - print "not ok 3 ($x @_)\n"; - } - } - -END -} - -# can we slice ENV? -@val1 = @ENV{keys(%ENV)}; -@val2 = values(%ENV); -ok 5, join(':',@val1) eq join(':',@val2); -ok 6, @val1 > 1; - -# regex vars -'foobarbaz' =~ /b(a)r/; -ok 7, $` eq 'foo', $`; -ok 8, $& eq 'bar', $&; -ok 9, $' eq 'baz', $'; -ok 10, $+ eq 'a', $+; - -# $" -@a = qw(foo bar baz); -ok 11, "@a" eq "foo bar baz", "@a"; -{ - local $" = ','; - ok 12, "@a" eq "foo,bar,baz", "@a"; -} - -# $; -%h = (); -$h{'foo', 'bar'} = 1; -ok 13, (keys %h)[0] eq "foo\034bar", (keys %h)[0]; -{ - local $; = 'x'; - %h = (); - $h{'foo', 'bar'} = 1; - ok 14, (keys %h)[0] eq 'fooxbar', (keys %h)[0]; -} - -# $?, $@, $$ -system qq[$PERL -e "exit(0)"]; -ok 15, $? == 0, $?; -system qq[$PERL -e "exit(1)"]; -ok 16, $? != 0, $?; - -eval { die "foo\n" }; -ok 17, $@ eq "foo\n", $@; - -ok 18, $$ > 0, $$; - -# $^X and $0 -{ - if ($^O eq 'qnx') { - chomp($wd = `/usr/bin/fullpath -t`); - } - elsif($Is_Cygwin) { - # Cygwin turns the symlink into the real file - chomp($wd = `pwd`); - $wd =~ s#/t$##; - } - elsif($Is_os2) { - $wd = Cwd::sys_cwd(); - } - else { - $wd = '.'; - } - my $perl = "$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"; - } - 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 19, open(SCRIPT, ">$script"), $!; - ok 20, print(SCRIPT $headmaybe . <<EOB . <<'EOF' . $tailmaybe), $!; -#!$wd/perl -EOB -print "\$^X is $^X, \$0 is $0\n"; -EOF - ok 21, close(SCRIPT), $!; - ok 22, chmod(0755, $script), $!; - $_ = `$script`; - s/\.exe//i if $Is_Dos or $Is_Cygwin or $Is_os2; - 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 23, (($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1:"; - $_ = `$perl $script`; - s/\.exe//i if $Is_Dos or $Is_os2; - s{\\}{/}g; - ok 24, (($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1: after `$perl $script`"; - ok 25, unlink($script), $!; -} - -# $], $^O, $^T -ok 26, $] >= 5.00319, $]; -ok 27, $^O; -ok 28, $^T > 850000000, $^T; - -if ($Is_VMS || $Is_Dos) { - ok "29 # skipped", 1; - ok "30 # skipped", 1; -} -else { - $PATH = $ENV{PATH}; - $PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0; - $ENV{foo} = "bar"; - %ENV = (); - $ENV{PATH} = $PATH; - $ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0; - ok 29, ($Is_MSWin32 ? (`cmd /x /c set foo 2>NUL` eq "") - : (`echo \$foo` eq "\n") ); - - $ENV{__NoNeSuCh} = "foo"; - $0 = "bar"; - ok 30, ($Is_MSWin32 ? (`cmd /x /c set __NoNeSuCh` eq "__NoNeSuCh=foo\n") - : (`echo \$__NoNeSuCh` eq "foo\n") ); -} - -{ - local $SIG{'__WARN__'} = sub { print "# @_\nnot " }; - $! = undef; - print "ok 31\n"; -} - -# test case-insignificance of %ENV (these tests must be enabled only -# when perl is compiled with -DENV_IS_CASELESS) -if ($Is_MSWin32) { - %ENV = (); - $ENV{'Foo'} = 'bar'; - $ENV{'fOo'} = 'baz'; - ok 32, (scalar(keys(%ENV)) == 1); - ok 33, exists($ENV{'FOo'}); - ok 34, (delete($ENV{'foO'}) eq 'baz'); - ok 35, (scalar(keys(%ENV)) == 0); -} -else { - ok "32 # skipped: no caseless %ENV support",1; - ok "33 # skipped: no caseless %ENV support",1; - ok "34 # skipped: no caseless %ENV support",1; - ok "35 # skipped: no caseless %ENV support",1; -} diff --git a/contrib/perl5/t/op/method.t b/contrib/perl5/t/op/method.t deleted file mode 100755 index be4df75..0000000 --- a/contrib/perl5/t/op/method.t +++ /dev/null @@ -1,187 +0,0 @@ -#!./perl - -# -# test method calls and autoloading. -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..53\n"; - -@A::ISA = 'B'; -@B::ISA = 'C'; - -sub C::d {"C::d"} -sub D::d {"D::d"} - -my $cnt = 0; -sub test { - print "# got `$_[0]', expected `$_[1]'\nnot " unless $_[0] eq $_[1]; - # print "not " unless shift eq shift; - print "ok ", ++$cnt, "\n" -} - -# First, some basic checks of method-calling syntax: -$obj = bless [], "Pack"; -sub Pack::method { shift; join(",", "method", @_) } -$mname = "method"; - -test(Pack->method("a","b","c"), "method,a,b,c"); -test(Pack->$mname("a","b","c"), "method,a,b,c"); -test(method Pack ("a","b","c"), "method,a,b,c"); -test((method Pack "a","b","c"), "method,a,b,c"); - -test(Pack->method(), "method"); -test(Pack->$mname(), "method"); -test(method Pack (), "method"); -test(Pack->method, "method"); -test(Pack->$mname, "method"); -test(method Pack, "method"); - -test($obj->method("a","b","c"), "method,a,b,c"); -test($obj->$mname("a","b","c"), "method,a,b,c"); -test((method $obj ("a","b","c")), "method,a,b,c"); -test((method $obj "a","b","c"), "method,a,b,c"); - -test($obj->method(), "method"); -test($obj->$mname(), "method"); -test((method $obj ()), "method"); -test($obj->method, "method"); -test($obj->$mname, "method"); -test(method $obj, "method"); - -test( A->d, "C::d"); # Update hash table; - -*B::d = \&D::d; # Import now. -test (A->d, "D::d"); # Update hash table; - -{ - local @A::ISA = qw(C); # Update hash table with split() assignment - test (A->d, "C::d"); - $#A::ISA = -1; - test (eval { A->d } || "fail", "fail"); -} -test (A->d, "D::d"); - -{ - local *B::d; - eval 'sub B::d {"B::d1"}'; # Import now. - test (A->d, "B::d1"); # Update hash table; - undef &B::d; - test ((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1); -} - -test (A->d, "D::d"); # Back to previous state - -eval 'sub B::d {"B::d2"}'; # Import now. -test (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}; -test (A->d, "C::d"); # Update hash table; - -eval 'sub B::d {"B::d3"}'; # Import now. -test (A->d, "B::d3"); # Update hash table; - -delete $B::{d}; -*dummy::dummy = sub {}; # Mark as updated -test (A->d, "C::d"); - -eval 'sub B::d {"B::d4"}'; # Import now. -test (A->d, "B::d4"); # Update hash table; - -delete $B::{d}; # Should work without any help too -test (A->d, "C::d"); - -{ - local *C::d; - test (eval { A->d } || "nope", "nope"); -} -test (A->d, "C::d"); - -*A::x = *A::d; # See if cache incorrectly follows synonyms -A->d; -test (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 - -test(A->e(), "C: In C::e, 1"); # We get a correct autoload -test(A->e(), "C: In C::e, 1"); # Which sticks - -test(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top -test(A->ee(), "B: In A::ee, 2"); # Which sticks - -test(Y->f(), "B: In Y::f, 3"); # We vivify a correct method -test(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; -}; - -test(A->eee(), "new B: In A::eee, 4"); # We get a correct $autoload -test(A->eee(), "new B: In A::eee, 4"); # Which sticks - -# this test added due to bug discovery -test(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; - test(A2->foo(), "foo"); - test(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1); - test(A2->foo(), "foo"); -} - -{ - test(do { use Config; eval 'Config->foo()'; - $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); - test(do { use Config; eval '$d = bless {}, "Config"; $d->foo()'; - $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); -} - -test(do { eval 'E->foo()'; - $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); -test(do { eval '$e = bless {}, "E"; $e->foo()'; - $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); - diff --git a/contrib/perl5/t/op/misc.t b/contrib/perl5/t/op/misc.t deleted file mode 100755 index 35437a4..0000000 --- a/contrib/perl5/t/op/misc.t +++ /dev/null @@ -1,603 +0,0 @@ -#!./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. - -chdir 't' if -d 't'; -@INC = '../lib'; -$ENV{PERL5LIB} = "../lib"; - -$|=1; - -undef $/; -@prgs = split "\n########\n", <DATA>; -print "1..", scalar @prgs, "\n"; - -$tmpfile = "misctmp000"; -1 while -f ++$tmpfile; -END { while($tmpfile && unlink $tmpfile){} } - -$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); - -for (@prgs){ - my $switch; - if (s/^\s*(-\w.*)//){ - $switch = $1; - } - my($prog,$expected) = split(/\nEXPECT\n/, $_); - open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; - $prog =~ s#/dev/null#NL:# if $^O eq 'VMS'; - $prog =~ s#if \(-e _ and -f _ and -r _\)#if (-e _ and -f _)# if $^O eq 'VMS'; # VMS file locking - - print TEST $prog, "\n"; - close TEST or die "Cannot close $tmpfile: $!"; - - if ($^O eq 'MSWin32') { - $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; - } - else { - $results = `./perl $switch $tmpfile 2>&1`; - } - $status = $?; - $results =~ s/\n+$//; - $results =~ s/at\s+misctmp\d+\s+line/at - line/g; - $results =~ s/of\s+misctmp\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; - $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 = ":="; split /($a)/o, "a:=b:=c"; print "@_" -EXPECT -a := b := c -######## -$cusp = ~0 ^ (~0 >> 1); -use integer; -$, = " "; -print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n"; -EXPECT -7 0 0 8 ! -######## -$foo=undef; $foo->go; -EXPECT -Can't call method "go" on an undefined value at - line 1. -######## -BEGIN - { - "foo"; - } -######## -$array[128]=1 -######## -$x=0x0eabcd; print $x->ref; -EXPECT -Can't call method "ref" without a package or object reference at - line 1. -######## -chop ($str .= <DATA>); -######## -close ($banana); -######## -$x=2;$y=3;$x<$y ? $x : $y += 23;print $x; -EXPECT -25 -######## -eval {sub bar {print "In bar";}} -######## -system './perl -ne "print if eof" /dev/null' -######## -chop($file = <DATA>); -######## -package N; -sub new {my ($obj,$n)=@_; bless \$n} -$aa=new N 1; -$aa=12345; -print $aa; -EXPECT -12345 -######## -%@x=0; -EXPECT -Can't modify hash dereference in repeat (x) at - line 1, near "0;" -Execution of - aborted due to compilation errors. -######## -$_="foo"; -printf(STDOUT "%s\n", $_); -EXPECT -foo -######## -push(@a, 1, 2, 3,) -######## -quotemeta "" -######## -for ("ABCDE") { - ⊂ -s/./&sub($&)/eg; -print;} -sub sub {local($_) = @_; -$_ x 4;} -EXPECT -Modification of a read-only value attempted at - line 3. -######## -package FOO;sub new {bless {FOO => BAR}}; -package main; -use strict vars; -my $self = new FOO; -print $$self{FOO}; -EXPECT -BAR -######## -$_="foo"; -s/.{1}//s; -print; -EXPECT -oo -######## -print scalar ("foo","bar") -EXPECT -bar -######## -sub by_number { $a <=> $b; };# inline function for sort below -$as_ary{0}="a0"; -@ordered_array=sort by_number keys(%as_ary); -######## -sub NewShell -{ - local($Host) = @_; - my($m2) = $#Shells++; - $Shells[$m2]{HOST} = $Host; - return $m2; -} - -sub ShowShell -{ - local($i) = @_; -} - -&ShowShell(&NewShell(beach,Work,"+0+0")); -&ShowShell(&NewShell(beach,Work,"+0+0")); -&ShowShell(&NewShell(beach,Work,"+0+0")); -######## - { - package FAKEARRAY; - - sub TIEARRAY - { print "TIEARRAY @_\n"; - die "bomb out\n" unless $count ++ ; - bless ['foo'] - } - sub FETCH { print "fetch @_\n"; $_[0]->[$_[1]] } - sub STORE { print "store @_\n"; $_[0]->[$_[1]] = $_[2] } - sub DESTROY { print "DESTROY \n"; undef @{$_[0]}; } - } - -eval 'tie @h, FAKEARRAY, fred' ; -tie @h, FAKEARRAY, fred ; -EXPECT -TIEARRAY FAKEARRAY fred -TIEARRAY FAKEARRAY fred -DESTROY -######## -BEGIN { die "phooey\n" } -EXPECT -phooey -BEGIN failed--compilation aborted at - line 1. -######## -BEGIN { 1/$zero } -EXPECT -Illegal division by zero at - line 1. -BEGIN failed--compilation aborted at - line 1. -######## -BEGIN { undef = 0 } -EXPECT -Modification of a read-only value attempted at - line 1. -BEGIN failed--compilation aborted at - line 1. -######## -{ - package foo; - sub PRINT { - shift; - print join(' ', reverse @_)."\n"; - } - sub PRINTF { - shift; - my $fmt = shift; - print sprintf($fmt, @_)."\n"; - } - sub TIEHANDLE { - bless {}, shift; - } - sub READLINE { - "Out of inspiration"; - } - sub DESTROY { - print "and destroyed as well\n"; - } - sub READ { - shift; - print STDOUT "foo->can(READ)(@_)\n"; - return 100; - } - sub GETC { - shift; - print STDOUT "Don't GETC, Get Perl\n"; - return "a"; - } -} -{ - local(*FOO); - tie(*FOO,'foo'); - print FOO "sentence.", "reversed", "a", "is", "This"; - print "-- ", <FOO>, " --\n"; - my($buf,$len,$offset); - $buf = "string"; - $len = 10; $offset = 1; - read(FOO, $buf, $len, $offset) == 100 or die "foo->READ failed"; - getc(FOO) eq "a" or die "foo->GETC failed"; - printf "%s is number %d\n", "Perl", 1; -} -EXPECT -This is a reversed sentence. --- Out of inspiration -- -foo->can(READ)(string 10 1) -Don't GETC, Get Perl -Perl is number 1 -and destroyed as well -######## -my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n" -EXPECT -2 2 2 -######## -@a = ($a, $b, $c, $d) = (5, 6); -print "ok\n" - if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]); -EXPECT -ok -######## -print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000); -EXPECT -ok -######## -print "ok\n" if ("\0" lt "\xFF"); -EXPECT -ok -######## -open(H,'op/misc.t'); # must be in the 't' directory -stat(H); -print "ok\n" if (-e _ and -f _ and -r _); -EXPECT -ok -######## -sub thing { 0 || return qw(now is the time) } -print thing(), "\n"; -EXPECT -nowisthetime -######## -$ren = 'joy'; -$stimpy = 'happy'; -{ local $main::{ren} = *stimpy; print $ren, ' ' } -print $ren, "\n"; -EXPECT -happy joy -######## -$stimpy = 'happy'; -{ local $main::{ren} = *stimpy; print ${'ren'}, ' ' } -print +(defined(${'ren'}) ? 'oops' : 'joy'), "\n"; -EXPECT -happy joy -######## -package p; -sub func { print 'really ' unless wantarray; 'p' } -sub groovy { 'groovy' } -package main; -print p::func()->groovy(), "\n" -EXPECT -really groovy -######## -@list = ([ 'one', 1 ], [ 'two', 2 ]); -sub func { $num = shift; (grep $_->[1] == $num, @list)[0] } -print scalar(map &func($_), 1 .. 3), " ", - scalar(map scalar &func($_), 1 .. 3), "\n"; -EXPECT -2 3 -######## -($k, $s) = qw(x 0); -@{$h{$k}} = qw(1 2 4); -for (@{$h{$k}}) { $s += $_; delete $h{$k} if ($_ == 2) } -print "bogus\n" unless $s == 7; -######## -my $a = 'outer'; -eval q[ my $a = 'inner'; eval q[ print "$a " ] ]; -eval { my $x = 'peace'; eval q[ print "$x\n" ] } -EXPECT -inner peace -######## --w -$| = 1; -sub foo { - print "In foo1\n"; - eval 'sub foo { print "In foo2\n" }'; - print "Exiting foo1\n"; -} -foo; -foo; -EXPECT -In foo1 -Subroutine foo redefined at (eval 1) line 1. -Exiting foo1 -In foo2 -######## -$s = 0; -map {#this newline here tickles the bug -$s += $_} (1,2,4); -print "eat flaming death\n" unless ($s == 7); -######## -sub foo { local $_ = shift; split; @_ } -@x = foo(' x y z '); -print "you die joe!\n" unless "@x" eq 'x y z'; -######## -/(?{"{"})/ # Check it outside of eval too -EXPECT -Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern -Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/(?{ << HERE "{"})/ at - line 1. -######## -/(?{"{"}})/ # Check it outside of eval too -EXPECT -Unmatched right curly bracket at (re_eval 1) line 1, at end of line -syntax error at (re_eval 1) line 1, near ""{"}" -Compilation failed in regexp at - line 1. -######## -BEGIN { @ARGV = qw(a b c d e) } -BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" } -END { print "end <",shift,">\nargv <@ARGV>\n" } -INIT { print "init <",shift,">\n" } -CHECK { print "check <",shift,">\n" } -EXPECT -argv <a b c d e> -begin <a> -check <b> -init <c> -end <d> -argv <e> -######## --l -# fdopen from a system descriptor to a system descriptor used to close -# the former. -open STDERR, '>&=STDOUT' or die $!; -select STDOUT; $| = 1; print fileno STDOUT or die $!; -select STDERR; $| = 1; print fileno STDERR or die $!; -EXPECT -1 -2 -######## --w -sub testme { my $a = "test"; { local $a = "new test"; print $a }} -EXPECT -Can't localize lexical variable $a at - line 2. -######## -package X; -sub ascalar { my $r; bless \$r } -sub DESTROY { print "destroyed\n" }; -package main; -*s = ascalar X; -EXPECT -destroyed -######## -package X; -sub anarray { bless [] } -sub DESTROY { print "destroyed\n" }; -package main; -*a = anarray X; -EXPECT -destroyed -######## -package X; -sub ahash { bless {} } -sub DESTROY { print "destroyed\n" }; -package main; -*h = ahash X; -EXPECT -destroyed -######## -package X; -sub aclosure { my $x; bless sub { ++$x } } -sub DESTROY { print "destroyed\n" }; -package main; -*c = aclosure X; -EXPECT -destroyed -######## -package X; -sub any { bless {} } -my $f = "FH000"; # just to thwart any future optimisations -sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r } -sub DESTROY { print "destroyed\n" } -package main; -$x = any X; # to bump sv_objcount. IO objs aren't counted?? -*f = afh X; -EXPECT -destroyed -destroyed -######## -BEGIN { - $| = 1; - $SIG{__WARN__} = sub { - eval { print $_[0] }; - die "bar\n"; - }; - warn "foo\n"; -} -EXPECT -foo -bar -BEGIN failed--compilation aborted at - line 8. -######## -package X; -@ISA='Y'; -sub new { - my $class = shift; - my $self = { }; - bless $self, $class; - my $init = shift; - $self->foo($init); - print "new", $init; - return $self; -} -sub DESTROY { - my $self = shift; - print "DESTROY", $self->foo; -} -package Y; -sub attribute { - my $self = shift; - my $var = shift; - if (@_ == 0) { - return $self->{$var}; - } elsif (@_ == 1) { - $self->{$var} = shift; - } -} -sub AUTOLOAD { - $AUTOLOAD =~ /::([^:]+)$/; - my $method = $1; - splice @_, 1, 0, $method; - goto &attribute; -} -package main; -my $x = X->new(1); -for (2..3) { - my $y = X->new($_); - print $y->foo; -} -print $x->foo; -EXPECT -new1new22DESTROY2new33DESTROY31DESTROY1 -######## -re(); -sub re { - my $re = join '', eval 'qr/(??{ $obj->method })/'; - $re; -} -EXPECT -######## -use strict; -my $foo = "ZZZ\n"; -END { print $foo } -EXPECT -ZZZ -######## -eval ' -use strict; -my $foo = "ZZZ\n"; -END { print $foo } -'; -EXPECT -ZZZ -######## --w -if (@ARGV) { print "" } -else { - if ($x == 0) { print "" } else { print $x } -} -EXPECT -Use of uninitialized value in numeric eq (==) at - line 4. -######## -$x = sub {}; -foo(); -sub foo { eval { return }; } -print "ok\n"; -EXPECT -ok -######## -my @l = qw(hello.* world); -my $x; - -foreach $x (@l) { - print "before - $x\n"; - $x = "\Q$x\E"; - print "quotemeta - $x\n"; - $x = "\u$x"; - print "ucfirst - $x\n"; - $x = "\l$x"; - print "lcfirst - $x\n"; - $x = "\U$x\E"; - print "uc - $x\n"; - $x = "\L$x\E"; - print "lc - $x\n"; -} -EXPECT -before - hello.* -quotemeta - hello\.\* -ucfirst - Hello\.\* -lcfirst - hello\.\* -uc - HELLO\.\* -lc - hello\.\* -before - world -quotemeta - world -ucfirst - World -lcfirst - world -uc - WORLD -lc - world -######## -sub f { my $a = 1; my $b = 2; my $c = 3; my $d = 4; next } -my $x = "foo"; -{ f } continue { print $x, "\n" } -EXPECT -foo -######## -sub C () { 1 } -sub M { $_[0] = 2; } -eval "C"; -M(C); -EXPECT -Modification of a read-only value attempted at - line 2. -######## -print qw(ab a\b a\\b); -EXPECT -aba\ba\b -######## -# This test is here instead of pragma/locale.t because -# the bug depends on in the internal state of the locale -# settings and pragma/locale messes up that state pretty badly. -# We need a "fresh run". -BEGIN { - eval { require POSIX }; - if ($@) { - exit(0); # running minitest? - } -} -use Config; -my $have_setlocale = $Config{d_setlocale} eq 'define'; -$have_setlocale = 0 if $@; -# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1" -# and mingw32 uses said silly CRT -$have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; -exit(0) unless $have_setlocale; -my @locales; -if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a|")) { - while(<LOCALES>) { - chomp; - push(@locales, $_); - } - close(LOCALES); -} -exit(0) unless @locales; -for (@locales) { - use POSIX qw(locale_h); - use locale; - setlocale(LC_NUMERIC, $_) or next; - my $s = sprintf "%g %g", 3.1, 3.1; - next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/; - print "$_ $s\n"; -} -EXPECT diff --git a/contrib/perl5/t/op/mkdir.t b/contrib/perl5/t/op/mkdir.t deleted file mode 100755 index c5a090c..0000000 --- a/contrib/perl5/t/op/mkdir.t +++ /dev/null @@ -1,25 +0,0 @@ -#!./perl - -print "1..9\n"; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -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 - -print (mkdir('blurfl',0777) ? "ok 1\n" : "not ok 1\n"); -print (mkdir('blurfl',0777) ? "not ok 2\n" : "ok 2\n"); -print ($! =~ /cannot move|exist|denied/ ? "ok 3\n" : "# $!\nnot ok 3\n"); -print (-d 'blurfl' ? "ok 4\n" : "not ok 4\n"); -print (rmdir('blurfl') ? "ok 5\n" : "not ok 5\n"); -print (rmdir('blurfl') ? "not ok 6\n" : "ok 6\n"); -print ($! =~ /cannot find|such|exist|not found/i ? "ok 7\n" : "# $!\nnot ok 7\n"); -print (mkdir('blurfl') ? "ok 8\n" : "not ok 8\n"); -print (rmdir('blurfl') ? "ok 9\n" : "not ok 9\n"); diff --git a/contrib/perl5/t/op/my.t b/contrib/perl5/t/op/my.t deleted file mode 100755 index 601e1d6..0000000 --- a/contrib/perl5/t/op/my.t +++ /dev/null @@ -1,101 +0,0 @@ -#!./perl - -# $RCSfile: my.t,v $ - -print "1..31\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,@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,@b,@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"; -} diff --git a/contrib/perl5/t/op/my_stash.t b/contrib/perl5/t/op/my_stash.t deleted file mode 100755 index 4a1d502..0000000 --- a/contrib/perl5/t/op/my_stash.t +++ /dev/null @@ -1,31 +0,0 @@ -#!./perl - -package Foo; - -BEGIN { - @INC = '../lib'; -} - -use Test; - -plan tests => 7; - -use constant MyClass => 'Foo::Bar::Biz::Baz'; - -{ - package Foo::Bar::Biz::Baz; -} - -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 $@; -} diff --git a/contrib/perl5/t/op/nothr5005.t b/contrib/perl5/t/op/nothr5005.t deleted file mode 100755 index 411a0b4..0000000 --- a/contrib/perl5/t/op/nothr5005.t +++ /dev/null @@ -1,35 +0,0 @@ -#!./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"; - } diff --git a/contrib/perl5/t/op/numconvert.t b/contrib/perl5/t/op/numconvert.t deleted file mode 100755 index f3c9867..0000000 --- a/contrib/perl5/t/op/numconvert.t +++ /dev/null @@ -1,192 +0,0 @@ -#!./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 - -print "# max_uv1 = $max_uv1, max_uv2 = $max_uv2, big_iv = $big_iv\n"; -if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1) { - 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; -} - -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"; - - -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; - } - $nok++, - print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n" - if $ans[0] ne $ans[1]; - } - print "not " if $nok; - print "ok $test\n"; - #print $txt if $nok; - $test++; - } - } - } -} diff --git a/contrib/perl5/t/op/oct.t b/contrib/perl5/t/op/oct.t deleted file mode 100755 index fe155d3..0000000 --- a/contrib/perl5/t/op/oct.t +++ /dev/null @@ -1,88 +0,0 @@ -#!./perl - -print "1..50\n"; - -print +(oct('0b1_0101') == 0b101_01) ? "ok" : "not ok", " 1\n"; -print +(oct('0b10_101') == 0_2_5) ? "ok" : "not ok", " 2\n"; -print +(oct('0b101_01') == 2_1) ? "ok" : "not ok", " 3\n"; -print +(oct('0b1010_1') == 0x1_5) ? "ok" : "not ok", " 4\n"; - -print +(oct('b1_0101') == 0b10101) ? "ok" : "not ok", " 5\n"; -print +(oct('b10_101') == 025) ? "ok" : "not ok", " 6\n"; -print +(oct('b101_01') == 21) ? "ok" : "not ok", " 7\n"; -print +(oct('b1010_1') == 0x15) ? "ok" : "not ok", " 8\n"; - -print +(oct('01_234') == 0b10_1001_1100) ? "ok" : "not ok", " 9\n"; -print +(oct('012_34') == 01234) ? "ok" : "not ok", " 10\n"; -print +(oct('0123_4') == 668) ? "ok" : "not ok", " 11\n"; -print +(oct('01234') == 0x29c) ? "ok" : "not ok", " 12\n"; - -print +(oct('0x1_234') == 0b10010_00110100) ? "ok" : "not ok", " 13\n"; -print +(oct('0x12_34') == 01_1064) ? "ok" : "not ok", " 14\n"; -print +(oct('0x123_4') == 4660) ? "ok" : "not ok", " 15\n"; -print +(oct('0x1234') == 0x12_34) ? "ok" : "not ok", " 16\n"; - -print +(oct('x1_234') == 0b100100011010_0) ? "ok" : "not ok", " 17\n"; -print +(oct('x12_34') == 0_11064) ? "ok" : "not ok", " 18\n"; -print +(oct('x123_4') == 4660) ? "ok" : "not ok", " 19\n"; -print +(oct('x1234') == 0x_1234) ? "ok" : "not ok", " 20\n"; - -print +(hex('01_234') == 0b_1001000110100) ? "ok" : "not ok", " 21\n"; -print +(hex('012_34') == 011064) ? "ok" : "not ok", " 22\n"; -print +(hex('0123_4') == 4660) ? "ok" : "not ok", " 23\n"; -print +(hex('01234_') == 0x1234) ? "ok" : "not ok", " 24\n"; - -print +(hex('0x_1234') == 0b1001000110100) ? "ok" : "not ok", " 25\n"; -print +(hex('0x1_234') == 011064) ? "ok" : "not ok", " 26\n"; -print +(hex('0x12_34') == 4660) ? "ok" : "not ok", " 27\n"; -print +(hex('0x1234_') == 0x1234) ? "ok" : "not ok", " 28\n"; - -print +(hex('x_1234') == 0b1001000110100) ? "ok" : "not ok", " 29\n"; -print +(hex('x12_34') == 011064) ? "ok" : "not ok", " 30\n"; -print +(hex('x123_4') == 4660) ? "ok" : "not ok", " 31\n"; -print +(hex('x1234_') == 0x1234) ? "ok" : "not ok", " 32\n"; - -print +(oct('0b1111_1111_1111_1111_1111_1111_1111_1111') == 4294967295) ? - "ok" : "not ok", " 33\n"; -print +(oct('037_777_777_777') == 4294967295) ? - "ok" : "not ok", " 34\n"; -print +(oct('0xffff_ffff') == 4294967295) ? - "ok" : "not ok", " 35\n"; - -print +(hex('0xff_ff_ff_ff') == 4294967295) ? - "ok" : "not ok", " 36\n"; - -$_ = "\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"; -} - -print +(oct('0b'.( '0'x10).'1_0101') == 0b101_01) ? "ok" : "not ok", " 45\n"; -print +(oct('0b'.( '0'x100).'1_0101') == 0b101_01) ? "ok" : "not ok", " 46\n"; -print +(oct('0b'.('0'x1000).'1_0101') == 0b101_01) ? "ok" : "not ok", " 47\n"; - -print +(hex(( '0'x10).'01234') == 0x1234) ? "ok" : "not ok", " 48\n"; -print +(hex(( '0'x100).'01234') == 0x1234) ? "ok" : "not ok", " 49\n"; -print +(hex(('0'x1000).'01234') == 0x1234) ? "ok" : "not ok", " 50\n"; - diff --git a/contrib/perl5/t/op/ord.t b/contrib/perl5/t/op/ord.t deleted file mode 100755 index 22ff3af..0000000 --- a/contrib/perl5/t/op/ord.t +++ /dev/null @@ -1,23 +0,0 @@ -#!./perl - -print "1..5\n"; - -# compile time evaluation - -# 65 ASCII -# 193 EBCDIC -if (ord('A') == 65 || ord('A') == 193) {print "ok 1\n";} else {print "not ok 1\n";} - -print "not " unless ord(chr(500)) == 500; -print "ok 2\n"; - -# run time evaluation - -$x = 'ABC'; -if (ord($x) == 65 || ord($x) == 193) {print "ok 3\n";} else {print "not ok 3\n";} - -if (chr 65 eq 'A' || chr 193 eq 'A') {print "ok 4\n";} else {print "not ok 4\n";} - -$x = 500; -print "not " unless ord(chr($x)) == $x; -print "ok 5\n"; diff --git a/contrib/perl5/t/op/pack.t b/contrib/perl5/t/op/pack.t deleted file mode 100755 index 67bd547..0000000 --- a/contrib/perl5/t/op/pack.t +++ /dev/null @@ -1,418 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; -} - -print "1..159\n"; - -$format = "c2 x5 C C x s d i l a6"; -# Need the expression in here to force ary[5] to be numeric. This avoids -# test2 failing because ary2 goes str->numeric->str and ary doesn't. -@ary = (1,-100,127,128,32767,987.654321098 / 100.0,12345,123456,"abcdef"); -$foo = pack($format,@ary); -@ary2 = unpack($format,$foo); - -print ($#ary == $#ary2 ? "ok 1\n" : "not ok 1\n"); - -$out1=join(':',@ary); -$out2=join(':',@ary2); -# Using long double NVs may introduce greater accuracy than wanted. -$out1 =~ s/:9\.87654321097999\d*:/:9.87654321098:/; -$out2 =~ s/:9\.87654321097999\d*:/:9.87654321098:/; -print ($out1 eq $out2? "ok 2\n" : "not ok 2\n"); - -print ($foo =~ /def/ ? "ok 3\n" : "not ok 3\n"); - -# How about counting bits? - -print +($x = unpack("%32B*", "\001\002\004\010\020\040\100\200\377")) == 16 - ? "ok 4\n" : "not ok 4 $x\n"; - -print +($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")) == 12 - ? "ok 5\n" : "not ok 5 $x\n"; - -print +($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9 - ? "ok 6\n" : "not ok 6 $x\n"; - -my $sum = 129; # ASCII -$sum = 103 if ($Config{ebcdic} eq 'define'); - -print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum - ? "ok 7\n" : "not ok 7 $x\n"; - -open(BIN, "./perl") || open(BIN, "./perl.exe") - || die "Can't open ../perl or ../perl.exe: $!\n"; -sysread BIN, $foo, 8192; -close BIN; - -$sum = unpack("%32b*", $foo); -$longway = unpack("b*", $foo); -print $sum == $longway =~ tr/1/1/ ? "ok 8\n" : "not ok 8\n"; - -print +($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF - ? "ok 9\n" : "not ok 9 $x\n"; - -# check 'w' -my $test=10; -my @x = (5,130,256,560,32000,3097152,268435455,1073741844, - '4503599627365785','23728385234614992549757750638446'); -my $x = pack('w*', @x); -my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f848080801487ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e'; - -print $x eq $y ? "ok $test\n" : "not ok $test\n"; $test++; - -@y = unpack('w*', $y); -my $a; -while ($a = pop @x) { - my $b = pop @y; - print $a eq $b ? "ok $test\n" : "not ok $test\n$a\n$b\n"; $test++; -} - -@y = unpack('w2', $x); - -print scalar(@y) == 2 ? "ok $test\n" : "not ok $test\n"; $test++; -print $y[1] == 130 ? "ok $test\n" : "not ok $test\n"; $test++; - -# test exeptions -eval { $x = unpack 'w', pack 'C*', 0xff, 0xff}; -print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++; - -eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff}; -print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++; - -eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff}; -print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++; - -# -# test the "p" template - -# literals -print((unpack("p",pack("p","foo")) eq "foo" ? "ok " : "not ok "),$test++,"\n"); - -# scalars -print((unpack("p",pack("p",$test)) == $test ? "ok " : "not ok "),$test++,"\n"); - -# temps -sub foo { my $a = "a"; return $a . $a++ . $a++ } -{ - use warnings; - my $last = $test; - local $SIG{__WARN__} = sub { - print "ok ",$test++,"\n" if $_[0] =~ /temporary val/ - }; - my $junk = pack("p", &foo); - print "not ok ", $test++, "\n" if $last == $test; -} - -# undef should give null pointer -print((pack("p", undef) =~ /^\0+/ ? "ok " : "not ok "),$test++,"\n"); - -# Check for optimizer bug (e.g. Digital Unix GEM cc with -O4 on DU V4.0B gives -# 4294967295 instead of -1) -# see #ifdef __osf__ in pp.c pp_unpack -# Test 30: -print( ((unpack("i",pack("i",-1))) == -1 ? "ok " : "not ok "),$test++,"\n"); - -# 31..36: test the pack lengths of s S i I l L -print "not " unless length(pack("s", 0)) == 2; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("S", 0)) == 2; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("i", 0)) >= 4; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("I", 0)) >= 4; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("l", 0)) == 4; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("L", 0)) == 4; -print "ok ", $test++, "\n"; - -# 37..40: test the pack lengths of n N v V - -print "not " unless length(pack("n", 0)) == 2; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("N", 0)) == 4; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("v", 0)) == 2; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("V", 0)) == 4; -print "ok ", $test++, "\n"; - -# 41..56: test unpack-pack lengths - -my @templates = qw(c C i I s S l L n N v V f d); - -# quads not supported everywhere: if not, retest floats/doubles -# to preserve the test count... -eval { my $q = pack("q",0) }; -push @templates, $@ !~ /Invalid type in pack/ ? qw(q Q) : qw(f d); - -foreach my $t (@templates) { - my @t = unpack("$t*", pack("$t*", 12, 34)); - print "not " - unless @t == 2 and (($t[0] == 12 and $t[1] == 34) or ($t =~ /[nv]/i)); - print "ok ", $test++, "\n"; -} - -# 57..60: uuencode/decode - -# Note that first uuencoding known 'text' data and then checking the -# binary values of the uuencoded version would not be portable between -# character sets. Uuencoding is meant for encoding binary data, not -# text data. - -$in = pack 'C*', 0 .. 255; - -# just to be anal, we do some random tr/`/ / -$uu = <<'EOUU'; -M` $"`P0%!@<("0H+# T.#Q`1$A,4%187&!D:&QP='A\@(2(C)"4F)R@I*BLL -M+2XO,#$R,S0U-C<X.3H[/#T^/T!!0D-$149'2$E*2TQ-3D]045)35%565UA9 -M6EM<75Y?8&%B8V1E9F=H:6IK;&UN;W!Q<G-T=79W>'EZ>WQ]?G^`@8*#A(6& -MAXB)BHN,C8Z/D)&2DY25EI>8F9J;G)V>GZ"AHJ.DI::GJ*FJJZRMKJ^PL;*S -MM+6VM[BYNKN\O;Z_P,'"P\3%QL?(R<K+S,W.S]#1TM/4U=;7V-G:V]S=WM_@ -?X>+CY.7FY^CIZNOL[>[O\/'R\_3U]O?X^?K[_/W^_P ` -EOUU - -$_ = $uu; -tr/ /`/; -print "not " unless pack('u', $in) eq $_; -print "ok ", $test++, "\n"; - -print "not " unless unpack('u', $uu) eq $in; -print "ok ", $test++, "\n"; - -$in = "\x1f\x8b\x08\x08\x58\xdc\xc4\x35\x02\x03\x4a\x41\x50\x55\x00\xf3\x2a\x2d\x2e\x51\x48\xcc\xcb\x2f\xc9\x48\x2d\x52\x08\x48\x2d\xca\x51\x28\x2d\x4d\xce\x4f\x49\x2d\xe2\x02\x00\x64\x66\x60\x5c\x1a\x00\x00\x00"; -$uu = <<'EOUU'; -M'XL("%C<Q#4"`TI!4%4`\RHM+E%(S,LOR4@M4@A(+<I1*"U-SD])+>("`&1F -&8%P:```` -EOUU - -print "not " unless unpack('u', $uu) eq $in; -print "ok ", $test++, "\n"; - -# 60 identical to 59 except that backquotes have been changed to spaces - -$uu = <<'EOUU'; -M'XL("%C<Q#4" TI!4%4 \RHM+E%(S,LOR4@M4@A(+<I1*"U-SD])+>(" &1F -&8%P: -EOUU - -print "not " unless unpack('u', $uu) eq $in; -print "ok ", $test++, "\n"; - -# 61..73: test the ascii template types (A, a, Z) - -print "not " unless pack('A*', "foo\0bar\0 ") eq "foo\0bar\0 "; -print "ok ", $test++, "\n"; - -print "not " unless pack('A11', "foo\0bar\0 ") eq "foo\0bar\0 "; -print "ok ", $test++, "\n"; - -print "not " unless unpack('A*', "foo\0bar \0") eq "foo\0bar"; -print "ok ", $test++, "\n"; - -print "not " unless unpack('A8', "foo\0bar \0") eq "foo\0bar"; -print "ok ", $test++, "\n"; - -print "not " unless pack('a*', "foo\0bar\0 ") eq "foo\0bar\0 "; -print "ok ", $test++, "\n"; - -print "not " unless pack('a11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0"; -print "ok ", $test++, "\n"; - -print "not " unless unpack('a*', "foo\0bar \0") eq "foo\0bar \0"; -print "ok ", $test++, "\n"; - -print "not " unless unpack('a8', "foo\0bar \0") eq "foo\0bar "; -print "ok ", $test++, "\n"; - -print "not " unless pack('Z*', "foo\0bar\0 ") eq "foo\0bar\0 \0"; -print "ok ", $test++, "\n"; - -print "not " unless pack('Z11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0"; -print "ok ", $test++, "\n"; - -print "not " unless pack('Z3', "foo") eq "fo\0"; -print "ok ", $test++, "\n"; - -print "not " unless unpack('Z*', "foo\0bar \0") eq "foo"; -print "ok ", $test++, "\n"; - -print "not " unless unpack('Z8', "foo\0bar \0") eq "foo"; -print "ok ", $test++, "\n"; - -# 74..79: packing native shorts/ints/longs - -print "not " unless length(pack("s!", 0)) == $Config{shortsize}; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("i!", 0)) == $Config{intsize}; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("l!", 0)) == $Config{longsize}; -print "ok ", $test++, "\n"; - -print "not " unless length(pack("s!", 0)) <= length(pack("i!", 0)); -print "ok ", $test++, "\n"; - -print "not " unless length(pack("i!", 0)) <= length(pack("l!", 0)); -print "ok ", $test++, "\n"; - -print "not " unless length(pack("i!", 0)) == length(pack("i", 0)); -print "ok ", $test++, "\n"; - -# 80..139: pack <-> unpack bijectionism - -# 80.. 84 c -foreach my $c (-128, -1, 0, 1, 127) { - print "not " unless unpack("c", pack("c", $c)) == $c; - print "ok ", $test++, "\n"; -} - -# 85.. 89: C -foreach my $C (0, 1, 127, 128, 255) { - print "not " unless unpack("C", pack("C", $C)) == $C; - print "ok ", $test++, "\n"; -} - -# 90.. 94: s -foreach my $s (-32768, -1, 0, 1, 32767) { - print "not " unless unpack("s", pack("s", $s)) == $s; - print "ok ", $test++, "\n"; -} - -# 95.. 99: S -foreach my $S (0, 1, 32767, 32768, 65535) { - print "not " unless unpack("S", pack("S", $S)) == $S; - print "ok ", $test++, "\n"; -} - -# 100..104: i -foreach my $i (-2147483648, -1, 0, 1, 2147483647) { - print "not " unless unpack("i", pack("i", $i)) == $i; - print "ok ", $test++, "\n"; -} - -# 105..109: I -foreach my $I (0, 1, 2147483647, 2147483648, 4294967295) { - print "not " unless unpack("I", pack("I", $I)) == $I; - print "ok ", $test++, "\n"; -} - -# 110..114: l -foreach my $l (-2147483648, -1, 0, 1, 2147483647) { - print "not " unless unpack("l", pack("l", $l)) == $l; - print "ok ", $test++, "\n"; -} - -# 115..119: L -foreach my $L (0, 1, 2147483647, 2147483648, 4294967295) { - print "not " unless unpack("L", pack("L", $L)) == $L; - print "ok ", $test++, "\n"; -} - -# 120..124: n -foreach my $n (0, 1, 32767, 32768, 65535) { - print "not " unless unpack("n", pack("n", $n)) == $n; - print "ok ", $test++, "\n"; -} - -# 125..129: v -foreach my $v (0, 1, 32767, 32768, 65535) { - print "not " unless unpack("v", pack("v", $v)) == $v; - print "ok ", $test++, "\n"; -} - -# 130..134: N -foreach my $N (0, 1, 2147483647, 2147483648, 4294967295) { - print "not " unless unpack("N", pack("N", $N)) == $N; - print "ok ", $test++, "\n"; -} - -# 135..139: V -foreach my $V (0, 1, 2147483647, 2147483648, 4294967295) { - print "not " unless unpack("V", pack("V", $V)) == $V; - print "ok ", $test++, "\n"; -} - -# 140..143: pack nvNV byteorders - -print "not " unless pack("n", 0xdead) eq "\xde\xad"; -print "ok ", $test++, "\n"; - -print "not " unless pack("v", 0xdead) eq "\xad\xde"; -print "ok ", $test++, "\n"; - -print "not " unless pack("N", 0xdeadbeef) eq "\xde\xad\xbe\xef"; -print "ok ", $test++, "\n"; - -print "not " unless pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde"; -print "ok ", $test++, "\n"; - -# 144..152: / - -my $z; -eval { ($x) = unpack '/a*','hello' }; -print 'not ' unless $@; print "ok $test\n"; $test++; -eval { ($z,$x,$y) = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" }; -print $@ eq '' && $z eq 'ok' ? "ok $test\n" : "not ok $test\n"; $test++; -print $@ eq '' && $x eq 'yes' ? "ok $test\n" : "not ok $test\n"; $test++; -print $@ eq '' && $y eq 'z' ? "ok $test\n" : "not ok $test\n"; $test++; - -eval { ($x) = pack '/a*','hello' }; -print 'not ' unless $@; print "ok $test\n"; $test++; -$z = pack 'n/a* N/Z* w/A*','string','hi there ','etc'; -print 'not ' unless $z eq "\000\006string\0\0\0\012hi there \000\003etc"; -print "ok $test\n"; $test++; - -eval { ($x) = unpack 'a/a*/a*', '212ab345678901234567' }; -print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "#$x,$@\nnot ok $test\n"; -$test++; - -eval { ($x) = unpack 'a/a*/a*', '3012ab345678901234567' }; -print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "not ok $test\n"; -$test++; - -eval { ($x) = unpack 'a/a*/b*', '212ab' }; -my $expected_x = '100001100100'; -if ($Config{ebcdic} eq 'define') { $expected_x = '100000010100'; } -print $@ eq '' && $x eq $expected_x ? "ok $test\n" : "#$x,$@\nnot ok $test\n"; -$test++; - -# 153..156: / with # - -eval { ($z,$x,$y) = unpack <<EOU, "003ok \003yes\004z\000abc" }; - a3/A # Count in ASCII - C/a* # Count in a C char - C/Z # Count in a C char but skip after \0 -EOU -print $@ eq '' && $z eq 'ok' ? "ok $test\n" : "not ok $test\n"; $test++; -print $@ eq '' && $x eq 'yes' ? "ok $test\n" : "not ok $test\n"; $test++; -print $@ eq '' && $y eq 'z' ? "ok $test\n" : "not ok $test\n"; $test++; - -$z = pack <<EOP,'string','etc'; - n/a* # Count as network short - w/A* # Count a BER integer -EOP -print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++; - -print 'not ' unless "1.20.300.4000" eq sprintf "%vd", pack("U*",1,20,300,4000); -print "ok $test\n"; $test++; -print 'not ' unless "1.20.300.4000" eq - sprintf "%vd", pack(" U*",1,20,300,4000); -print "ok $test\n"; $test++; -print 'not ' unless v1.20.300.4000 ne - sprintf "%vd", pack("C0U*",1,20,300,4000); -print "ok $test\n"; $test++; - diff --git a/contrib/perl5/t/op/pat.t b/contrib/perl5/t/op/pat.t deleted file mode 100755 index ffbc945..0000000 --- a/contrib/perl5/t/op/pat.t +++ /dev/null @@ -1,1130 +0,0 @@ -#!./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. - -print "1..231\n"; - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} -eval 'use Config'; # Defaults assumed if this fails - -$x = "abc\ndef\n"; - -if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";} -if ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";} - -$* = 1; -if ($x =~ /^def/) {print "ok 3\n";} else {print "not ok 3\n";} -$* = 0; - -$_ = '123'; -if (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";} - -if ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";} -if ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";} - -if ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";} -if ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";} - -if ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";} -if ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";} - -if ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";} -if ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";} - -$_ = 'aaabbbccc'; -if (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') { - print "ok 13\n"; -} else { - print "not ok 13\n"; -} -if (/(a+b+c+)/ && $1 eq 'aaabbbccc') { - print "ok 14\n"; -} else { - print "not ok 14\n"; -} - -if (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";} - -$_ = 'aaabccc'; -if (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";} -if (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";} - -$_ = 'aaaccc'; -if (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";} -if (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";} - -$_ = 'abcdef'; -if (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";} -if (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";} - -if (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";} - -if (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";} - -$* = 1; # test 3 only tested the optimized version--this one is for real -if ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";} -$* = 0; - -$XXX{123} = 123; -$XXX{234} = 234; -$XXX{345} = 345; - -@XXX = ('ok 25','not ok 25', 'ok 26','not ok 26','not ok 27'); -while ($_ = shift(@XXX)) { - ?(.*)? && (print $1,"\n"); - /not/ && reset; - /not ok 26/ && reset 'X'; -} - -while (($key,$val) = each(%XXX)) { - print "not ok 27\n"; - exit; -} - -print "ok 27\n"; - -'cde' =~ /[^ab]*/; -'xyz' =~ //; -if ($& eq 'xyz') {print "ok 28\n";} else {print "not ok 28\n";} - -$foo = '[^ab]*'; -'cde' =~ /$foo/; -'xyz' =~ //; -if ($& eq 'xyz') {print "ok 29\n";} else {print "not ok 29\n";} - -$foo = '[^ab]*'; -'cde' =~ /$foo/; -'xyz' =~ /$null/; -if ($& eq 'xyz') {print "ok 30\n";} else {print "not ok 30\n";} - -$_ = 'abcdefghi'; -/def/; # optimized up to cmd -if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 31\n";} else {print "not ok 31\n";} - -/cde/ + 0; # optimized only to spat -if ("$`:$&:$'" eq 'ab:cde:fghi') {print "ok 32\n";} else {print "not ok 32\n";} - -/[d][e][f]/; # not optimized -if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 33\n";} else {print "not ok 33\n";} - -$_ = 'now is the {time for all} good men to come to.'; -/ {([^}]*)}/; -if ($1 eq 'time for all') {print "ok 34\n";} else {print "not ok 34 $1\n";} - -$_ = 'xxx {3,4} yyy zzz'; -print /( {3,4})/ ? "ok 35\n" : "not ok 35\n"; -print $1 eq ' ' ? "ok 36\n" : "not ok 36\n"; -print /( {4,})/ ? "not ok 37\n" : "ok 37\n"; -print /( {2,3}.)/ ? "ok 38\n" : "not ok 38\n"; -print $1 eq ' y' ? "ok 39\n" : "not ok 39\n"; -print /(y{2,3}.)/ ? "ok 40\n" : "not ok 40\n"; -print $1 eq 'yyy ' ? "ok 41\n" : "not ok 41\n"; -print /x {3,4}/ ? "not ok 42\n" : "ok 42\n"; -print /^xxx {3,4}/ ? "not ok 43\n" : "ok 43\n"; - -$_ = "now is the time for all good men to come to."; -@words = /(\w+)/g; -print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to" - ? "ok 44\n" - : "not ok 44\n"; - -@words = (); -while (/\w+/g) { - push(@words, $&); -} -print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to" - ? "ok 45\n" - : "not ok 45\n"; - -@words = (); -pos = 0; -while (/to/g) { - push(@words, $&); -} -print join(':',@words) eq "to:to" - ? "ok 46\n" - : "not ok 46 `@words'\n"; - -pos $_ = 0; -@words = /to/g; -print join(':',@words) eq "to:to" - ? "ok 47\n" - : "not ok 47 `@words'\n"; - -$_ = "abcdefghi"; - -$pat1 = 'def'; -$pat2 = '^def'; -$pat3 = '.def.'; -$pat4 = 'abc'; -$pat5 = '^abc'; -$pat6 = 'abc$'; -$pat7 = 'ghi'; -$pat8 = '\w*ghi'; -$pat9 = 'ghi$'; - -$t1=$t2=$t3=$t4=$t5=$t6=$t7=$t8=$t9=0; - -for $iter (1..5) { - $t1++ if /$pat1/o; - $t2++ if /$pat2/o; - $t3++ if /$pat3/o; - $t4++ if /$pat4/o; - $t5++ if /$pat5/o; - $t6++ if /$pat6/o; - $t7++ if /$pat7/o; - $t8++ if /$pat8/o; - $t9++ if /$pat9/o; -} - -$x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9"; -print $x eq '505550555' ? "ok 48\n" : "not ok 48 $x\n"; - -$xyz = 'xyz'; -print "abc" =~ /^abc$|$xyz/ ? "ok 49\n" : "not ok 49\n"; - -# perl 4.009 says "unmatched ()" -eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"'; -print $@ eq "" ? "ok 50\n" : "not ok 50\n"; -print $result eq "abc:bc" ? "ok 51\n" : "not ok 51\n"; - - -$_="abcfooabcbar"; -$x=/abc/g; -print $` eq "" ? "ok 52\n" : "not ok 52\n" if $x; -$x=/abc/g; -print $` eq "abcfoo" ? "ok 53\n" : "not ok 53\n" if $x; -$x=/abc/g; -print $x == 0 ? "ok 54\n" : "not ok 54\n"; -pos = 0; -$x=/ABC/gi; -print $` eq "" ? "ok 55\n" : "not ok 55\n" if $x; -$x=/ABC/gi; -print $` eq "abcfoo" ? "ok 56\n" : "not ok 56\n" if $x; -$x=/ABC/gi; -print $x == 0 ? "ok 57\n" : "not ok 57\n"; -pos = 0; -$x=/abc/g; -print $' eq "fooabcbar" ? "ok 58\n" : "not ok 58\n" if $x; -$x=/abc/g; -print $' eq "bar" ? "ok 59\n" : "not ok 59\n" if $x; -$_ .= ''; -@x=/abc/g; -print scalar @x == 2 ? "ok 60\n" : "not ok 60\n"; - -$_ = "abdc"; -pos $_ = 2; -/\Gc/gc; -print "not " if (pos $_) != 2; -print "ok 61\n"; -/\Gc/g; -print "not " if defined pos $_; -print "ok 62\n"; - -$out = 1; -'abc' =~ m'a(?{ $out = 2 })b'; -print "not " if $out != 2; -print "ok 63\n"; - -$out = 1; -'abc' =~ m'a(?{ $out = 3 })c'; -print "not " if $out != 1; -print "ok 64\n"; - -$_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6'; -@out = /(?<!foo)bar./g; -print "not " if "@out" ne 'bar2 barf'; -print "ok 65\n"; - -# Tests which depend on REG_INFTY -$reg_infty = defined $Config{reg_infty} ? $Config{reg_infty} : 32767; -$reg_infty_m = $reg_infty - 1; $reg_infty_p = $reg_infty + 1; - -# As well as failing if the pattern matches do unexpected things, the -# next three tests will fail if you should have picked up a lower-than- -# default value for $reg_infty from Config.pm, but have not. - -undef $@; -print "not " if eval q(('aaa' =~ /(a{1,$reg_infty_m})/)[0] ne 'aaa') || $@; -print "ok 66\n"; - -undef $@; -print "not " if eval q(('a' x $reg_infty_m) !~ /a{$reg_infty_m}/) || $@; -print "ok 67\n"; - -undef $@; -print "not " if eval q(('a' x ($reg_infty_m - 1)) =~ /a{$reg_infty_m}/) || $@; -print "ok 68\n"; - -undef $@; -eval "'aaa' =~ /a{1,$reg_infty}/"; -print "not " if $@ !~ m%^\QQuantifier in {,} bigger than%; -print "ok 69\n"; - -eval "'aaa' =~ /a{1,$reg_infty_p}/"; -print "not " - if $@ !~ m%^\QQuantifier in {,} bigger than%; -print "ok 70\n"; -undef $@; - -# Poke a couple more parse failures - -$context = 'x' x 256; -eval qq("${context}y" =~ /(?<=$context)y/); -print "not " if $@ !~ m%^\QLookbehind longer than 255 not%; -print "ok 71\n"; - -# removed test -print "ok 72\n"; - -# Long Monsters -$test = 73; -for $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory - $a = 'a' x $l; - print "# length=$l\nnot " unless "ba$a=" =~ /a$a=/; - print "ok $test\n"; - $test++; - - print "not " if "b$a=" =~ /a$a=/; - print "ok $test\n"; - $test++; -} - -# 20000 nodes, each taking 3 words per string, and 1 per branch -$long_constant_len = join '|', 12120 .. 32645; -$long_var_len = join '|', 8120 .. 28645; -%ans = ( 'ax13876y25677lbc' => 1, - 'ax13876y25677mcb' => 0, # not b. - 'ax13876y35677nbc' => 0, # Num too big - 'ax13876y25677y21378obc' => 1, - 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o] - 'ax13876y25677y21378y21378kbc' => 1, - 'ax13876y25677y21378y21378kcb' => 0, # Not b. - 'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs - ); - -for ( keys %ans ) { - print "# const-len `$_' not => $ans{$_}\nnot " - if $ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o; - print "ok $test\n"; - $test++; - print "# var-len `$_' not => $ans{$_}\nnot " - if $ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o; - print "ok $test\n"; - $test++; -} - -$_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e"; -$expect = "(bla()) ((l)u((e))) (l(e)e)"; - -sub matchit { - m/ - ( - \( - (?{ $c = 1 }) # Initialize - (?: - (?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop - (?! - ) # Fail: will unwind one iteration back - ) - (?: - [^()]+ # Match a big chunk - (?= - [()] - ) # Do not try to match subchunks - | - \( - (?{ ++$c }) - | - \) - (?{ --$c }) - ) - )+ # This may not match with different subblocks - ) - (?(?{ $c != 0 }) - (?! - ) # Fail - ) # Otherwise the chunk 1 may succeed with $c>0 - /xg; -} - -@ans = (); -push @ans, $res while $res = matchit; - -print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne "1 1 1"; -print "ok $test\n"; -$test++; - -@ans = matchit; - -print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect; -print "ok $test\n"; -$test++; - -print "not " unless "abc" =~ /^(??{"a"})b/; -print "ok $test\n"; -$test++; - -my $matched; -$matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/; - -@ans = @ans1 = (); -push(@ans, $res), push(@ans1, $&) while $res = m/$matched/g; - -print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne "1 1 1"; -print "ok $test\n"; -$test++; - -print "# ans1='@ans1'\n# expect='$expect'\nnot " if "@ans1" ne $expect; -print "ok $test\n"; -$test++; - -@ans = m/$matched/g; - -print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect; -print "ok $test\n"; -$test++; - -@ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad -print "not " if "@ans" ne 'a/ b'; -print "ok $test\n"; -$test++; - -$code = '{$blah = 45}'; -$blah = 12; -eval { /(?$code)/ }; -print "not " unless $@ and $@ =~ /not allowed at runtime/ and $blah == 12; -print "ok $test\n"; -$test++; - -for $code ('{$blah = 45}','=xx') { - $blah = 12; - $res = eval { "xx" =~ /(?$code)/o }; - if ($code eq '=xx') { - print "#'$@','$res','$blah'\nnot " unless not $@ and $res; - } else { - print "#'$@','$res','$blah'\nnot " unless $@ and $@ =~ /not allowed at runtime/ and $blah == 12; - } - print "ok $test\n"; - $test++; -} - -$code = '{$blah = 45}'; -$blah = 12; -eval "/(?$code)/"; -print "not " if $blah != 45; -print "ok $test\n"; -$test++; - -$blah = 12; -/(?{$blah = 45})/; -print "not " if $blah != 45; -print "ok $test\n"; -$test++; - -$x = 'banana'; -$x =~ /.a/g; -print "not " unless pos($x) == 2; -print "ok $test\n"; -$test++; - -$x =~ /.z/gc; -print "not " unless pos($x) == 2; -print "ok $test\n"; -$test++; - -sub f { - my $p = $_[0]; - return $p; -} - -$x =~ /.a/g; -print "not " unless f(pos($x)) == 4; -print "ok $test\n"; -$test++; - -$x = $^R = 67; -'foot' =~ /foo(?{$x = 12; 75})[t]/; -print "not " unless $^R eq '75'; -print "ok $test\n"; -$test++; - -$x = $^R = 67; -'foot' =~ /foo(?{$x = 12; 75})[xy]/; -print "not " unless $^R eq '67' and $x eq '12'; -print "ok $test\n"; -$test++; - -$x = $^R = 67; -'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/; -print "not " unless $^R eq '79' and $x eq '12'; -print "ok $test\n"; -$test++; - -print "not " unless qr/\b\v$/i eq '(?i-xsm:\bv$)'; -print "ok $test\n"; -$test++; - -print "not " unless qr/\b\v$/s eq '(?s-xim:\bv$)'; -print "ok $test\n"; -$test++; - -print "not " unless qr/\b\v$/m eq '(?m-xis:\bv$)'; -print "ok $test\n"; -$test++; - -print "not " unless qr/\b\v$/x eq '(?x-ism:\bv$)'; -print "ok $test\n"; -$test++; - -print "not " unless qr/\b\v$/xism eq '(?msix:\bv$)'; -print "ok $test\n"; -$test++; - -print "not " unless qr/\b\v$/ eq '(?-xism:\bv$)'; -print "ok $test\n"; -$test++; - -$_ = 'xabcx'; -foreach $ans ('', 'c') { - /(?<=(?=a)..)((?=c)|.)/g; - print "# \$1 ='$1'\n# \$ans='$ans'\nnot " unless $1 eq $ans; - print "ok $test\n"; - $test++; -} - -$_ = 'a'; -foreach $ans ('', 'a', '') { - /^|a|$/g; - print "# \$& ='$&'\n# \$ans='$ans'\nnot " unless $& eq $ans; - print "ok $test\n"; - $test++; -} - -sub prefixify { - my($v,$a,$b,$res) = @_; - $v =~ s/\Q$a\E/$b/; - print "not " unless $res eq $v; - print "ok $test\n"; - $test++; -} -prefixify('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch'); -prefixify('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch'); - -$_ = 'var="foo"'; -/(\")/; -print "not " unless $1 and /$1/; -print "ok $test\n"; -$test++; - -$a=qr/(?{++$b})/; -$b = 7; -/$a$a/; -print "not " unless $b eq '9'; -print "ok $test\n"; -$test++; - -$c="$a"; -/$a$a/; -print "not " unless $b eq '11'; -print "ok $test\n"; -$test++; - -{ - use re "eval"; - /$a$c$a/; - print "not " unless $b eq '14'; - print "ok $test\n"; - $test++; - - local $lex_a = 2; - my $lex_a = 43; - my $lex_b = 17; - my $lex_c = 27; - my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/); - print "not " unless $lex_res eq '1'; - print "ok $test\n"; - $test++; - print "not " unless $lex_a eq '44'; - print "ok $test\n"; - $test++; - print "not " unless $lex_c eq '43'; - print "ok $test\n"; - $test++; - - - no re "eval"; - $match = eval { /$a$c$a/ }; - print "not " - unless $b eq '14' and $@ =~ /Eval-group not allowed/ and not $match; - print "ok $test\n"; - $test++; -} - -{ - local $lex_a = 2; - my $lex_a = 43; - my $lex_b = 17; - my $lex_c = 27; - my $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/); - print "not " unless $lex_res eq '1'; - print "ok $test\n"; - $test++; - print "not " unless $lex_a eq '44'; - print "ok $test\n"; - $test++; - print "not " unless $lex_c eq '43'; - print "ok $test\n"; - $test++; -} - -{ - package aa; - $c = 2; - $::c = 3; - '' =~ /(?{ $c = 4 })/; - print "not " unless $c == 4; -} -print "ok $test\n"; -$test++; -print "not " unless $c == 3; -print "ok $test\n"; -$test++; - -sub must_warn_pat { - my $warn_pat = shift; - return sub { print "not " unless $_[0] =~ /$warn_pat/ } -} - -sub must_warn { - my ($warn_pat, $code) = @_; - local %SIG; - eval 'BEGIN { use warnings; $SIG{__WARN__} = $warn_pat };' . $code; - print "ok $test\n"; - $test++; -} - - -sub make_must_warn { - my $warn_pat = shift; - return sub { must_warn(must_warn_pat($warn_pat)) } -} - -my $for_future = make_must_warn('reserved for future extensions'); - -&$for_future('q(a:[b]:) =~ /[x[:foo:]]/'); - -#&$for_future('q(a=[b]=) =~ /[x[=foo=]]/'); -print "ok $test\n"; $test++; # now a fatal croak - -#&$for_future('q(a.[b].) =~ /[x[.foo.]]/'); -print "ok $test\n"; $test++; # now a fatal croak - -# test if failure of patterns returns empty list -$_ = 'aaa'; -@_ = /bbb/; -print "not " if @_; -print "ok $test\n"; -$test++; - -@_ = /bbb/g; -print "not " if @_; -print "ok $test\n"; -$test++; - -@_ = /(bbb)/; -print "not " if @_; -print "ok $test\n"; -$test++; - -@_ = /(bbb)/g; -print "not " if @_; -print "ok $test\n"; -$test++; - -/a(?=.$)/; -print "not " if $#+ != 0 or $#- != 0; -print "ok $test\n"; -$test++; - -print "not " if $+[0] != 2 or $-[0] != 1; -print "ok $test\n"; -$test++; - -print "not " - if defined $+[1] or defined $-[1] or defined $+[2] or defined $-[2]; -print "ok $test\n"; -$test++; - -/a(a)(a)/; -print "not " if $#+ != 2 or $#- != 2; -print "ok $test\n"; -$test++; - -print "not " if $+[0] != 3 or $-[0] != 0; -print "ok $test\n"; -$test++; - -print "not " if $+[1] != 2 or $-[1] != 1; -print "ok $test\n"; -$test++; - -print "not " if $+[2] != 3 or $-[2] != 2; -print "ok $test\n"; -$test++; - -print "not " - if defined $+[3] or defined $-[3] or defined $+[4] or defined $-[4]; -print "ok $test\n"; -$test++; - -/.(a)(b)?(a)/; -print "not " if $#+ != 3 or $#- != 3; -print "ok $test\n"; -$test++; - -print "not " if $+[0] != 3 or $-[0] != 0; -print "ok $test\n"; -$test++; - -print "not " if $+[1] != 2 or $-[1] != 1; -print "ok $test\n"; -$test++; - -print "not " if $+[3] != 3 or $-[3] != 2; -print "ok $test\n"; -$test++; - -print "not " - if defined $+[2] or defined $-[2] or defined $+[4] or defined $-[4]; -print "ok $test\n"; -$test++; - -/.(a)/; -print "not " if $#+ != 1 or $#- != 1; -print "ok $test\n"; -$test++; - -print "not " if $+[0] != 2 or $-[0] != 0; -print "ok $test\n"; -$test++; - -print "not " if $+[1] != 2 or $-[1] != 1; -print "ok $test\n"; -$test++; - -print "not " - if defined $+[2] or defined $-[2] or defined $+[3] or defined $-[3]; -print "ok $test\n"; -$test++; - -eval { $+[0] = 13; }; -print "not " - if $@ !~ /^Modification of a read-only value attempted/; -print "ok $test\n"; -$test++; - -eval { $-[0] = 13; }; -print "not " - if $@ !~ /^Modification of a read-only value attempted/; -print "ok $test\n"; -$test++; - -eval { @+ = (7, 6, 5); }; -print "not " - if $@ !~ /^Modification of a read-only value attempted/; -print "ok $test\n"; -$test++; - -eval { @- = qw(foo bar); }; -print "not " - if $@ !~ /^Modification of a read-only value attempted/; -print "ok $test\n"; -$test++; - -/.(a)(ba*)?/; -print "#$#-..$#+\nnot " if $#+ != 2 or $#- != 1; -print "ok $test\n"; -$test++; - -$_ = 'aaa'; -pos = 1; -@a = /\Ga/g; -print "not " unless "@a" eq "a a"; -print "ok $test\n"; -$test++; - -$str = 'abcde'; -pos $str = 2; - -print "not " if $str =~ /^\G/; -print "ok $test\n"; -$test++; - -print "not " if $str =~ /^.\G/; -print "ok $test\n"; -$test++; - -print "not " unless $str =~ /^..\G/; -print "ok $test\n"; -$test++; - -print "not " if $str =~ /^...\G/; -print "ok $test\n"; -$test++; - -print "not " unless $str =~ /.\G./ and $& eq 'bc'; -print "ok $test\n"; -$test++; - -print "not " unless $str =~ /\G../ and $& eq 'cd'; -print "ok $test\n"; -$test++; - -undef $foo; undef $bar; -print "#'$str','$foo','$bar'\nnot " - unless $str =~ /b(?{$foo = $_; $bar = pos})c/ - and $foo eq 'abcde' and $bar eq 2; -print "ok $test\n"; -$test++; - -undef $foo; undef $bar; -pos $str = undef; -print "#'$str','$foo','$bar'\nnot " - unless $str =~ /b(?{$foo = $_; $bar = pos})c/g - and $foo eq 'abcde' and $bar eq 2 and pos $str eq 3; -print "ok $test\n"; -$test++; - -$_ = $str; - -undef $foo; undef $bar; -print "#'$str','$foo','$bar'\nnot " - unless /b(?{$foo = $_; $bar = pos})c/ - and $foo eq 'abcde' and $bar eq 2; -print "ok $test\n"; -$test++; - -undef $foo; undef $bar; -print "#'$str','$foo','$bar'\nnot " - unless /b(?{$foo = $_; $bar = pos})c/g - and $foo eq 'abcde' and $bar eq 2 and pos eq 3; -print "ok $test\n"; -$test++; - -undef $foo; undef $bar; -pos = undef; -1 while /b(?{$foo = $_; $bar = pos})c/g; -print "#'$str','$foo','$bar'\nnot " - unless $foo eq 'abcde' and $bar eq 2 and not defined pos; -print "ok $test\n"; -$test++; - -undef $foo; undef $bar; -$_ = 'abcde|abcde'; -print "#'$str','$foo','$bar','$_'\nnot " - unless s/b(?{$foo = $_; $bar = pos})c/x/g and $foo eq 'abcde|abcde' - and $bar eq 8 and $_ eq 'axde|axde'; -print "ok $test\n"; -$test++; - -@res = (); -# List context: -$_ = 'abcde|abcde'; -@dummy = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g; -@res = map {defined $_ ? "'$_'" : 'undef'} @res; -$res = "@res"; -print "#'@res' '$_'\nnot " - unless "@res" eq "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'"; -print "ok $test\n"; -$test++; - -@res = (); -@dummy = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g; -@res = map {defined $_ ? "'$_'" : 'undef'} @res; -$res = "@res"; -print "#'@res' '$_'\nnot " - unless "@res" eq - "'' 'ab' 'cde|abcde' " . - "'' 'abc' 'de|abcde' " . - "'abcd' 'e|' 'abcde' " . - "'abcde|' 'ab' 'cde' " . - "'abcde|' 'abc' 'de'" ; -print "ok $test\n"; -$test++; - -#Some more \G anchor checks -$foo='aabbccddeeffgg'; - -pos($foo)=1; - -$foo=~/.\G(..)/g; -print "not " unless($1 eq 'ab'); -print "ok $test\n"; -$test++; - -pos($foo) += 1; -$foo=~/.\G(..)/g; -print "not " unless($1 eq 'cc'); -print "ok $test\n"; -$test++; - -pos($foo) += 1; -$foo=~/.\G(..)/g; -print "not " unless($1 eq 'de'); -print "ok $test\n"; -$test++; - -print "not " unless $foo =~ /\Gef/g; -print "ok $test\n"; -$test++; - -undef pos $foo; - -$foo=~/\G(..)/g; -print "not " unless($1 eq 'aa'); -print "ok $test\n"; -$test++; - -$foo=~/\G(..)/g; -print "not " unless($1 eq 'bb'); -print "ok $test\n"; -$test++; - -pos($foo)=5; -$foo=~/\G(..)/g; -print "not " unless($1 eq 'cd'); -print "ok $test\n"; -$test++; - -$_='123x123'; -@res = /(\d*|x)/g; -print "not " unless('123||x|123|' eq join '|', @res); -print "ok $test\n"; -$test++; - -# see if matching against temporaries (created via pp_helem()) is safe -{ foo => "ok $test\n".$^X }->{foo} =~ /^(.*)\n/g; -print "$1\n"; -$test++; - -# See if $i work inside (?{}) in the presense of saved substrings and -# changing $_ -@a = qw(foo bar); -@b = (); -s/(\w)(?{push @b, $1})/,$1,/g for @a; - -print "# \@b='@b', expect 'f o o b a r'\nnot " unless("@b" eq "f o o b a r"); -print "ok $test\n"; -$test++; - -print "not " unless("@a" eq ",f,,o,,o, ,b,,a,,r,"); -print "ok $test\n"; -$test++; - -$brackets = qr{ - { (?> [^{}]+ | (??{ $brackets }) )* } - }x; - -"{{}" =~ $brackets; -print "ok $test\n"; # Did we survive? -$test++; - -"something { long { and } hairy" =~ $brackets; -print "ok $test\n"; # Did we survive? -$test++; - -"something { long { and } hairy" =~ m/((??{ $brackets }))/; -print "not " unless $1 eq "{ and }"; -print "ok $test\n"; -$test++; - -$_ = "a-a\nxbb"; -pos=1; -m/^-.*bb/mg and print "not "; -print "ok $test\n"; -$test++; - -$text = "aaXbXcc"; -pos($text)=0; -$text =~ /\GXb*X/g and print 'not '; -print "ok $test\n"; -$test++; - -$text = "xA\n" x 500; -$text =~ /^\s*A/m and print 'not '; -print "ok $test\n"; -$test++; - -$text = "abc dbf"; -@res = ($text =~ /.*?(b).*?\b/g); -"@res" eq 'b b' or print 'not '; -print "ok $test\n"; -$test++; - -@a = map chr,0..255; - -@b = grep(/\S/,@a); -@c = grep(/[^\s]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\S/,@a); -@c = grep(/[\S]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\s/,@a); -@c = grep(/[^\S]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\s/,@a); -@c = grep(/[\s]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\D/,@a); -@c = grep(/[^\d]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\D/,@a); -@c = grep(/[\D]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\d/,@a); -@c = grep(/[^\D]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\d/,@a); -@c = grep(/[\d]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\W/,@a); -@c = grep(/[^\w]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\W/,@a); -@c = grep(/[\W]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\w/,@a); -@c = grep(/[^\W]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -@b = grep(/\w/,@a); -@c = grep(/[\w]/,@a); -print "not " if "@b" ne "@c"; -print "ok $test\n"; -$test++; - -# see if backtracking optimization works correctly -"\n\n" =~ /\n $ \n/x or print "not "; -print "ok $test\n"; -$test++; - -"\n\n" =~ /\n* $ \n/x or print "not "; -print "ok $test\n"; -$test++; - -"\n\n" =~ /\n+ $ \n/x or print "not "; -print "ok $test\n"; -$test++; - -[] =~ /^ARRAY/ or print "# [] \nnot "; -print "ok $test\n"; -$test++; - -eval << 'EOE'; -{ - package S; - use overload '""' => sub { 'Object S' }; - sub new { bless [] } -} -$a = 'S'->new; -EOE - -$a and $a =~ /^Object\sS/ or print "# '$a' \nnot "; -print "ok $test\n"; -$test++; - -# test result of match used as match (!) -'a1b' =~ ('xyz' =~ /y/) and $` eq 'a' or print "not "; -print "ok $test\n"; -$test++; - -'a1b' =~ ('xyz' =~ /t/) and $` eq 'a' or print "not "; -print "ok $test\n"; -$test++; - -$w = 0; -{ - local $SIG{__WARN__} = sub { $w = 1 }; - local $^W = 1; - $w = 1 if ("1\n" x 102) =~ /^\s*\n/m; -} -print $w ? "not " : "", "ok $test\n"; -$test++; - -my %space = ( spc => " ", - tab => "\t", - cr => "\r", - lf => "\n", - ff => "\f", -# There's no \v but the vertical tabulator seems miraculously -# be 11 both in ASCII and EBCDIC. - vt => chr(11), - false => "space" ); - -my @space0 = sort grep { $space{$_} =~ /\s/ } keys %space; -my @space1 = sort grep { $space{$_} =~ /[[:space:]]/ } keys %space; -my @space2 = sort grep { $space{$_} =~ /[[:blank:]]/ } keys %space; - -print "not " unless "@space0" eq "cr ff lf spc tab"; -print "ok $test # @space0\n"; -$test++; - -print "not " unless "@space1" eq "cr ff lf spc tab vt"; -print "ok $test # @space1\n"; -$test++; - -print "not " unless "@space2" eq "spc tab"; -print "ok $test # @space2\n"; -$test++; - -# bugid 20001021.005 - this caused a SEGV -print "not " unless undef =~ /^([^\/]*)(.*)$/; -print "ok $test\n"; -$test++; - -{ - # japhy -- added 03/03/2001 - () = (my $str = "abc") =~ /(...)/; - $str = "def"; - print "not " if $1 ne "abc"; - print "ok $test\n"; - $test++; -} diff --git a/contrib/perl5/t/op/pos.t b/contrib/perl5/t/op/pos.t deleted file mode 100755 index f3bc23c..0000000 --- a/contrib/perl5/t/op/pos.t +++ /dev/null @@ -1,23 +0,0 @@ -#!./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"; - - - diff --git a/contrib/perl5/t/op/push.t b/contrib/perl5/t/op/push.t deleted file mode 100755 index a67caed..0000000 --- a/contrib/perl5/t/op/push.t +++ /dev/null @@ -1,56 +0,0 @@ -#!./perl - -# $RCSfile: push.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:13 $ - -@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,@x); -if (join(':',@x) eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} -push(@x,4); -if (join(':',@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(':',@x) eq '1:2:3:1:2:3:4:3') {print "ok 3\n";} else {print "not ok 3\n";} -pop(x); -if (join(':',@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(':',@got) eq join(':',@get) && - join(':',@x) eq join(':',@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 diff --git a/contrib/perl5/t/op/pwent.t b/contrib/perl5/t/op/pwent.t deleted file mode 100755 index d811f06..0000000 --- a/contrib/perl5/t/op/pwent.t +++ /dev/null @@ -1,170 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - eval {my @n = getpwuid 0}; - 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 ($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; - -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(); - -if (keys %perfect == 0) { - $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); diff --git a/contrib/perl5/t/op/quotemeta.t b/contrib/perl5/t/op/quotemeta.t deleted file mode 100755 index ea62ed8..0000000 --- a/contrib/perl5/t/op/quotemeta.t +++ /dev/null @@ -1,47 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; -} - -print "1..17\n"; - -if ($Config{ebcdic} eq 'define') { - $_=join "", map chr($_), 129..233; - - # 105 characters - 52 letters = 53 backslashes - # 105 characters + 53 backslashes = 158 characters - $_= quotemeta $_; - if ( length == 158 ){print "ok 1\n"} else {print "not ok 1\n"} - # 104 non-backslash characters - if (tr/\\//cd == 104){print "ok 2\n"} else {print "not ok 2\n"} -} 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 $_; - if ( length == 129 ){print "ok 1\n"} else {print "not ok 1\n"} - # 95 non-backslash characters - if (tr/\\//cd == 95){print "ok 2\n"} else {print "not ok 2\n"} -} - -if (length quotemeta "" == 0){print "ok 3\n"} else {print "not ok 3\n"} - -print "aA\UbB\LcC\EdD" eq "aABBccdD" ? "ok 4\n" : "not ok 4 \n"; -print "aA\LbB\UcC\EdD" eq "aAbbCCdD" ? "ok 5\n" : "not ok 5 \n"; -print "\L\upERL" eq "Perl" ? "ok 6\n" : "not ok 6 \n"; -print "\u\LpERL" eq "Perl" ? "ok 7\n" : "not ok 7 \n"; -print "\U\lPerl" eq "pERL" ? "ok 8\n" : "not ok 8 \n"; -print "\l\UPerl" eq "pERL" ? "ok 9\n" : "not ok 9 \n"; -print "\u\LpE\Q#X#\ER\EL" eq "Pe\\#x\\#rL" ? "ok 10\n" : "not ok 10 \n"; -print "\l\UPe\Q!x!\Er\El" eq "pE\\!X\\!Rl" ? "ok 11\n" : "not ok 11 \n"; -print "\Q\u\LpE.X.R\EL\E." eq "Pe\\.x\\.rL." ? "ok 12\n" : "not ok 12 \n"; -print "\Q\l\UPe*x*r\El\E*" eq "pE\\*X\\*Rl*" ? "ok 13\n" : "not ok 13 \n"; -print "\U\lPerl\E\E\E\E" eq "pERL" ? "ok 14\n" : "not ok 14 \n"; -print "\l\UPerl\E\E\E\E" eq "pERL" ? "ok 15\n" : "not ok 15 \n"; - -print length(quotemeta("\x{263a}")) == 1 ? "ok 16\n" : "not ok 16\n"; -print quotemeta("\x{263a}") eq "\x{263a}" ? "ok 17\n" : "not ok 17\n"; diff --git a/contrib/perl5/t/op/rand.t b/contrib/perl5/t/op/rand.t deleted file mode 100755 index 83186ae..0000000 --- a/contrib/perl5/t/op/rand.t +++ /dev/null @@ -1,359 +0,0 @@ -#!./perl - -# From Tom Phoenix <rootbeer@teleport.com> 22 Feb 1997 -# Based upon a test script by kgb@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 = '../lib'; -} - -use strict; -use Config; - -print "1..11\n"; - -srand; # Shouldn't need this with 5.004... - # But I'll include it now and test for - # whether we needed it later. - -my $reps = 1000; # 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; - } - - - # Hints for TEST 1 - # - # 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.) - # - if ($max <= 0 or $max >= (2 ** $randbits)) {# Just in case... - print "# max=[$max] min=[$min]\nnot ok 1\n"; - print "# This perl was compiled with randbits=$randbits\n"; - print "# which is _way_ off. Or maybe your system rand is broken,\n"; - print "# or your C compiler can't multiply, or maybe Martians\n"; - print "# have taken over your computer. For starters, see about\n"; - print "# trying a better value for randbits, probably smaller.\n"; - # 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 - if ($off) { - $shouldbe = $Config{randbits} + $off; - print "# max=[$max] min=[$min]\nnot ok 1\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; - } else { - print "ok 1\n"; - } - - # Hints for TEST 2 - # - # 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. - # - if ($min < 0 or $max >= 1) { # Slightly redundant... - print "not ok 2\n"; - print "# min too low\n" if $min < 0; - print "# max too high\n" if $max >= 1; - } else { - print "ok 2\n"; - } - - # Hints for TEST 3 - # - # 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; - if ($sum < 0.4 or $sum > 0.6) { - print "not ok 3\n# Average random number is far from 0.5\n"; - } else { - print "ok 3\n"; - } - - # Hints for TEST 4 - # - # 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); - - if ($dev < 1.96) { - print "ok 4\n"; # 95% of the time. - 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 "ok 4\n# In here about 4% of the time. Hmmm...\n"; - 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 "ok 4\n# In this range about 1% of the time.\n"; - 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 "not ok 4\n# In this range very rarely.\n"; - 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 "not ok 4\n# Seriously whacked.\n"; - 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; -} - -{ - srand; # These three lines are for test 7 - my $time = time; # It's just faster to do them here. - my $rand = join ", ", rand, rand, rand; - - # Hints for TEST 5 - # - # This test checks that the argument to srand actually - # sets the seed for generating random numbers. - # - srand(3.14159); - my $r = rand; - srand(3.14159); - if (rand != $r) { - print "not ok 5\n"; - print "# srand is not consistent.\n"; - } else { - print "ok 5\n"; - } - - # Hints for TEST 6 - # - # This test just checks that the previous one didn't - # give us false confidence! - # - if (rand == $r) { - print "not ok 6\n"; - print "# rand is now unchanging!\n"; - } else { - print "ok 6\n"; - } - - # Hints for TEST 7 - # - # This checks that srand without arguments gives - # different sequences each time. Note: You shouldn't - # be calling srand more than once unless you know - # what you're doing! But if this fails on your - # system, run perlbug and let the developers know - # what other sources of randomness srand should - # tap into. - # - while ($time == time) { } # Wait for new second, just in case. - srand; - if ((join ", ", rand, rand, rand) eq $rand) { - print "not ok 7\n"; - print "# srand without args isn't varying.\n"; - } else { - print "ok 7\n"; - } -} - -# 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; - } - - # Hints for TEST 8 - # - # 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. - # - if ($min < 0 or $max >= 100 or ($max - $min) < 65) { - print "not ok 8\n"; - 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; - } else { - print "ok 8\n"; - } - - # Hints for TEST 9 - # - # This test checks that rand without an argument - # is equivalent to rand(1). - # - $_ = 12345; # Just for fun. - srand 12345; - my $r = rand; - srand 12345; - if (rand(1) == $r) { - print "ok 9\n"; - } else { - print "not ok 9\n"; - print "# rand without arguments isn't rand(1)!\n"; - } - - # Hints for TEST 10 - # - # This checks that rand without an argument is not - # rand($_). (In case somebody got overzealous.) - # - if ($r >= 1) { - print "not ok 10\n"; - print "# rand without arguments isn't under 1!\n"; - } else { - print "ok 10\n"; - } -} - -# Hints for TEST 11 -# -# This test checks whether Perl called srand for you. This should -# be the case in version 5.004 and later. Note: You must still -# call srand if your code might ever be run on a pre-5.004 system! -# -AUTOSRAND: -{ - unless ($Config{d_fork}) { - # Skip this test. It's not likely to be system-specific, anyway. - print "ok 11\n# Skipping this test on this platform.\n"; - last; - } - - my($pid, $first); - for (1..5) { - my $PERL = (($^O eq 'VMS') ? "MCR $^X" - : ($^O eq 'MSWin32') ? '.\perl' - : './perl'); - $pid = open PERL, qq[$PERL -e "print rand"|]; - die "Couldn't pipe from perl: $!" unless defined $pid; - if (defined $first) { - if ($first ne <PERL>) { - print "ok 11\n"; - last AUTOSRAND; - } - } else { - $first = <PERL>; - } - close PERL or die "perl returned error code $?"; - } - print "not ok 11\n# srand isn't being autocalled.\n"; -} diff --git a/contrib/perl5/t/op/range.t b/contrib/perl5/t/op/range.t deleted file mode 100755 index e8aecf5..0000000 --- a/contrib/perl5/t/op/range.t +++ /dev/null @@ -1,75 +0,0 @@ -#!./perl - -print "1..15\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(':',@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(':',@bar[1..5]) eq ':c:d:e:' ? "ok 3\n" : "not ok 3\n"; - -($a,@bcd[0..2],$e) = ('a','b','c','d','e'); -print join(':',$a,@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 -@a = 0x7ffffffe..0x7fffffff; -print "not " unless "@a" eq "2147483646 2147483647"; -print "ok 11\n"; - -@a = -0x7fffffff..-0x7ffffffe; -print "not " unless "@a" eq "-2147483647 -2147483646"; -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"; diff --git a/contrib/perl5/t/op/re_tests b/contrib/perl5/t/op/re_tests deleted file mode 100644 index 6477d67..0000000 --- a/contrib/perl5/t/op/re_tests +++ /dev/null @@ -1,786 +0,0 @@ -abc abc y $& abc -abc xbc n - - -abc axc n - - -abc abx n - - -abc xabcy y $& abc -abc ababc y $& abc -ab*c abc y $& abc -ab*bc abc y $& abc -ab*bc abbc y $& abbc -ab*bc abbbbc y $& abbbbc -.{1} abbbbc y $& a -.{3,4} abbbbc y $& abbb -ab{0,}bc abbbbc y $& abbbbc -ab+bc abbc y $& abbc -ab+bc abc n - - -ab+bc abq n - - -ab{1,}bc abq n - - -ab+bc abbbbc y $& abbbbc -ab{1,}bc abbbbc y $& abbbbc -ab{1,3}bc abbbbc y $& abbbbc -ab{3,4}bc abbbbc y $& abbbbc -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" before HERE mark in regex m/a[b-a << HERE ]/ -a[]b - c - Unmatched [ before HERE mark in regex m/a[ << HERE ]b/ -a[ - c - Unmatched [ before HERE mark in regex m/a[ << HERE / -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 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- -*a - c - Quantifier follows nothing before HERE mark in regex m/* << HERE a/ -(*)b - c - Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ -$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 ) before HERE mark in regex m/abc) << HERE / -(abc - c - Unmatched ( before HERE mark in regex m/( << HERE abc/ -((a)) abc y $&-$1-$2 a-a-a -(a)b(c) abc y $&-$1-$2 abc-a-c -a+b+c aabbabc y $& abc -a{1,}b{1,}c aabbabc y $& abc -a** - c - Nested quantifiers before HERE mark in regex m/a** << HERE / -a.+?c abcabc y $& abc -(a+|b)* ab y $&-$1 ab-b -(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 ) before HERE mark in regex m/) << HERE (/ -[^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 -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 $&-$1-$2 abcd-bc-d -a([bc]*)(c+d) abcd y $&-$1-$2 abcd-b-cd -a[bcd]*dcdcde adcdcde y $& adcdcde -a[bcd]+dcdcde adcdcde n - - -(ab|a)b*c abc y $&-$1 abc-ab -((a)(b)c)(d) abcd y $1-$2-$3-$4 abc-a-b-d -[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))))))))))\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 -'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" before HERE mark in regex m/a[b-a << HERE ]/ -'a[]b'i - c - Unmatched [ before HERE mark in regex m/a[ << HERE ]b/ -'a['i - c - Unmatched [ before HERE mark in regex m/a[ << HERE / -'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 before HERE mark in regex m/* << HERE a/ -'(*)b'i - c - Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ -'$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 ) before HERE mark in regex m/abc) << HERE / -'(abc'i - c - Unmatched ( before HERE mark in regex m/( << HERE abc/ -'((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 before HERE mark in regex m/a** << HERE / -'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 ) before HERE mark in regex m/) << HERE (/ -'[^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 before HERE mark in regex m/(?<% << HERE )b/ -(?:..)*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 before HERE mark in regex m/a(?{ << HERE )b/ -a(?{{})b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE {})b/ -a(?{}})b - c - -a(?{"{"})b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE "{"})b/ -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 before HERE mark in regex m/(?(1? << HERE )a|b)/ -(?(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 [ before HERE mark in regex m/[ << HERE a[:xyz:/ -[a[:xyz:] - c - POSIX class [:xyz:] unknown before HERE mark in regex m/[a[:xyz:] << HERE / -[a[:]b[:c] abc y $& abc -([a[:xyz:]b]+) pbaq c - POSIX class [:xyz:] unknown before HERE mark in regex m/([a[:xyz:] << HERE b]+)/ -[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 before HERE mark in regex m/[[:foo:] << HERE ]/ -[[:^foo:]] - c - POSIX class [:^foo:] unknown before HERE mark in regex m/[[:^foo:] << HERE ]/ -((?>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 bn - - -'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 bn - - -'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 bn - - -'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 bn - - -'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 - - diff --git a/contrib/perl5/t/op/read.t b/contrib/perl5/t/op/read.t deleted file mode 100755 index 2746970..0000000 --- a/contrib/perl5/t/op/read.t +++ /dev/null @@ -1,19 +0,0 @@ -#!./perl - -# $RCSfile: read.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:17 $ - -print "1..4\n"; - - -open(FOO,'op/read.t') || open(FOO,'t/op/read.t') || die "Can't open op.read"; -seek(FOO,4,0); -$got = read(FOO,$buf,4); - -print ($got == 4 ? "ok 1\n" : "not ok 1\n"); -print ($buf eq "perl" ? "ok 2\n" : "not ok 2 :$buf:\n"); - -seek (FOO,0,2) || seek(FOO,20000,0); -$got = read(FOO,$buf,4); - -print ($got == 0 ? "ok 3\n" : "not ok 3\n"); -print ($buf eq "" ? "ok 4\n" : "not ok 4\n"); diff --git a/contrib/perl5/t/op/readdir.t b/contrib/perl5/t/op/readdir.t deleted file mode 100755 index 00199b0..0000000 --- a/contrib/perl5/t/op/readdir.t +++ /dev/null @@ -1,40 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -eval 'opendir(NOSUCH, "no/such/directory");'; -if ($@) { print "1..0\n"; exit; } - -print "1..3\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 -## -if (@D > 90 && @D < 110) { print "ok 2\n"; } else { print "not ok 2\n"; } - -@R = sort @D; -@G = sort <op/*.t>; -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 && "op/".$R[0] eq $G[0]) { - shift(@R); - shift(@G); -} -if (@R == 0 && @G == 0) { print "ok 3\n"; } else { print "not ok 3\n"; } diff --git a/contrib/perl5/t/op/recurse.t b/contrib/perl5/t/op/recurse.t deleted file mode 100755 index dc823ed..0000000 --- a/contrib/perl5/t/op/recurse.t +++ /dev/null @@ -1,116 +0,0 @@ -#!./perl - -# -# test recursive functions. -# - -print "1..25\n"; - -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]; -} - -print 'not ' unless (($d = gcd(1147, 1271)) == 31); -print "ok 1\n"; -print "# gcd(1147, 1271) = $d\n"; - -print 'not ' unless (($d = gcd(1908, 2016)) == 36); -print "ok 2\n"; -print "# gcd(1908, 2016) = $d\n"; - -print 'not ' unless (($f = factorial(10)) == 3628800); -print "ok 3\n"; -print "# factorial(10) = $f\n"; - -print 'not ' unless (($f = factorial(factorial(3))) == 720); -print "ok 4\n"; -print "# factorial(factorial(3)) = $f\n"; - -print 'not ' unless (($f = fibonacci(10)) == 89); -print "ok 5\n"; -print "# fibonacci(10) = $f\n"; - -print 'not ' unless (($f = fibonacci(fibonacci(7))) == 17711); -print "ok 6\n"; -print "# fibonacci(fibonacci(7)) = $f\n"; - -$i = 7; - -@ack = qw(1 2 3 4 2 3 4 5 3 5 7 9 5 13 29 61); - -for $x (0..3) { - for $y (0..3) { - $a = ackermann($x, $y); - print 'not ' unless ($a == shift(@ack)); - print "ok ", $i++, "\n"; - print "# ackermann($x, $y) = $a\n"; - } -} - -($x, $y, $z) = (18, 12, 6); - -print 'not ' unless (($t = takeuchi($x, $y, $z)) == $z + 1); -print "ok ", $i++, "\n"; -print "# takeuchi($x, $y, $z) = $t\n"; - -{ - sub get_first1 { - get_list1(@_)->[0]; - } - - sub get_list1 { - return [24] unless $_[0]; - my $u = get_first1(0); - [$u]; - } - my $x = get_first1(1); - print "ok $x\n"; -} - -{ - sub get_first2 { - return get_list2(@_)->[0]; - } - - sub get_list2 { - return [25] unless $_[0]; - my $u = get_first2(0); - return [$u]; - } - my $x = get_first2(1); - print "ok $x\n"; -} - -$i = 26; diff --git a/contrib/perl5/t/op/ref.t b/contrib/perl5/t/op/ref.t deleted file mode 100755 index a2baab8..0000000 --- a/contrib/perl5/t/op/ref.t +++ /dev/null @@ -1,295 +0,0 @@ -#!./perl - -print "1..56\n"; - -# Test glob operations. - -$bar = "ok 1\n"; -$foo = "ok 2\n"; -{ - local(*foo) = *bar; - print $foo; -} -print $foo; - -$baz = "ok 3\n"; -$foo = "ok 4\n"; -{ - local(*foo) = 'baz'; - print $foo; -} -print $foo; - -$foo = "ok 6\n"; -{ - local(*foo); - print $foo; - $foo = "ok 5\n"; - print $foo; -} -print $foo; - -# Test fake references. - -$baz = "ok 7\n"; -$bar = 'baz'; -$foo = 'bar'; -print $$$foo; - -# Test real references. - -$FOO = \$BAR; -$BAR = \$BAZ; -$BAZ = "ok 8\n"; -print $$$FOO; - -# Test references to real arrays. - -@ary = (9,10,11,12); -$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]; -print @{'d'}; - -# Test references to references. - -$refref = \\$x; -$x = "ok 13\n"; -print $$$refref; - -# Test nested anonymous lists. - -$ref = [[],2,[3,4,5,]]; -print scalar @$ref == 3 ? "ok 14\n" : "not ok 14\n"; -print $$ref[1] == 2 ? "ok 15\n" : "not ok 15\n"; -print ${$$ref[2]}[2] == 5 ? "ok 16\n" : "not ok 16\n"; -print scalar @{$$ref[0]} == 0 ? "ok 17\n" : "not ok 17\n"; - -print $ref->[1] == 2 ? "ok 18\n" : "not ok 18\n"; -print $ref->[2]->[0] == 3 ? "ok 19\n" : "not ok 19\n"; - -# Test references to hashes of references. - -$refref = \%whatever; -$refref->{"key"} = $ref; -print $refref->{"key"}->[2]->[0] == 3 ? "ok 20\n" : "not ok 20\n"; - -# Test to see if anonymous subarrays spring into existence. - -$spring[5]->[0] = 123; -$spring[5]->[1] = 456; -push(@{$spring[5]}, 789); -print join(':',@{$spring[5]}) eq "123:456:789" ? "ok 21\n" : "not ok 21\n"; - -# Test to see if anonymous subhashes spring into existence. - -@{$spring2{"foo"}} = (1,2,3); -$spring2{"foo"}->[3] = 4; -print join(':',@{$spring2{"foo"}}) eq "1:2:3:4" ? "ok 22\n" : "not ok 22\n"; - -# Test references to subroutines. - -sub mysub { print "ok 23\n" } -$subref = \&mysub; -&$subref; - -$subrefref = \\&mysub2; -$$subrefref->("ok 24\n"); -sub mysub2 { print shift } - -# Test the ref operator. - -print ref $subref eq CODE ? "ok 25\n" : "not ok 25\n"; -print ref $ref eq ARRAY ? "ok 26\n" : "not ok 26\n"; -print ref $refref eq HASH ? "ok 27\n" : "not ok 27\n"; - -# Test anonymous hash syntax. - -$anonhash = {}; -print ref $anonhash eq HASH ? "ok 28\n" : "not ok 28\n"; -$anonhash2 = {FOO => BAR, ABC => XYZ,}; -print join('', sort values %$anonhash2) eq BARXYZ ? "ok 29\n" : "not ok 29\n"; - -# Test bless operator. - -package MYHASH; - -$object = bless $main'anonhash2; -print ref $object eq MYHASH ? "ok 30\n" : "not ok 30\n"; -print $object->{ABC} eq XYZ ? "ok 31\n" : "not ok 31\n"; - -$object2 = bless {}; -print ref $object2 eq MYHASH ? "ok 32\n" : "not ok 32\n"; - -# Test ordinary call on object method. - -&mymethod($object,33); - -sub mymethod { - local($THIS, @ARGS) = @_; - die 'Got a "' . ref($THIS). '" instead of a MYHASH' - unless ref $THIS eq MYHASH; - print $THIS->{FOO} eq BAR ? "ok $ARGS[0]\n" : "not ok $ARGS[0]\n"; -} - -# Test automatic destructor call. - -$string = "not ok 34\n"; -$object = "foo"; -$string = "ok 34\n"; -$main'anonhash2 = "foo"; -$string = ""; - -DESTROY { - return unless $string; - print $string; - - # Test that the object has not already been "cursed". - print ref shift ne HASH ? "ok 35\n" : "not ok 35\n"; -} - -# Now test inheritance of methods. - -package OBJ; - -@ISA = (BASEOBJ); - -$main'object = bless {FOO => foo, BAR => bar}; - -package main; - -# Test arrow-style method invocation. - -print $object->doit("BAR") eq bar ? "ok 36\n" : "not ok 36\n"; - -# Test indirect-object-style method invocation. - -$foo = doit $object "FOO"; -print $foo eq foo ? "ok 37\n" : "not ok 37\n"; - -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 { print $_[1] } - -package WHATEVER; -foo WHATEVER "ok 38\n"; - -# -# test the \(@foo) construct -# -package main; -@foo = (1,2,3); -@bar = \(@foo); -@baz = \(1,@foo,@bar); -print @bar == 3 ? "ok 39\n" : "not ok 39\n"; -print grep(ref($_), @bar) == 3 ? "ok 40\n" : "not ok 40\n"; -print @baz == 3 ? "ok 41\n" : "not ok 41\n"; - -my(@fuu) = (1,2,3); -my(@baa) = \(@fuu); -my(@bzz) = \(1,@fuu,@baa); -print @baa == 3 ? "ok 42\n" : "not ok 42\n"; -print grep(ref($_), @baa) == 3 ? "ok 43\n" : "not ok 43\n"; -print @bzz == 3 ? "ok 44\n" : "not ok 44\n"; - -# test for proper destruction of lexical objects - -sub larry::DESTROY { print "# larry\nok 45\n"; } -sub curly::DESTROY { print "# curly\nok 46\n"; } -sub moe::DESTROY { print "# moe\nok 47\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"; - -# another glob test - -$foo = "not ok 48"; -{ local(*bar) = "foo" } -$bar = "ok 48"; -local(*bar) = *bar; -print "$bar\n"; - -$var = "ok 49"; -$_ = \$var; -print $$_,"\n"; - -# test if reblessing during destruction results in more destruction - -{ - package A; - sub new { bless {}, shift } - DESTROY { print "# destroying 'A'\nok 51\n" } - package _B; - sub new { bless {}, shift } - DESTROY { print "# destroying '_B'\nok 50\n"; bless shift, 'A' } - package main; - my $b = _B->new; -} - -# test if $_[0] is properly protected in DESTROY() - -{ - my $i = 0; - local $SIG{'__DIE__'} = sub { - my $m = shift; - if ($i++ > 4) { - print "# infinite recursion, bailing\nnot ok 52\n"; - exit 1; - } - print "# $m"; - if ($m =~ /^Modification of a read-only/) { print "ok 52\n" } - }; - 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] = "ok 53\n"; - print ${\$_} for @a; -} - -# test global destruction - -package FINALE; - -{ - $ref3 = bless ["ok 56\n"]; # package destruction - my $ref2 = bless ["ok 55\n"]; # lexical destruction - local $ref1 = bless ["ok 54\n"]; # dynamic destruction - 1; # flush any temp values on stack -} - -DESTROY { - print $_[0][0]; -} diff --git a/contrib/perl5/t/op/regexp.t b/contrib/perl5/t/op/regexp.t deleted file mode 100755 index 4a4d42f..0000000 --- a/contrib/perl5/t/op/regexp.t +++ /dev/null @@ -1,112 +0,0 @@ -#!./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') || - 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//)); - # Certain tests don't work with utf8 (the re_test should be in UTF8) - $skip = 1, $reason = 'utf8' - if ($^H &= ~0x00000008) && $pat =~ /\[:\^(alnum|print|word|ascii|xdigit):\]/; - $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; -} diff --git a/contrib/perl5/t/op/regexp_noamp.t b/contrib/perl5/t/op/regexp_noamp.t deleted file mode 100755 index 03c19e9..0000000 --- a/contrib/perl5/t/op/regexp_noamp.t +++ /dev/null @@ -1,10 +0,0 @@ -#!./perl - -$skip_amp = 1; -for $file ('op/regexp.t', 't/op/regexp.t') { - if (-r $file) { - do $file; - exit; - } -} -die "Cannot find op/regexp.t or t/op/regexp.t\n"; diff --git a/contrib/perl5/t/op/regmesg.t b/contrib/perl5/t/op/regmesg.t deleted file mode 100755 index 01fa675..0000000 --- a/contrib/perl5/t/op/regmesg.t +++ /dev/null @@ -1,179 +0,0 @@ -#!./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 before {#} mark in regex m/[[=foo=]{#}]/', - - '/(?<= .*)/' => 'Variable length lookbehind not implemented before {#} mark in regex m/(?<= .*){#}/', - - '/(?<= x{1000})/' => 'Lookbehind longer than 255 not implemented before {#} mark in regex m/(?<= x{1000}){#}/', - - '/(?@)/' => 'Sequence (?@...) not implemented before {#} mark in regex m/(?@{#})/', - - '/(?{ 1/' => 'Sequence (?{...}) not terminated or not {}-balanced before {#} mark in regex m/(?{{#} 1/', - - '/(?(1x))/' => 'Switch condition not recognized before {#} mark in regex m/(?(1x{#}))/', - - '/(?(1)x|y|z)/' => 'Switch (?(condition)... contains too many branches before {#} mark in regex m/(?(1)x|y|{#}z)/', - - '/(?(x)y|x)/' => 'Unknown switch condition (?(x) before {#} mark in regex m/(?({#}x)y|x)/', - - '/(?/' => 'Sequence (? incomplete before {#} mark in regex m/(?{#}/', - - '/(?;x/' => 'Sequence (?;...) not recognized before {#} mark in regex m/(?;{#}x/', - '/(?<;x/' => 'Sequence (?<;...) not recognized before {#} mark in regex m/(?<;{#}x/', - - '/((x)/' => 'Unmatched ( before {#} mark in regex m/({#}(x)/', - - "/x{$inf_p1}/" => "Quantifier in {,} bigger than $inf_m1 before {#} mark in regex m/x{{#}$inf_p1}/", - - '/x{3,1}/' => 'Can\'t do {n,m} with n > m before {#} mark in regex m/x{3,1}{#}/', - - '/x**/' => 'Nested quantifiers before {#} mark in regex m/x**{#}/', - - '/x[/' => 'Unmatched [ before {#} mark in regex m/x[{#}/', - - '/*/', => 'Quantifier follows nothing before {#} mark in regex m/*{#}/', - - '/\p{x/' => 'Missing right brace on \p{} before {#} mark in regex m/\p{{#}x/', - - 'use utf8; /[\p{x]/' => 'Missing right brace on \p{} before {#} mark in regex m/[\p{{#}x]/', - - '/(x)\2/' => 'Reference to nonexistent group before {#} mark in regex m/(x)\2{#}/', - - 'my $m = "\\\"; $m =~ $m', => 'Trailing \ in regex m/\/', - - '/\x{1/' => 'Missing right brace on \x{} before {#} mark in regex m/\x{{#}1/', - - 'use utf8; /[\x{X]/' => 'Missing right brace on \x{} before {#} mark in regex m/[\x{{#}X]/', - - '/[[:barf:]]/' => 'POSIX class [:barf:] unknown before {#} mark in regex m/[[:barf:]{#}]/', - - '/[[=barf=]]/' => 'POSIX syntax [= =] is reserved for future extensions before {#} mark in regex m/[[=barf=]{#}]/', - - '/[[.barf.]]/' => 'POSIX syntax [. .] is reserved for future extensions before {#} mark in regex m/[[.barf.]{#}]/', - - '/[z-a]/' => 'Invalid [] range "z-a" before {#} mark in regex m/[z-a{#}]/', -); - -## -## Key-value pairs of code/error of code that should have non-fatal warnings. -## -@warning = ( - "m/(?p{ 'a' })/" => "(?p{}) is deprecated - use (??{}) before {#} mark in regex m/(?p{#}{ 'a' })/", - - 'm/\b*/' => '\b* matches null string many times before {#} mark in regex m/\b*{#}/', - - 'm/[:blank:]/' => 'POSIX syntax [: :] belongs inside character classes before {#} mark in regex m/[:blank:]{#}/', - - "m'[\\y]'" => 'Unrecognized escape \y in character class passed through before {#} mark in regex m/[\y{#}]/', - - 'm/[a-\d]/' => 'False [] range "a-\d" before {#} mark in regex m/[a-\d{#}]/', - 'm/[\w-x]/' => 'False [] range "\w-" before {#} mark in regex m/[\w-{#}x]/', - "m'\\y'" => 'Unrecognized escape \y passed through before {#} mark in regex 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 - scalar(@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/; - if ($@ !~ /^\Q$result/) { - print "# For $regex, expected:\n# $result\n# Got:\n# $@\n#\nnot "; - } - print "ok $count\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/; - if ($warning !~ /^\Q$result/) - { - print <<"EOM"; -# For $regex, expected: -# $result -# Got: -# $warning -# -not ok $count -EOM - next; - } - print "ok $count\n"; -} - - - diff --git a/contrib/perl5/t/op/repeat.t b/contrib/perl5/t/op/repeat.t deleted file mode 100755 index c030ba9..0000000 --- a/contrib/perl5/t/op/repeat.t +++ /dev/null @@ -1,98 +0,0 @@ -#!./perl - -# $RCSfile: repeat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:21 $ - -print "1..20\n"; - -# compile time - -if ('-' x 5 eq '-----') {print "ok 1\n";} else {print "not ok 1\n";} -if ('-' x 1 eq '-') {print "ok 2\n";} else {print "not ok 2\n";} -if ('-' x 0 eq '') {print "ok 3\n";} else {print "not ok 3\n";} - -if ('ab' x 3 eq 'ababab') {print "ok 4\n";} else {print "not ok 4\n";} - -# run time - -$a = '-'; -if ($a x 5 eq '-----') {print "ok 5\n";} else {print "not ok 5\n";} -if ($a x 1 eq '-') {print "ok 6\n";} else {print "not ok 6\n";} -if ($a x 0 eq '') {print "ok 7\n";} else {print "not ok 7\n";} - -$a = 'ab'; -if ($a x 3 eq 'ababab') {print "ok 8\n";} else {print "not ok 8\n";} - -$a = 'xyz'; -$a x= 2; -if ($a eq 'xyzxyz') {print "ok 9\n";} else {print "not ok 9\n";} -$a x= 1; -if ($a eq 'xyzxyz') {print "ok 10\n";} else {print "not ok 10\n";} -$a x= 0; -if ($a eq '') {print "ok 11\n";} else {print "not ok 11\n";} - -@x = (1,2,3); - -print join('', @x x 4) eq '3333' ? "ok 12\n" : "not ok 12\n"; -print join('', (@x) x 4) eq '123123123123' ? "ok 13\n" : "not ok 13\n"; -print join('', (@x,()) x 4) eq '123123123123' ? "ok 14\n" : "not ok 14\n"; -print join('', (@x,1) x 4) eq '1231123112311231' ? "ok 15\n" : "not ok 15\n"; -print join(':', () x 4) eq '' ? "ok 16\n" : "not ok 16\n"; -print join(':', (9) x 4) eq '9:9:9:9' ? "ok 17\n" : "not ok 17\n"; -print join(':', (9,9) x 4) eq '9:9:9:9:9:9:9:9' ? "ok 18\n" : "not ok 18\n"; -print join('', (split(//,"123")) x 2) eq '123123' ? "ok 19\n" : "not ok 19\n"; - -# -# The test #20 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@nsc.ijs.si while trying to install Digest-MD5-2.00. -# -# jhi@iki.fi -# -print "\xdd" x 24 eq "\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd" ? "ok 20\n" : "not ok 20\n"; diff --git a/contrib/perl5/t/op/reverse.t b/contrib/perl5/t/op/reverse.t deleted file mode 100755 index bb7b9b7..0000000 --- a/contrib/perl5/t/op/reverse.t +++ /dev/null @@ -1,33 +0,0 @@ -#!./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"; -} diff --git a/contrib/perl5/t/op/runlevel.t b/contrib/perl5/t/op/runlevel.t deleted file mode 100755 index b6c128b..0000000 --- a/contrib/perl5/t/op/runlevel.t +++ /dev/null @@ -1,366 +0,0 @@ -#!./perl - -## -## Many of these tests are originally from Michael Schroeder -## <Michael.Schroeder@informatik.uni-erlangen.de> -## Adapted and expanded by Gurusamy Sarathy <gsar@activestate.com> -## - -chdir 't' if -d 't'; -@INC = '../lib'; -$Is_VMS = $^O eq 'VMS'; -$Is_MSWin32 = $^O eq 'MSWin32'; -$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; - my $results = $Is_VMS ? - `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` : - $Is_MSWin32 ? - `.\\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"; -} - -__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. -######## -sub sortfn { - (split(/./, 'x'x10000))[0]; - my (@y) = ( 4, 6, 5); - @y = sort { $a <=> $b } @y; - print "sortfn ".join(', ', @y)."\n"; - return $_[0] <=> $_[1]; -} -@x = ( 3, 2, 1 ); -@x = sort { &sortfn($a, $b) } @x; -print "---- ".join(', ', @x)."\n"; -EXPECT -sortfn 4, 5, 6 -sortfn 4, 5, 6 -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(); -EXPECT -In DIE -main|-|8|(eval) -In DIE -main|-|9|(eval) -main|-|9|main::__ANON__ -In DIE -main|-|10|(eval) -main|-|10|main::foo -######## -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 diff --git a/contrib/perl5/t/op/sleep.t b/contrib/perl5/t/op/sleep.t deleted file mode 100755 index 5f6c4c0..0000000 --- a/contrib/perl5/t/op/sleep.t +++ /dev/null @@ -1,8 +0,0 @@ -#!./perl - -# $RCSfile: sleep.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:23 $ - -print "1..1\n"; - -$x = sleep 3; -if ($x >= 2 && $x <= 10) {print "ok 1\n";} else {print "not ok 1 $x\n";} diff --git a/contrib/perl5/t/op/sort.t b/contrib/perl5/t/op/sort.t deleted file mode 100755 index 29aff1d..0000000 --- a/contrib/perl5/t/op/sort.t +++ /dev/null @@ -1,317 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} -use warnings; -print "1..57\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; -} - -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 c) 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"; -} diff --git a/contrib/perl5/t/op/splice.t b/contrib/perl5/t/op/splice.t deleted file mode 100755 index 06e3509..0000000 --- a/contrib/perl5/t/op/splice.t +++ /dev/null @@ -1,34 +0,0 @@ -#!./perl - -print "1..9\n"; - -@a = (1..10); - -sub j { join(":",@_) } - -print "not " unless j(splice(@a,@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, 20, 0, 12, 13)) eq "" && j(@a) eq j(0..13); -print "ok 6\n"; - -print "not " unless j(splice(@a, -@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"; diff --git a/contrib/perl5/t/op/split.t b/contrib/perl5/t/op/split.t deleted file mode 100755 index 9a6586d..0000000 --- a/contrib/perl5/t/op/split.t +++ /dev/null @@ -1,129 +0,0 @@ -#!./perl - -print "1..29\n"; - -$FS = ':'; - -$_ = 'a:b:c'; - -($a,$b,$c) = split($FS,$_); - -if (join(';',$a,$b,$c) eq 'a;b;c') {print "ok 1\n";} else {print "not ok 1\n";} - -@ary = split(/:b:/); -if (join("$_",@ary) eq 'aa:b:cc') {print "ok 2\n";} else {print "not ok 2\n";} - -$_ = "abc\n"; -@xyz = (@ary = split(//)); -if (join(".",@ary) eq "a.b.c.\n") {print "ok 3\n";} else {print "not ok 3\n";} - -$_ = "a:b:c::::"; -@ary = split(/:/); -if (join(".",@ary) eq "a.b.c") {print "ok 4\n";} else {print "not ok 4\n";} - -$_ = join(':',split(' '," a b\tc \t d ")); -if ($_ eq 'a:b:c:d') {print "ok 5\n";} else {print "not ok 5 #$_#\n";} - -$_ = join(':',split(/ */,"foo bar bie\tdoll")); -if ($_ eq "f:o:o:b:a:r:b:i:e:\t:d:o:l:l") - {print "ok 6\n";} else {print "not ok 6\n";} - -$_ = join(':', 'foo', split(/ /,'a b c'), 'bar'); -if ($_ eq "foo:a:b::c:bar") {print "ok 7\n";} else {print "not ok 7 $_\n";} - -# Can we say how many fields to split to? -$_ = join(':', split(' ','1 2 3 4 5 6', 3)); -print $_ eq '1:2:3 4 5 6' ? "ok 8\n" : "not ok 8 $_\n"; - -# Can we do it as a variable? -$x = 4; -$_ = join(':', split(' ','1 2 3 4 5 6', $x)); -print $_ eq '1:2:3:4 5 6' ? "ok 9\n" : "not ok 9 $_\n"; - -# Does the 999 suppress null field chopping? -$_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999)); -print $_ eq '1:2:3:4:5:6:::' ? "ok 10\n" : "not ok 10 $_\n"; - -# Does assignment to a list imply split to one more field than that? -if ($^O eq 'MSWin32') { $foo = `.\\perl -D1024 -e "(\$a,\$b) = split;" 2>&1` } -elsif ($^O eq 'VMS') { $foo = `./perl "-D1024" -e "(\$a,\$b) = split;" 2>&1` } -else { $foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1` } -print $foo =~ /DEBUGGING/ || $foo =~ /SV = (VOID|IV\(3\))/ ? "ok 11\n" : "not ok 11\n"; - -# 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); -print $_ eq '1:2 3 4 5 6' ? "ok 12\n" : "not ok 12 $_\n"; - -# do subpatterns generate additional fields (without trailing nulls)? -$_ = join '|', split(/,|(-)/, "1-10,20,,,"); -print $_ eq "1|-|10||20" ? "ok 13\n" : "not ok 13\n"; - -# do subpatterns generate additional fields (with a limit)? -$_ = join '|', split(/,|(-)/, "1-10,20,,,", 10); -print $_ eq "1|-|10||20||||||" ? "ok 14\n" : "not ok 14\n"; - -# is the 'two undefs' bug fixed? -(undef, $a, undef, $b) = qw(1 2 3 4); -print "$a|$b" eq "2|4" ? "ok 15\n" : "not ok 15\n"; - -# .. even for locals? -{ - local(undef, $a, undef, $b) = qw(1 2 3 4); - print "$a|$b" eq "2|4" ? "ok 16\n" : "not ok 16\n"; -} - -# check splitting of null string -$_ = join('|', split(/x/, '',-1), 'Z'); -print $_ eq "Z" ? "ok 17\n" : "#$_\nnot ok 17\n"; - -$_ = join('|', split(/x/, '', 1), 'Z'); -print $_ eq "Z" ? "ok 18\n" : "#$_\nnot ok 18\n"; - -$_ = join('|', split(/(p+)/,'',-1), 'Z'); -print $_ eq "Z" ? "ok 19\n" : "#$_\nnot ok 19\n"; - -$_ = join('|', split(/.?/, '',-1), 'Z'); -print $_ eq "Z" ? "ok 20\n" : "#$_\nnot ok 20\n"; - - -# Are /^/m patterns scanned? -$_ = join '|', split(/^a/m, "a b a\na d a", 20); -print $_ eq "| b a\n| d a" ? "ok 21\n" : "not ok 21\n# `$_'\n"; - -# Are /$/m patterns scanned? -$_ = join '|', split(/a$/m, "a b a\na d a", 20); -print $_ eq "a b |\na d |" ? "ok 22\n" : "not ok 22\n# `$_'\n"; - -# Are /^/m patterns scanned? -$_ = join '|', split(/^aa/m, "aa b aa\naa d aa", 20); -print $_ eq "| b aa\n| d aa" ? "ok 23\n" : "not ok 23\n# `$_'\n"; - -# Are /$/m patterns scanned? -$_ = join '|', split(/aa$/m, "aa b aa\naa d aa", 20); -print $_ eq "aa b |\naa d |" ? "ok 24\n" : "not ok 24\n# `$_'\n"; - -# Greedyness: -$_ = "a : b :c: d"; -@ary = split(/\s*:\s*/); -if (($res = join(".",@ary)) eq "a.b.c.d") {print "ok 25\n";} else {print "not ok 25\n# res=`$res' != `a.b.c.d'\n";} - -# use of match result as pattern (!) -'p:q:r:s' eq join ':', split('abc' =~ /b/, 'p1q1r1s') or print "not "; -print "ok 26\n"; - -# /^/ treated as /^/m -$_ = join ':', split /^/, "ab\ncd\nef\n"; -print "not " if $_ ne "ab\n:cd\n:ef\n"; -print "ok 27\n"; - -# see if @a = @b = split(...) optimization works -@list1 = @list2 = split ('p',"a p b c p"); -print "not " if @list1 != @list2 or "@list1" ne "@list2" - or @list1 != 2 or "@list1" ne "a b c "; -print "ok 28\n"; - -# zero-width assertion -$_ = join ':', split /(?=\w)/, "rm b"; -print "not" if $_ ne "r:m :b"; -print "ok 29\n"; diff --git a/contrib/perl5/t/op/sprintf.t b/contrib/perl5/t/op/sprintf.t deleted file mode 100755 index f4af3cd..0000000 --- a/contrib/perl5/t/op/sprintf.t +++ /dev/null @@ -1,310 +0,0 @@ -#!./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 use utf8 and such). - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} -use warnings; - -while (<DATA>) { - s/^\s*>//; s/<\s*$//; - push @tests, [split(/<\s*>/, $_, 4)]; -} - -print '1..', scalar @tests, "\n"; - -$SIG{__WARN__} = sub { - if ($_[0] =~ /^Invalid conversion/) { - $w = ' INVALID' - } else { - warn @_; - } -}; - -for ($i = 1; @tests; $i++) { - ($template, $data, $result, $comment) = @{shift @tests}; - $evalData = eval $data; - $w = undef; - $x = sprintf(">$template<", - defined @$evalData ? @$evalData : $evalData); - 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/^>/> /; - } - } - - if ($x eq ">$result<") { - print "ok $i\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 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. -# -# The following tests are not currently run, for the reasons stated: - -=pod - -=begin problematic - ->%.0f< >-0.1< >-0< >C library bug: no minus on VMS, HP-UX< ->%.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< ->%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< >Synonum for %lo< ->%P< >''< >%P INVALID< ->%Q< >''< >%Q INVALID< ->%R< >''< >%R INVALID< ->%S< >''< >%S INVALID< ->%T< >''< >%T INVALID< ->%U< >2**32-1< >4294967295< >Synonum 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< ->%v03d< >"\01\02\03"< >001.002.003< ->%v-3d< >"\01\02\03"< >1 .2 .3 < ->%v+-3d< >"\01\02\03"< >+1 .2 .3 < ->%v4.3d< >"\01\02\03"< > 001. 002. 003< ->%v04.3d< >"\01\02\03"< >0001.0002.0003< ->%*v02d< >['-', "\0\7\14"]< >00-07-12< ->%v.*d< >[3, "\01\02\03"]< >001.002.003< ->%v0*d< >[3, "\01\02\03"]< >001.002.003< ->%v-*d< >[3, "\01\02\03"]< >1 .2 .3 < ->%v+-*d< >[3, "\01\02\03"]< >+1 .2 .3 < ->%v*.*d< >[4, 3, "\01\02\03"]< > 001. 002. 003< ->%v0*.*d< >[4, 3, "\01\02\03"]< >0001.0002.0003< ->%*v0*d< >['-', 2, "\0\7\13"]< >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< ->%.*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< ->%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< >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 and (irix|nonstop-ux|powerux)< ->%.0f< >-0.6< >-1< >Known to fail with sfio and (irix|nonstop-ux|powerux)< ->%.0f< >1< >1< ->%#.0f< >1< >1.< ->%g< >12345.6789< >12345.7< ->%+g< >12345.6789< >+12345.7< ->%#g< >12345.6789< >12345.7< ->%.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 < ->%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< ->%d< >$p=sprintf('%p',$p);$p=~/^[0-9a-f]+$/< >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< diff --git a/contrib/perl5/t/op/stat.t b/contrib/perl5/t/op/stat.t deleted file mode 100755 index 1d8c7a3..0000000 --- a/contrib/perl5/t/op/stat.t +++ /dev/null @@ -1,287 +0,0 @@ -#!./perl - -# $RCSfile: stat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:28 $ - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -use Config; - -print "1..58\n"; - -$Is_MSWin32 = $^O eq 'MSWin32'; -$Is_Dos = $^O eq 'dos'; -$Is_Dosish = $Is_Dos || $^O eq 'os2' || $Is_MSWin32; -$Is_Cygwin = $^O eq 'cygwin'; -chop($cwd = ($Is_MSWin32 ? `cd` : `pwd`)); - -$DEV = `ls -l /dev` unless $Is_Dosish or $Is_Cygwin; - -unlink "Op.stat.tmp"; -if (open(FOO, ">Op.stat.tmp")) { - # hack to make Apollo update link count: - $junk = `ls Op.stat.tmp` unless ($Is_MSWin32 || $Is_Dos); - - ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat(FOO); - if ($nlink == 1) { - print "ok 1\n"; - } - else { - print "# res=$res, nlink=$nlink.\nnot ok 1\n"; - } - if ($Is_MSWin32 or $Is_Cygwin or $Is_Dos || ($mtime && $mtime == $ctime)) { - print "ok 2\n"; - } - else { - print "# |$mtime| vs |$ctime|\nnot ok 2\n"; - } - - 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 unless $funky_FAT_timestamps; - -} else { - print "# open failed: $!\nnot ok 1\nnot ok 2\n"; -} - -if ($Is_Dosish) { unlink "Op.stat.tmp2"} -else { - `rm -f Op.stat.tmp2;ln Op.stat.tmp Op.stat.tmp2; chmod 644 Op.stat.tmp`; -} - -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat('Op.stat.tmp'); - -if ($Is_Dosish || $Config{dont_use_nlink}) - {print "ok 3 # skipped: no link count\n";} -elsif ($nlink == 2) - {print "ok 3\n";} -else {print "# \$nlink is |$nlink|\nnot ok 3\n";} - -if ( $Is_Dosish - # Solaris tmpfs bug - || ($cwd =~ m#^/tmp# and $mtime && $mtime==$ctime && $^O eq 'solaris') - || $cwd =~ m#/afs/# - || $^O eq 'amigaos') { - print "ok 4 # skipped: different semantic of mtime/ctime\n"; -} -elsif ( ($mtime && $mtime != $ctime) ) { - print "ok 4\n"; -} -else { - print "not ok 4\n"; - print "#4 If test op/stat.t fails test 4, check if you are on a tmpfs\n"; - print "#4 of some sort. Building in /tmp sometimes has this problem.\n"; - print "#4 Also building on the ClearCase VOBS filesystem may cause this failure.\n"; -} -print "#4 :$mtime: should != :$ctime:\n"; - -unlink "Op.stat.tmp" or print "# unlink failed: $!\n"; -if ($Is_MSWin32) { open F, '>Op.stat.tmp' and close F } -else { `touch Op.stat.tmp` } - -if (-z 'Op.stat.tmp') {print "ok 5\n";} else {print "not ok 5\n";} -if (! -s 'Op.stat.tmp') {print "ok 6\n";} else {print "not ok 6\n";} - -$Is_MSWin32 ? `cmd /c echo hi > Op.stat.tmp` : `echo hi >Op.stat.tmp`; -if (! -z 'Op.stat.tmp') {print "ok 7\n";} else {print "not ok 7\n";} -if (-s 'Op.stat.tmp') {print "ok 8\n";} else {print "not ok 8\n";} - -unlink 'Op.stat.tmp' or print "# unlink failed: $!\n"; -$olduid = $>; # can't test -r if uid == 0 -$Is_MSWin32 ? `cmd /c echo hi > Op.stat.tmp` : `echo hi >Op.stat.tmp`; -chmod 0,'Op.stat.tmp'; -eval '$> = 1;'; # so switch uid (may not be implemented) -if (!$> || $Is_Dos || ! -r 'Op.stat.tmp') {print "ok 9\n";} else {print "not ok 9\n";} -if (!$> || ! -w 'Op.stat.tmp') {print "ok 10\n";} else {print "not ok 10\n";} -eval '$> = $olduid;'; # switch uid back (may not be implemented) -print "# olduid=$olduid, newuid=$>\n" unless ($> == $olduid); - -if (! -x 'Op.stat.tmp') {print "ok 11\n";} -else {print "not ok 11\n";} - -foreach ((12,13,14,15,16,17)) { - print "ok $_\n"; #deleted tests -} - -# in ms windows, Op.stat.tmp inherits owner uid from directory -# not sure about os/2, but chown is harmless anyway -eval { chown $>,'Op.stat.tmp'; 1 } or print "# $@" ; -chmod 0700,'Op.stat.tmp'; -if (-r 'Op.stat.tmp') {print "ok 18\n";} else {print "not ok 18\n";} -if (-w 'Op.stat.tmp') {print "ok 19\n";} else {print "not ok 19\n";} -if ($Is_Dosish) {print "ok 20 # skipped: -x by extension\n";} -elsif (-x 'Op.stat.tmp') {print "ok 20\n";} -else {print "not ok 20\n";} - -if (-f 'Op.stat.tmp') {print "ok 21\n";} else {print "not ok 21\n";} -if (! -d 'Op.stat.tmp') {print "ok 22\n";} else {print "not ok 22\n";} - -if (-d '.') {print "ok 23\n";} else {print "not ok 23\n";} -if (! -f '.') {print "ok 24\n";} else {print "not ok 24\n";} - -if (!$Is_Dosish and `ls -l perl` =~ /^l.*->/) { - if (-l 'perl') {print "ok 25\n";} else {print "not ok 25\n";} -} -else { - print "ok 25\n"; -} - -if (-o 'Op.stat.tmp') {print "ok 26\n";} else {print "not ok 26\n";} - -if (-e 'Op.stat.tmp') {print "ok 27\n";} else {print "not ok 27\n";} -unlink 'Op.stat.tmp2'; -if (! -e 'Op.stat.tmp2') {print "ok 28\n";} else {print "not ok 28\n";} - -if ($Is_MSWin32 || $Is_Dos) - {print "ok 29\n";} -elsif ($DEV !~ /\nc.* (\S+)\n/) - {print "ok 29\n";} -elsif (-c "/dev/$1") - {print "ok 29\n";} -else - {print "not ok 29\n";} -if (! -c '.') {print "ok 30\n";} else {print "not ok 30\n";} - -if ($Is_MSWin32 || $Is_Dos) - {print "ok 31\n";} -elsif ($DEV !~ /\ns.* (\S+)\n/) - {print "ok 31\n";} -elsif (-S "/dev/$1") - {print "ok 31\n";} -else - {print "not ok 31\n";} -if (! -S '.') {print "ok 32\n";} else {print "not ok 32\n";} - -if ($Is_MSWin32 || $Is_Dos) - {print "ok 33\n";} -elsif ($DEV !~ /\nb.* (\S+)\n/) - {print "ok 33\n";} -elsif (-b "/dev/$1") - {print "ok 33\n";} -else - {print "not ok 33\n";} -if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";} - -if ($^O eq 'mpeix' or $^O eq 'amigaos' or $Is_Dosish or $Is_Cygwin) { - print "ok 35 # skipped: no -u\n"; goto tty_test; -} - -$cnt = $uid = 0; - -die "Can't run op/stat.t test 35 without pwd working" unless $cwd; -my @bin = grep {-d} ($^O eq 'machten' ? - qw(/usr/bin /bin) : - qw(/sbin /usr/sbin /bin /usr/bin)); -unless (@bin) { print ("not ok 35\n"), goto tty_test; } -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; - -# I suppose this is going to fail somewhere... -if ($uid > 0 && $uid < $cnt) - {print "ok 35\n";} -else - {print "not ok 35 \n# ($uid $cnt)\n";} - -tty_test: - -# 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. -unless($ENV{PERL_SKIP_TTY_TEST}) { - if ($Is_MSWin32) { - print "ok 36\n"; - print "ok 37\n"; - } - else { - my $TTY = "/dev/tty"; - - $TTY = "/dev/ttyp0" if $^O eq 'rhapsody'; - - if (defined $TTY) { - unless (open(TTY, $TTY)) { - print STDERR "Can't open $TTY--run t/TEST outside of make.\n"; - } - if (-t TTY) {print "ok 36\n";} else {print "not ok 36\n";} - if (-c TTY) {print "ok 37\n";} else {print "not ok 37\n";} - close(TTY); - } else { # if some platform completely undefines $TTY - print "ok 36 # skipped\n"; - print "ok 37 # skipped\n"; - } - } - if (! -t TTY) {print "ok 38\n";} else {print "not ok 38\n";} - if (-t) {print "ok 39\n";} else {print "not ok 39\n";} -} -else { - print "ok 36\n"; - print "ok 37\n"; - print "ok 38\n"; - print "ok 39\n"; -} -open(null,"/dev/null"); -if (! -t null || -e '/xenix' || $^O eq 'machten' || $Is_MSWin32) - {print "ok 40\n";} else {print "not ok 40\n";} -close(null); - -# These aren't strictly "stat" calls, but so what? - -if (-T 'op/stat.t') {print "ok 41\n";} else {print "not ok 41\n";} -if (! -B 'op/stat.t') {print "ok 42\n";} else {print "not ok 42\n";} - -if (-B './perl' || -B './perl.exe') {print "ok 43\n";} else {print "not ok 43\n";} -if (! -T './perl' && ! -T './perl.exe') {print "ok 44\n";} else {print "not ok 44\n";} - -open(FOO,'op/stat.t'); -eval { -T FOO; }; -if ($@ =~ /not implemented/) { - print "# $@"; - for (45 .. 54) { - print "ok $_\n"; - } -} -else { - if (-T FOO) {print "ok 45\n";} else {print "not ok 45\n";} - if (! -B FOO) {print "ok 46\n";} else {print "not ok 46\n";} - $_ = <FOO>; - if (/perl/) {print "ok 47\n";} else {print "not ok 47\n";} - if (-T FOO) {print "ok 48\n";} else {print "not ok 48\n";} - if (! -B FOO) {print "ok 49\n";} else {print "not ok 49\n";} - close(FOO); - - open(FOO,'op/stat.t'); - $_ = <FOO>; - if (/perl/) {print "ok 50\n";} else {print "not ok 50\n";} - if (-T FOO) {print "ok 51\n";} else {print "not ok 51\n";} - if (! -B FOO) {print "ok 52\n";} else {print "not ok 52\n";} - seek(FOO,0,0); - if (-T FOO) {print "ok 53\n";} else {print "not ok 53\n";} - if (! -B FOO) {print "ok 54\n";} else {print "not ok 54\n";} -} -close(FOO); - -if (-T '/dev/null') {print "ok 55\n";} else {print "not ok 55\n";} -if (-B '/dev/null') {print "ok 56\n";} else {print "not ok 56\n";} - -# and now, a few parsing tests: -$_ = 'Op.stat.tmp'; -if (-f) {print "ok 57\n";} else {print "not ok 57\n";} -if (-f()) {print "ok 58\n";} else {print "not ok 58\n";} - -unlink 'Op.stat.tmp' or print "# unlink failed: $!\n"; diff --git a/contrib/perl5/t/op/study.t b/contrib/perl5/t/op/study.t deleted file mode 100755 index ea3b366..0000000 --- a/contrib/perl5/t/op/study.t +++ /dev/null @@ -1,69 +0,0 @@ -#!./perl - -# $RCSfile: study.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:30 $ - -print "1..24\n"; - -$x = "abc\ndef\n"; -study($x); - -if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";} -if ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";} - -$* = 1; -if ($x =~ /^def/) {print "ok 3\n";} else {print "not ok 3\n";} -$* = 0; - -$_ = '123'; -study; -if (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";} - -if ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";} -if ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";} - -if ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";} -if ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";} - -study($x); -if ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";} -if ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";} - -if ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";} -if ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";} - -$_ = 'aaabbbccc'; -study; -if (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') { - print "ok 13\n"; -} else { - print "not ok 13\n"; -} -if (/(a+b+c+)/ && $1 eq 'aaabbbccc') { - print "ok 14\n"; -} else { - print "not ok 14\n"; -} - -if (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";} - -$_ = 'aaabccc'; -study; -if (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";} -if (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";} - -$_ = 'aaaccc'; -study; -if (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";} -if (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";} - -$_ = 'abcdef'; -study; -if (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";} -if (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";} - -if (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";} - -if (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";} - -$* = 1; # test 3 only tested the optimized version--this one is for real -if ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";} diff --git a/contrib/perl5/t/op/subst.t b/contrib/perl5/t/op/subst.t deleted file mode 100755 index 7dd7a1c..0000000 --- a/contrib/perl5/t/op/subst.t +++ /dev/null @@ -1,381 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; -} - -print "1..84\n"; - -$x = 'foo'; -$_ = "x"; -s/x/\$x/; -print "#1\t:$_: eq :\$x:\n"; -if ($_ eq '$x') {print "ok 1\n";} else {print "not ok 1\n";} - -$_ = "x"; -s/x/$x/; -print "#2\t:$_: eq :foo:\n"; -if ($_ eq 'foo') {print "ok 2\n";} else {print "not ok 2\n";} - -$_ = "x"; -s/x/\$x $x/; -print "#3\t:$_: eq :\$x foo:\n"; -if ($_ eq '$x foo') {print "ok 3\n";} else {print "not ok 3\n";} - -$b = 'cd'; -($a = 'abcdef') =~ s<(b${b}e)>'\n$1'; -print "#4\t:$1: eq :bcde:\n"; -print "#4\t:$a: eq :a\\n\$1f:\n"; -if ($1 eq 'bcde' && $a eq 'a\n$1f') {print "ok 4\n";} else {print "not ok 4\n";} - -$a = 'abacada'; -if (($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx') - {print "ok 5\n";} else {print "not ok 5\n";} - -if (($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx') - {print "ok 6\n";} else {print "not ok 6 $a\n";} - -if (($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx') - {print "ok 7\n";} else {print "not ok 7 $a\n";} - -$_ = 'ABACADA'; -if (/a/i && s///gi && $_ eq 'BCD') {print "ok 8\n";} else {print "not ok 8 $_\n";} - -$_ = '\\' x 4; -if (length($_) == 4) {print "ok 9\n";} else {print "not ok 9\n";} -s/\\/\\\\/g; -if ($_ eq '\\' x 8) {print "ok 10\n";} else {print "not ok 10 $_\n";} - -$_ = '\/' x 4; -if (length($_) == 8) {print "ok 11\n";} else {print "not ok 11\n";} -s/\//\/\//g; -if ($_ eq '\\//' x 4) {print "ok 12\n";} else {print "not ok 12\n";} -if (length($_) == 12) {print "ok 13\n";} else {print "not ok 13\n";} - -$_ = 'aaaXXXXbbb'; -s/^a//; -print $_ eq 'aaXXXXbbb' ? "ok 14\n" : "not ok 14\n"; - -$_ = 'aaaXXXXbbb'; -s/a//; -print $_ eq 'aaXXXXbbb' ? "ok 15\n" : "not ok 15\n"; - -$_ = 'aaaXXXXbbb'; -s/^a/b/; -print $_ eq 'baaXXXXbbb' ? "ok 16\n" : "not ok 16\n"; - -$_ = 'aaaXXXXbbb'; -s/a/b/; -print $_ eq 'baaXXXXbbb' ? "ok 17\n" : "not ok 17\n"; - -$_ = 'aaaXXXXbbb'; -s/aa//; -print $_ eq 'aXXXXbbb' ? "ok 18\n" : "not ok 18\n"; - -$_ = 'aaaXXXXbbb'; -s/aa/b/; -print $_ eq 'baXXXXbbb' ? "ok 19\n" : "not ok 19\n"; - -$_ = 'aaaXXXXbbb'; -s/b$//; -print $_ eq 'aaaXXXXbb' ? "ok 20\n" : "not ok 20\n"; - -$_ = 'aaaXXXXbbb'; -s/b//; -print $_ eq 'aaaXXXXbb' ? "ok 21\n" : "not ok 21\n"; - -$_ = 'aaaXXXXbbb'; -s/bb//; -print $_ eq 'aaaXXXXb' ? "ok 22\n" : "not ok 22\n"; - -$_ = 'aaaXXXXbbb'; -s/aX/y/; -print $_ eq 'aayXXXbbb' ? "ok 23\n" : "not ok 23\n"; - -$_ = 'aaaXXXXbbb'; -s/Xb/z/; -print $_ eq 'aaaXXXzbb' ? "ok 24\n" : "not ok 24\n"; - -$_ = 'aaaXXXXbbb'; -s/aaX.*Xbb//; -print $_ eq 'ab' ? "ok 25\n" : "not ok 25\n"; - -$_ = 'aaaXXXXbbb'; -s/bb/x/; -print $_ eq 'aaaXXXXxb' ? "ok 26\n" : "not ok 26\n"; - -# now for some unoptimized versions of the same. - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/^a//; -print $_ eq 'aaXXXXbbb' ? "ok 27\n" : "not ok 27\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/a//; -print $_ eq 'aaXXXXbbb' ? "ok 28\n" : "not ok 28\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/^a/b/; -print $_ eq 'baaXXXXbbb' ? "ok 29\n" : "not ok 29\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/a/b/; -print $_ eq 'baaXXXXbbb' ? "ok 30\n" : "not ok 30\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/aa//; -print $_ eq 'aXXXXbbb' ? "ok 31\n" : "not ok 31\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/aa/b/; -print $_ eq 'baXXXXbbb' ? "ok 32\n" : "not ok 32\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/b$//; -print $_ eq 'aaaXXXXbb' ? "ok 33\n" : "not ok 33\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/b//; -print $_ eq 'aaaXXXXbb' ? "ok 34\n" : "not ok 34\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/bb//; -print $_ eq 'aaaXXXXb' ? "ok 35\n" : "not ok 35\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/aX/y/; -print $_ eq 'aayXXXbbb' ? "ok 36\n" : "not ok 36\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/Xb/z/; -print $_ eq 'aaaXXXzbb' ? "ok 37\n" : "not ok 37\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/aaX.*Xbb//; -print $_ eq 'ab' ? "ok 38\n" : "not ok 38\n"; - -$_ = 'aaaXXXXbbb'; -$x ne $x || s/bb/x/; -print $_ eq 'aaaXXXXxb' ? "ok 39\n" : "not ok 39\n"; - -$_ = 'abc123xyz'; -s/(\d+)/$1*2/e; # yields 'abc246xyz' -print $_ eq 'abc246xyz' ? "ok 40\n" : "not ok 40\n"; -s/(\d+)/sprintf("%5d",$1)/e; # yields 'abc 246xyz' -print $_ eq 'abc 246xyz' ? "ok 41\n" : "not ok 41\n"; -s/(\w)/$1 x 2/eg; # yields 'aabbcc 224466xxyyzz' -print $_ eq 'aabbcc 224466xxyyzz' ? "ok 42\n" : "not ok 42\n"; - -$_ = "aaaaa"; -print y/a/b/ == 5 ? "ok 43\n" : "not ok 43\n"; -print y/a/b/ == 0 ? "ok 44\n" : "not ok 44\n"; -print y/b// == 5 ? "ok 45\n" : "not ok 45\n"; -print y/b/c/s == 5 ? "ok 46\n" : "not ok 46\n"; -print y/c// == 1 ? "ok 47\n" : "not ok 47\n"; -print y/c//d == 1 ? "ok 48\n" : "not ok 48\n"; -print $_ eq "" ? "ok 49\n" : "not ok 49\n"; - -$_ = "Now is the %#*! time for all good men..."; -print (($x=(y/a-zA-Z //cd)) == 7 ? "ok 50\n" : "not ok 50\n"); -print y/ / /s == 8 ? "ok 51\n" : "not ok 51\n"; - -$_ = 'abcdefghijklmnopqrstuvwxyz0123456789'; -tr/a-z/A-Z/; - -print $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ? "ok 52\n" : "not ok 52\n"; - -# same as tr/A-Z/a-z/; -if ($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]; -} - -print $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' ? "ok 53\n" : "not ok 53\n"; - -if (ord("+") == ord(",") - 1 && ord(",") == ord("-") - 1 && - ord("a") == ord("b") - 1 && ord("b") == ord("c") - 1) { - $_ = '+,-'; - tr/+--/a-c/; - print "not " unless $_ eq 'abc'; -} -print "ok 54\n"; - -$_ = '+,-'; -tr/+\--/a\/c/; -print $_ eq 'a,/' ? "ok 55\n" : "not ok 55\n"; - -$_ = '+,-'; -tr/-+,/ab\-/; -print $_ eq 'b-a' ? "ok 56\n" : "not ok 56\n"; - - -# 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; -} - -print exp_vars('$(AAAAA)',0) eq 'D' - ? "ok 57\n" : "not ok 57\n"; -print exp_vars('$(E)',0) eq 'p HHHHH q' - ? "ok 58\n" : "not ok 58\n"; -print exp_vars('$(DIR)',0) eq '$(UNDEFINEDNAME)/xxx' - ? "ok 59\n" : "not ok 59\n"; -print exp_vars('foo $(DIR)/yyy bar',0) eq 'foo $(UNDEFINEDNAME)/xxx/yyy bar' - ? "ok 60\n" : "not ok 60\n"; - -# a match nested in the RHS of a substitution: - -$_ = "abcd"; -s/(..)/$x = $1, m#.#/eg; -print $x eq "cd" ? "ok 61\n" : "not ok 61\n"; - -# Subst and lookbehind - -$_="ccccc"; -s/(?<!x)c/x/g; -print $_ eq "xxxxx" ? "ok 62\n" : "not ok 62 # `$_' ne `xxxxx'\n"; - -$_="ccccc"; -s/(?<!x)(c)/x/g; -print $_ eq "xxxxx" ? "ok 63\n" : "not ok 63 # `$_' ne `xxxxx'\n"; - -$_="foobbarfoobbar"; -s/(?<!r)foobbar/foobar/g; -print $_ eq "foobarfoobbar" ? "ok 64\n" : "not ok 64 # `$_' ne `foobarfoobbar'\n"; - -$_="foobbarfoobbar"; -s/(?<!ar)(foobbar)/foobar/g; -print $_ eq "foobarfoobbar" ? "ok 65\n" : "not ok 65 # `$_' ne `foobarfoobbar'\n"; - -$_="foobbarfoobbar"; -s/(?<!ar)foobbar/foobar/g; -print $_ eq "foobarfoobbar" ? "ok 66\n" : "not ok 66 # `$_' ne `foobarfoobbar'\n"; - -# check parsing of split subst with comment -eval 's{foo} # this is a comment, not a delimiter - {bar};'; -print @? ? "not ok 67\n" : "ok 67\n"; - -# check if squashing works at the end of string -$_="baacbaa"; -tr/a/b/s; -print $_ eq "bbcbb" ? "ok 68\n" : "not ok 68 # `$_' ne `bbcbb'\n"; - -# XXX TODO: Most tests above don't test return values of the ops. They should. -$_ = "ab"; -print (s/a/b/ == 1 ? "ok 69\n" : "not ok 69\n"); - -$_ = <<'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$@%# '; - -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; -print ($_ eq $foo ? "ok 70\n" : "not ok 70\n#'$_'\n#'$foo'\n"); - -$_ = 'x' x 20; -s/(\d*|x)/<$1>/g; -$foo = '<>' . ('<x><>' x 20) ; -print ($_ eq $foo ? "ok 71\n" : "not ok 71\n#'$_'\n#'$foo'\n"); - -$t = 'aaaaaaaaa'; - -$_ = $t; -pos = 6; -s/\Ga/xx/g; -print "not " unless $_ eq 'aaaaaaxxxxxx'; -print "ok 72\n"; - -$_ = $t; -pos = 6; -s/\Ga/x/g; -print "not " unless $_ eq 'aaaaaaxxx'; -print "ok 73\n"; - -$_ = $t; -pos = 6; -s/\Ga/xx/; -print "not " unless $_ eq 'aaaaaaxxaa'; -print "ok 74\n"; - -$_ = $t; -pos = 6; -s/\Ga/x/; -print "not " unless $_ eq 'aaaaaaxaa'; -print "ok 75\n"; - -$_ = $t; -s/\Ga/xx/g; -print "not " unless $_ eq 'xxxxxxxxxxxxxxxxxx'; -print "ok 76\n"; - -$_ = $t; -s/\Ga/x/g; -print "not " unless $_ eq 'xxxxxxxxx'; -print "ok 77\n"; - -$_ = $t; -s/\Ga/xx/; -print "not " unless $_ eq 'xxaaaaaaaa'; -print "ok 78\n"; - -$_ = $t; -s/\Ga/x/; -print "not " unless $_ eq 'xaaaaaaaa'; -print "ok 79\n"; - -$_ = 'aaaa'; -s/\ba/./g; -print "#'$_'\nnot " unless $_ eq '.aaa'; -print "ok 80\n"; - -eval q% s/a/"b"}/e %; -print ($@ =~ /Bad evalled substitution/ ? "ok 81\n" : "not ok 81\n"); -eval q% ($_ = "x") =~ s/(.)/"$1 "/e %; -print +($_ eq "x " and !length $@) ? "ok 82\n" : "not ok 82\n# \$_ eq $_, $@\n"; -$x = $x = 'interp'; -eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %; -print +($_ eq '' and !length $@) ? "ok 83\n" : "not ok 83\n# \$_ eq $_, $@\n"; - -$_ = "C:/"; -s/^([a-z]:)/\u$1/ and print "not "; -print "ok 84\n"; - diff --git a/contrib/perl5/t/op/subst_amp.t b/contrib/perl5/t/op/subst_amp.t deleted file mode 100755 index 7189572..0000000 --- a/contrib/perl5/t/op/subst_amp.t +++ /dev/null @@ -1,104 +0,0 @@ -#!./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"; - diff --git a/contrib/perl5/t/op/subst_wamp.t b/contrib/perl5/t/op/subst_wamp.t deleted file mode 100755 index b716b30..0000000 --- a/contrib/perl5/t/op/subst_wamp.t +++ /dev/null @@ -1,11 +0,0 @@ -#!./perl - -$dummy = defined $&; # Now we have it... -for $file ('op/subst.t', 't/op/subst.t') { - if (-r $file) { - do $file; - exit; - } -} -die "Cannot find op/subst.t or t/op/subst.t\n"; - diff --git a/contrib/perl5/t/op/substr.t b/contrib/perl5/t/op/substr.t deleted file mode 100755 index 85574d5..0000000 --- a/contrib/perl5/t/op/substr.t +++ /dev/null @@ -1,587 +0,0 @@ -#!./perl - -print "1..174\n"; - -#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]; - } -}; - -sub ok { print (($_[1] ? "" : "not ") . "ok $_[0]\n") } - -$FATAL_MSG = '^substr outside of string' ; - -ok 1, substr($a,0,3) eq 'abc'; # P=Q R S -ok 2, substr($a,3,3) eq 'def'; # P Q R S -ok 3, substr($a,6,999) eq 'xyz'; # P Q S R -$b = substr($a,999,999) ; # warn # P R Q S -ok 4, $w-- == 1 ; -eval{substr($a,999,999) = "" ; };# P R Q S -ok 5, $@ =~ /$FATAL_MSG/; -ok 6, substr($a,0,-6) eq 'abc'; # P=Q R S -ok 7, substr($a,-3,1) eq 'x'; # P Q R S - -$[ = 1; - -ok 8, substr($a,1,3) eq 'abc' ; # P=Q R S -ok 9, substr($a,4,3) eq 'def' ; # P Q R S -ok 10, substr($a,7,999) eq 'xyz';# P Q S R -$b = substr($a,999,999) ; # warn # P R Q S -ok 11, $w-- == 1 ; -eval{substr($a,999,999) = "" ; } ; # P R Q S -ok 12, $@ =~ /$FATAL_MSG/; -ok 13, substr($a,1,-6) eq 'abc' ;# P=Q R S -ok 14, substr($a,-3,1) eq 'x' ; # P Q R S - -$[ = 0; - -substr($a,3,3) = 'XYZ'; -ok 15, $a eq 'abcXYZxyz' ; -substr($a,0,2) = ''; -ok 16, $a eq 'cXYZxyz' ; -substr($a,0,0) = 'ab'; -ok 17, $a eq 'abcXYZxyz' ; -substr($a,0,0) = '12345678'; -ok 18, $a eq '12345678abcXYZxyz' ; -substr($a,-3,3) = 'def'; -ok 19, $a eq '12345678abcXYZdef'; -substr($a,-3,3) = '<'; -ok 20, $a eq '12345678abcXYZ<' ; -substr($a,-1,1) = '12345678'; -ok 21, $a eq '12345678abcXYZ12345678' ; - -$a = 'abcdefxyz'; - -ok 22, substr($a,6) eq 'xyz' ; # P Q R=S -ok 23, substr($a,-3) eq 'xyz' ; # P Q R=S -$b = substr($a,999,999) ; # warning # P R=S Q -ok 24, $w-- == 1 ; -eval{substr($a,999,999) = "" ; } ; # P R=S Q -ok 25, $@ =~ /$FATAL_MSG/; -ok 26, substr($a,0) eq 'abcdefxyz' ; # P=Q R=S -ok 27, substr($a,9) eq '' ; # P Q=R=S -ok 28, substr($a,-11) eq 'abcdefxyz'; # Q P R=S -ok 29, substr($a,-9) eq 'abcdefxyz'; # P=Q R=S - -$a = '54321'; - -$b = substr($a,-7, 1) ; # warn # Q R P S -ok 30, $w-- == 1 ; -eval{substr($a,-7, 1) = "" ; }; # Q R P S -ok 31, $@ =~ /$FATAL_MSG/; -$b = substr($a,-7,-6) ; # warn # Q R P S -ok 32, $w-- == 1 ; -eval{substr($a,-7,-6) = "" ; }; # Q R P S -ok 33, $@ =~ /$FATAL_MSG/; -ok 34, substr($a,-5,-7) eq ''; # R P=Q S -ok 35, substr($a, 2,-7) eq ''; # R P Q S -ok 36, substr($a,-3,-7) eq ''; # R P Q S -ok 37, substr($a, 2,-5) eq ''; # P=R Q S -ok 38, substr($a,-3,-5) eq ''; # P=R Q S -ok 39, substr($a, 2,-4) eq ''; # P R Q S -ok 40, substr($a,-3,-4) eq ''; # P R Q S -ok 41, substr($a, 5,-6) eq ''; # R P Q=S -ok 42, substr($a, 5,-5) eq ''; # P=R Q S -ok 43, substr($a, 5,-3) eq ''; # P R Q=S -$b = substr($a, 7,-7) ; # warn # R P S Q -ok 44, $w-- == 1 ; -eval{substr($a, 7,-7) = "" ; }; # R P S Q -ok 45, $@ =~ /$FATAL_MSG/; -$b = substr($a, 7,-5) ; # warn # P=R S Q -ok 46, $w-- == 1 ; -eval{substr($a, 7,-5) = "" ; }; # P=R S Q -ok 47, $@ =~ /$FATAL_MSG/; -$b = substr($a, 7,-3) ; # warn # P Q S Q -ok 48, $w-- == 1 ; -eval{substr($a, 7,-3) = "" ; }; # P Q S Q -ok 49, $@ =~ /$FATAL_MSG/; -$b = substr($a, 7, 0) ; # warn # P S Q=R -ok 50, $w-- == 1 ; -eval{substr($a, 7, 0) = "" ; }; # P S Q=R -ok 51, $@ =~ /$FATAL_MSG/; - -ok 52, substr($a,-7,2) eq ''; # Q P=R S -ok 53, substr($a,-7,4) eq '54'; # Q P R S -ok 54, substr($a,-7,7) eq '54321';# Q P R=S -ok 55, substr($a,-7,9) eq '54321';# Q P S R -ok 56, substr($a,-5,0) eq ''; # P=Q=R S -ok 57, substr($a,-5,3) eq '543';# P=Q R S -ok 58, substr($a,-5,5) eq '54321';# P=Q R=S -ok 59, substr($a,-5,7) eq '54321';# P=Q S R -ok 60, substr($a,-3,0) eq ''; # P Q=R S -ok 61, substr($a,-3,3) eq '321';# P Q R=S -ok 62, substr($a,-2,3) eq '21'; # P Q S R -ok 63, substr($a,0,-5) eq ''; # P=Q=R S -ok 64, substr($a,2,-3) eq ''; # P Q=R S -ok 65, substr($a,0,0) eq ''; # P=Q=R S -ok 66, substr($a,0,5) eq '54321';# P=Q R=S -ok 67, substr($a,0,7) eq '54321';# P=Q S R -ok 68, substr($a,2,0) eq ''; # P Q=R S -ok 69, substr($a,2,3) eq '321'; # P Q R=S -ok 70, substr($a,5,0) eq ''; # P Q=R=S -ok 71, substr($a,5,2) eq ''; # P Q=S R -ok 72, substr($a,-7,-5) eq ''; # Q P=R S -ok 73, substr($a,-7,-2) eq '543';# Q P R S -ok 74, substr($a,-5,-5) eq ''; # P=Q=R S -ok 75, substr($a,-5,-2) eq '543';# P=Q R S -ok 76, substr($a,-3,-3) eq ''; # P Q=R S -ok 77, substr($a,-3,-1) eq '32';# P Q R S - -$a = ''; - -ok 78, substr($a,-2,2) eq ''; # Q P=R=S -ok 79, substr($a,0,0) eq ''; # P=Q=R=S -ok 80, substr($a,0,1) eq ''; # P=Q=S R -ok 81, substr($a,-2,3) eq ''; # Q P=S R -ok 82, substr($a,-2) eq ''; # Q P=R=S -ok 83, substr($a,0) eq ''; # P=Q=R=S - - -ok 84, substr($a,0,-1) eq ''; # R P=Q=S -$b = substr($a,-2, 0) ; # warn # Q=R P=S -ok 85, $w-- == 1 ; -eval{substr($a,-2, 0) = "" ; }; # Q=R P=S -ok 86, $@ =~ /$FATAL_MSG/; - -$b = substr($a,-2, 1) ; # warn # Q R P=S -ok 87, $w-- == 1 ; -eval{substr($a,-2, 1) = "" ; }; # Q R P=S -ok 88, $@ =~ /$FATAL_MSG/; - -$b = substr($a,-2,-1) ; # warn # Q R P=S -ok 89, $w-- == 1 ; -eval{substr($a,-2,-1) = "" ; }; # Q R P=S -ok 90, $@ =~ /$FATAL_MSG/; - -$b = substr($a,-2,-2) ; # warn # Q=R P=S -ok 91, $w-- == 1 ; -eval{substr($a,-2,-2) = "" ; }; # Q=R P=S -ok 92, $@ =~ /$FATAL_MSG/; - -$b = substr($a, 1,-2) ; # warn # R P=S Q -ok 93, $w-- == 1 ; -eval{substr($a, 1,-2) = "" ; }; # R P=S Q -ok 94, $@ =~ /$FATAL_MSG/; - -$b = substr($a, 1, 1) ; # warn # P=S Q R -ok 95, $w-- == 1 ; -eval{substr($a, 1, 1) = "" ; }; # P=S Q R -ok 96, $@ =~ /$FATAL_MSG/; - -$b = substr($a, 1, 0) ;# warn # P=S Q=R -ok 97, $w-- == 1 ; -eval{substr($a, 1, 0) = "" ; }; # P=S Q=R -ok 98, $@ =~ /$FATAL_MSG/; - -$b = substr($a,1) ; # warning # P=R=S Q -ok 99, $w-- == 1 ; -eval{substr($a,1) = "" ; }; # P=R=S Q -ok 100, $@ =~ /$FATAL_MSG/; - -my $a = 'zxcvbnm'; -substr($a,2,0) = ''; -ok 101, $a eq 'zxcvbnm'; -substr($a,7,0) = ''; -ok 102, $a eq 'zxcvbnm'; -substr($a,5,0) = ''; -ok 103, $a eq 'zxcvbnm'; -substr($a,0,2) = 'pq'; -ok 104, $a eq 'pqcvbnm'; -substr($a,2,0) = 'r'; -ok 105, $a eq 'pqrcvbnm'; -substr($a,8,0) = 'asd'; -ok 106, $a eq 'pqrcvbnmasd'; -substr($a,0,2) = 'iop'; -ok 107, $a eq 'ioprcvbnmasd'; -substr($a,0,5) = 'fgh'; -ok 108, $a eq 'fghvbnmasd'; -substr($a,3,5) = 'jkl'; -ok 109, $a eq 'fghjklsd'; -substr($a,3,2) = '1234'; -ok 110, $a eq 'fgh1234lsd'; - - -# with lexicals (and in re-entered scopes) -for (0,1) { - my $txt; - unless ($_) { - $txt = "Foo"; - substr($txt, -1) = "X"; - ok 111, $txt eq "FoX"; - } - else { - substr($txt, 0, 1) = "X"; - ok 112, $txt eq "X"; - } -} - -$w = 0 ; -# coercion of references -{ - my $s = []; - substr($s, 0, 1) = 'Foo'; - ok 113, substr($s,0,7) eq "FooRRAY" && !($w-=2); -} - -# check no spurious warnings -ok 114, $w == 0; - -# check new 4 arg replacement syntax -$a = "abcxyz"; -$w = 0; -ok 115, substr($a, 0, 3, "") eq "abc" && $a eq "xyz"; -ok 116, substr($a, 0, 0, "abc") eq "" && $a eq "abcxyz"; -ok 117, substr($a, 3, -1, "") eq "xy" && $a eq "abcz"; - -ok 118, substr($a, 3, undef, "xy") eq "" && $a eq "abcxyz" - && $w == 3; - -$w = 0; - -ok 119, substr($a, 3, 9999999, "") eq "xyz" && $a eq "abc"; -eval{substr($a, -99, 0, "") }; -ok 120, $@ =~ /$FATAL_MSG/; -eval{substr($a, 99, 3, "") }; -ok 121, $@ =~ /$FATAL_MSG/; - -substr($a, 0, length($a), "foo"); -ok 122, $a eq "foo" && !$w; - -# using 4 arg substr as lvalue is a compile time error -eval 'substr($a,0,0,"") = "abc"'; -ok 123, $@ && $@ =~ /Can't modify substr/ && $a eq "foo"; - -$a = "abcdefgh"; -ok 124, sub { shift }->(substr($a, 0, 4, "xxxx")) eq 'abcd'; -ok 125, $a eq 'xxxxefgh'; - -{ - my $y = 10; - $y = "2" . $y; - ok 126, $y+0 == 210; -} - -# utf8 sanity -{ - my $x = substr("a\x{263a}b",0); - ok 127, length($x) == 3; - $x = substr($x,1,1); - ok 128, $x eq "\x{263a}"; - $x = $x x 2; - ok 129, length($x) == 2; - substr($x,0,1) = "abcd"; - ok 130, $x eq "abcd\x{263a}"; - ok 131, length($x) == 5; - $x = reverse $x; - ok 132, length($x) == 5; - ok 133, $x eq "\x{263a}dcba"; - - my $z = 10; - $z = "21\x{263a}" . $z; - ok 134, length($z) == 5; - ok 135, $z eq "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"; -ok 136, substr($data{'a'}, 0, 5, "") eq "first" && $data{'a'} eq "last"; - -# more utf8 - -# The following two originally from Ignasi Roca. - -$x = "\xF1\xF2\xF3"; -substr($x, 0, 1) = "\x{100}"; # Ignasi had \x{FF} -ok 137, length($x) == 3 && - $x eq "\x{100}\xF2\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{F3}"; - -$x = "\xF1\xF2\xF3"; -substr($x, 0, 1) = "\x{100}\x{FF}"; # Ignasi had \x{FF} -ok 138, length($x) == 4 && - $x eq "\x{100}\x{FF}\xF2\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F2}" && - substr($x, 3, 1) eq "\x{F3}"; - -# more utf8 lval exercise - -$x = "\xF1\xF2\xF3"; -substr($x, 0, 2) = "\x{100}\xFF"; -ok 139, length($x) == 3 && - $x eq "\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F3}"; - -$x = "\xF1\xF2\xF3"; -substr($x, 1, 1) = "\x{100}\xFF"; -ok 140, length($x) == 4 && - $x eq "\xF1\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{F1}" && - substr($x, 1, 1) eq "\x{100}" && - substr($x, 2, 1) eq "\x{FF}" && - substr($x, 3, 1) eq "\x{F3}"; - -$x = "\xF1\xF2\xF3"; -substr($x, 2, 1) = "\x{100}\xFF"; -ok 141, length($x) == 4 && - $x eq "\xF1\xF2\x{100}\xFF" && - substr($x, 0, 1) eq "\x{F1}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{100}" && - substr($x, 3, 1) eq "\x{FF}"; - -$x = "\xF1\xF2\xF3"; -substr($x, 3, 1) = "\x{100}\xFF"; -ok 142, length($x) == 5 && - $x eq "\xF1\xF2\xF3\x{100}\xFF" && - substr($x, 0, 1) eq "\x{F1}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{F3}" && - substr($x, 3, 1) eq "\x{100}" && - substr($x, 4, 1) eq "\x{FF}"; - -$x = "\xF1\xF2\xF3"; -substr($x, -1, 1) = "\x{100}\xFF"; -ok 143, length($x) == 4 && - $x eq "\xF1\xF2\x{100}\xFF" && - substr($x, 0, 1) eq "\x{F1}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{100}" && - substr($x, 3, 1) eq "\x{FF}"; - -$x = "\xF1\xF2\xF3"; -substr($x, -1, 0) = "\x{100}\xFF"; -ok 144, length($x) == 5 && - $x eq "\xF1\xF2\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{F1}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{100}" && - substr($x, 3, 1) eq "\x{FF}" && - substr($x, 4, 1) eq "\x{F3}"; - -$x = "\xF1\xF2\xF3"; -substr($x, 0, -1) = "\x{100}\xFF"; -ok 145, length($x) == 3 && - $x eq "\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F3}"; - -$x = "\xF1\xF2\xF3"; -substr($x, 0, -2) = "\x{100}\xFF"; -ok 146, length($x) == 4 && - $x eq "\x{100}\xFF\xF2\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F2}" && - substr($x, 3, 1) eq "\x{F3}"; - -$x = "\xF1\xF2\xF3"; -substr($x, 0, -3) = "\x{100}\xFF"; -ok 147, length($x) == 5 && - $x eq "\x{100}\xFF\xF1\xF2\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F1}" && - substr($x, 3, 1) eq "\x{F2}" && - substr($x, 4, 1) eq "\x{F3}"; - -$x = "\xF1\xF2\xF3"; -substr($x, 1, -1) = "\x{100}\xFF"; -ok 148, length($x) == 4 && - $x eq "\xF1\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{F1}" && - substr($x, 1, 1) eq "\x{100}" && - substr($x, 2, 1) eq "\x{FF}" && - substr($x, 3, 1) eq "\x{F3}"; - -$x = "\xF1\xF2\xF3"; -substr($x, -1, -1) = "\x{100}\xFF"; -ok 149, length($x) == 5 && - $x eq "\xF1\xF2\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{F1}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{100}" && - substr($x, 3, 1) eq "\x{FF}" && - substr($x, 4, 1) eq "\x{F3}"; - -# And tests for already-UTF8 one - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, 1) = "\x{100}"; -ok 150, length($x) == 3 && - $x eq "\x{100}\xF2\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, 1) = "\x{100}\x{FF}"; -ok 151, length($x) == 4 && - $x eq "\x{100}\x{FF}\xF2\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F2}" && - substr($x, 3, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, 2) = "\x{100}\xFF"; -ok 152, length($x) == 3 && - $x eq "\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 1, 1) = "\x{100}\xFF"; -ok 153, length($x) == 4 && - $x eq "\x{101}\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{101}" && - substr($x, 1, 1) eq "\x{100}" && - substr($x, 2, 1) eq "\x{FF}" && - substr($x, 3, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 2, 1) = "\x{100}\xFF"; -ok 154, length($x) == 4 && - $x eq "\x{101}\xF2\x{100}\xFF" && - substr($x, 0, 1) eq "\x{101}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{100}" && - substr($x, 3, 1) eq "\x{FF}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 3, 1) = "\x{100}\xFF"; -ok 155, length($x) == 5 && - $x eq "\x{101}\x{F2}\x{F3}\x{100}\xFF" && - substr($x, 0, 1) eq "\x{101}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{F3}" && - substr($x, 3, 1) eq "\x{100}" && - substr($x, 4, 1) eq "\x{FF}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, -1, 1) = "\x{100}\xFF"; -ok 156, length($x) == 4 && - $x eq "\x{101}\xF2\x{100}\xFF" && - substr($x, 0, 1) eq "\x{101}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{100}" && - substr($x, 3, 1) eq "\x{FF}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, -1, 0) = "\x{100}\xFF"; -ok 157, length($x) == 5 && - $x eq "\x{101}\xF2\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{101}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{100}" && - substr($x, 3, 1) eq "\x{FF}" && - substr($x, 4, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, -1) = "\x{100}\xFF"; -ok 158, length($x) == 3 && - $x eq "\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, -2) = "\x{100}\xFF"; -ok 159, length($x) == 4 && - $x eq "\x{100}\xFF\xF2\xF3" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{F2}" && - substr($x, 3, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 0, -3) = "\x{100}\xFF"; -ok 160, length($x) == 5 && - $x eq "\x{100}\xFF\x{101}\x{F2}\x{F3}" && - substr($x, 0, 1) eq "\x{100}" && - substr($x, 1, 1) eq "\x{FF}" && - substr($x, 2, 1) eq "\x{101}" && - substr($x, 3, 1) eq "\x{F2}" && - substr($x, 4, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, 1, -1) = "\x{100}\xFF"; -ok 161, length($x) == 4 && - $x eq "\x{101}\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{101}" && - substr($x, 1, 1) eq "\x{100}" && - substr($x, 2, 1) eq "\x{FF}" && - substr($x, 3, 1) eq "\x{F3}"; - -$x = "\x{101}\x{F2}\x{F3}"; -substr($x, -1, -1) = "\x{100}\xFF"; -ok 162, length($x) == 5 && - $x eq "\x{101}\xF2\x{100}\xFF\xF3" && - substr($x, 0, 1) eq "\x{101}" && - substr($x, 1, 1) eq "\x{F2}" && - substr($x, 2, 1) eq "\x{100}" && - substr($x, 3, 1) eq "\x{FF}" && - substr($x, 4, 1) eq "\x{F3}"; - -substr($x = "ab", 0, 0, "\x{100}\x{200}"); -ok 163, $x eq "\x{100}\x{200}ab"; - -substr($x = "\x{100}\x{200}", 0, 0, "ab"); -ok 164, $x eq "ab\x{100}\x{200}"; - -substr($x = "ab", 1, 0, "\x{100}\x{200}"); -ok 165, $x eq "a\x{100}\x{200}b"; - -substr($x = "\x{100}\x{200}", 1, 0, "ab"); -ok 166, $x eq "\x{100}ab\x{200}"; - -substr($x = "ab", 2, 0, "\x{100}\x{200}"); -ok 167, $x eq "ab\x{100}\x{200}"; - -substr($x = "\x{100}\x{200}", 2, 0, "ab"); -ok 168, $x eq "\x{100}\x{200}ab"; - -substr($x = "\xFFb", 0, 0, "\x{100}\x{200}"); -ok 169, $x eq "\x{100}\x{200}\xFFb"; - -substr($x = "\x{100}\x{200}", 0, 0, "\xFFb"); -ok 170, $x eq "\xFFb\x{100}\x{200}"; - -substr($x = "\xFFb", 1, 0, "\x{100}\x{200}"); -ok 171, $x eq "\xFF\x{100}\x{200}b"; - -substr($x = "\x{100}\x{200}", 1, 0, "\xFFb"); -ok 172, $x eq "\x{100}\xFFb\x{200}"; - -substr($x = "\xFFb", 2, 0, "\x{100}\x{200}"); -ok 173, $x eq "\xFFb\x{100}\x{200}"; - -substr($x = "\x{100}\x{200}", 2, 0, "\xFFb"); -ok 174, $x eq "\x{100}\x{200}\xFFb"; - diff --git a/contrib/perl5/t/op/sysio.t b/contrib/perl5/t/op/sysio.t deleted file mode 100755 index e43f850..0000000 --- a/contrib/perl5/t/op/sysio.t +++ /dev/null @@ -1,210 +0,0 @@ -#!./perl - -print "1..39\n"; - -chdir('op') || chdir('t/op') || die "sysio.t: cannot look for myself: $!"; - -open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!"; - -$reopen = ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'MSWin32' || $^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 -print 'not ' unless (syswrite(O, $a, 2) == 2); -print "ok 20\n"; - -# $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; - -chdir('..'); - -1; - -# eof diff --git a/contrib/perl5/t/op/taint.t b/contrib/perl5/t/op/taint.t deleted file mode 100755 index 2958a37..0000000 --- a/contrib/perl5/t/op/taint.t +++ /dev/null @@ -1,735 +0,0 @@ -#!./perl -T -# -# Taint tests by Tom Phoenix <rootbeer@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; - -# We do not want the whole taint.t to fail -# just because Errno possibly failing. -eval { require Errno; import Errno }; - -use vars qw($ipcsysv); # did we manage to load IPC::SysV? - -BEGIN { - if ($^O eq 'VMS' && !defined($Config{d_setenv})) { - $ENV{PATH} = $ENV{PATH}; - $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy'; - } - if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ - && ($Config{d_shm} || $Config{d_msg})) { - eval { require IPC::SysV }; - unless ($@) { - $ipcsysv++; - IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU)); - } - } -} - -my $Is_VMS = $^O eq 'VMS'; -my $Is_MSWin32 = $^O eq 'MSWin32'; -my $Is_Dos = $^O eq 'dos'; -my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.' : - $Is_MSWin32 ? '.\perl' : './perl'; -my @MoreEnv = qw/IFS CDPATH ENV BASH_ENV/; - -if ($Is_VMS) { - my (%old, $x); - for $x ('DCL$PATH', @MoreEnv) { - ($old{$x}) = $ENV{$x} =~ /^(.*)$/ if exists $ENV{$x}; - } - eval <<EndOfCleanup; - END { - \$ENV{PATH} = '' if $Config{d_setenv}; - warn "# Note: logical name 'PATH' may have been deleted\n"; - \@ENV{keys %old} = values %old; - } -EndOfCleanup -} - -# Sources of taint: -# The empty tainted value, for tainting strings -my $TAINT = substr($^X, 0, 0); -# A tainted zero, useful for tainting numbers -my $TAINT0 = 0 + $TAINT; - -# This taints each argument passed. All must be lvalues. -# Side effect: It also stringifies them. :-( -sub taint_these (@) { - for (@_) { $_ .= $TAINT } -} - -# How to identify taint when you see it -sub any_tainted (@) { - not eval { join("",@_), kill 0; 1 }; -} -sub tainted ($) { - any_tainted @_; -} -sub all_tainted (@) { - for (@_) { return 0 unless tainted $_ } - 1; -} - -sub test ($$;$) { - my($serial, $boolean, $diag) = @_; - if ($boolean) { - print "ok $serial\n"; - } else { - print "not ok $serial\n"; - for (split m/^/m, $diag) { - print "# $_"; - } - print "\n" unless - $diag eq '' - or substr($diag, -1) eq "\n"; - } -} - -# We need an external program to call. -my $ECHO = ($Is_MSWin32 ? ".\\echo$$" : "./echo$$"); -END { unlink $ECHO } -open PROG, "> $ECHO" or die "Can't create $ECHO: $!"; -print PROG 'print "@ARGV\n"', "\n"; -close PROG; -my $echo = "$Invoke_Perl $ECHO"; - -print "1..155\n"; - -# First, let's make sure that Perl is checking the dangerous -# environment variables. Maybe they aren't set yet, so we'll -# taint them ourselves. -{ - $ENV{'DCL$PATH'} = '' if $Is_VMS; - - $ENV{PATH} = ''; - delete @ENV{@MoreEnv}; - $ENV{TERM} = 'dumb'; - - test 1, eval { `$echo 1` } eq "1\n"; - - if ($Is_MSWin32 || $Is_VMS || $Is_Dos) { - print "# Environment tainting tests skipped\n"; - for (2..5) { print "ok $_\n" } - } - else { - my @vars = ('PATH', @MoreEnv); - while (my $v = $vars[0]) { - local $ENV{$v} = $TAINT; - last if eval { `$echo 1` }; - last unless $@ =~ /^Insecure \$ENV{$v}/; - shift @vars; - } - test 2, !@vars, "\$$vars[0]"; - - # tainted $TERM is unsafe only if it contains metachars - local $ENV{TERM}; - $ENV{TERM} = 'e=mc2'; - test 3, eval { `$echo 1` } eq "1\n"; - $ENV{TERM} = 'e=mc2' . $TAINT; - test 4, eval { `$echo 1` } eq ''; - test 5, $@ =~ /^Insecure \$ENV{TERM}/, $@; - } - - my $tmp; - if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_Dos) { - print "# all directories are writeable\n"; - } - else { - $tmp = (grep { defined and -d and (stat _)[2] & 2 } - qw(sys$scratch /tmp /var/tmp /usr/tmp), - @ENV{qw(TMP TEMP)})[0] - or print "# can't find world-writeable directory to test PATH\n"; - } - - if ($tmp) { - local $ENV{PATH} = $tmp; - test 6, eval { `$echo 1` } eq ''; - test 7, $@ =~ /^Insecure directory in \$ENV{PATH}/, $@; - } - else { - for (6..7) { print "ok $_ # Skipped: all directories are writeable\n" } - } - - if ($Is_VMS) { - $ENV{'DCL$PATH'} = $TAINT; - test 8, eval { `$echo 1` } eq ''; - test 9, $@ =~ /^Insecure \$ENV{DCL\$PATH}/, $@; - if ($tmp) { - $ENV{'DCL$PATH'} = $tmp; - test 10, eval { `$echo 1` } eq ''; - test 11, $@ =~ /^Insecure directory in \$ENV{DCL\$PATH}/, $@; - } - else { - for (10..11) { print "ok $_ # Skipped: can't find world-writeable directory to test DCL\$PATH\n" } - } - $ENV{'DCL$PATH'} = ''; - } - else { - for (8..11) { print "ok $_ # Skipped: This is not VMS\n"; } - } -} - -# Let's see that we can taint and untaint as needed. -{ - my $foo = $TAINT; - test 12, tainted $foo; - - # That was a sanity check. If it failed, stop the insanity! - die "Taint checks don't seem to be enabled" unless tainted $foo; - - $foo = "foo"; - test 13, not tainted $foo; - - taint_these($foo); - test 14, tainted $foo; - - my @list = 1..10; - test 15, not any_tainted @list; - taint_these @list[1,3,5,7,9]; - test 16, any_tainted @list; - test 17, all_tainted @list[1,3,5,7,9]; - test 18, not any_tainted @list[0,2,4,6,8]; - - ($foo) = $foo =~ /(.+)/; - test 19, not tainted $foo; - - $foo = $1 if ('bar' . $TAINT) =~ /(.+)/; - test 20, not tainted $foo; - test 21, $foo eq 'bar'; - - { - use re 'taint'; - - ($foo) = ('bar' . $TAINT) =~ /(.+)/; - test 22, tainted $foo; - test 23, $foo eq 'bar'; - - $foo = $1 if ('bar' . $TAINT) =~ /(.+)/; - test 24, tainted $foo; - test 25, $foo eq 'bar'; - } - - $foo = $1 if 'bar' =~ /(.+)$TAINT/; - test 26, tainted $foo; - test 27, $foo eq 'bar'; - - my $pi = 4 * atan2(1,1) + $TAINT0; - test 28, tainted $pi; - - ($pi) = $pi =~ /(\d+\.\d+)/; - test 29, not tainted $pi; - test 30, sprintf("%.5f", $pi) eq '3.14159'; -} - -# How about command-line arguments? The problem is that we don't -# always get some, so we'll run another process with some. -{ - my $arg = "./arg$$"; - open PROG, "> $arg" or die "Can't create $arg: $!"; - print PROG q{ - eval { join('', @ARGV), kill 0 }; - exit 0 if $@ =~ /^Insecure dependency/; - print "# Oops: \$@ was [$@]\n"; - exit 1; - }; - close PROG; - print `$Invoke_Perl "-T" $arg and some suspect arguments`; - test 31, !$?, "Exited with status $?"; - unlink $arg; -} - -# Reading from a file should be tainted -{ - my $file = './TEST'; - test 32, open(FILE, $file), "Couldn't open '$file': $!"; - - my $block; - sysread(FILE, $block, 100); - my $line = <FILE>; - close FILE; - test 33, tainted $block; - test 34, tainted $line; -} - -# Globs should be forbidden, except under VMS, -# which doesn't spawn an external program. -if (1 # built-in glob - or $Is_VMS) { - for (35..36) { print "ok $_\n"; } -} -else { - my @globs = eval { <*> }; - test 35, @globs == 0 && $@ =~ /^Insecure dependency/; - - @globs = eval { glob '*' }; - test 36, @globs == 0 && $@ =~ /^Insecure dependency/; -} - -# Output of commands should be tainted -{ - my $foo = `$echo abc`; - test 37, tainted $foo; -} - -# Certain system variables should be tainted -{ - test 38, all_tainted $^X, $0; -} - -# Results of matching should all be untainted -{ - my $foo = "abcdefghi" . $TAINT; - test 39, tainted $foo; - - $foo =~ /def/; - test 40, not any_tainted $`, $&, $'; - - $foo =~ /(...)(...)(...)/; - test 41, not any_tainted $1, $2, $3, $+; - - my @bar = $foo =~ /(...)(...)(...)/; - test 42, not any_tainted @bar; - - test 43, tainted $foo; # $foo should still be tainted! - test 44, $foo eq "abcdefghi"; -} - -# Operations which affect files can't use tainted data. -{ - test 45, eval { chmod 0, $TAINT } eq '', 'chmod'; - test 46, $@ =~ /^Insecure dependency/, $@; - - # There is no feature test in $Config{} for truncate, - # so we allow for the possibility that it's missing. - test 47, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate'; - test 48, $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@; - - test 49, eval { rename '', $TAINT } eq '', 'rename'; - test 50, $@ =~ /^Insecure dependency/, $@; - - test 51, eval { unlink $TAINT } eq '', 'unlink'; - test 52, $@ =~ /^Insecure dependency/, $@; - - test 53, eval { utime $TAINT } eq '', 'utime'; - test 54, $@ =~ /^Insecure dependency/, $@; - - if ($Config{d_chown}) { - test 55, eval { chown -1, -1, $TAINT } eq '', 'chown'; - test 56, $@ =~ /^Insecure dependency/, $@; - } - else { - for (55..56) { print "ok $_ # Skipped: chown() is not available\n" } - } - - if ($Config{d_link}) { - test 57, eval { link $TAINT, '' } eq '', 'link'; - test 58, $@ =~ /^Insecure dependency/, $@; - } - else { - for (57..58) { print "ok $_ # Skipped: link() is not available\n" } - } - - if ($Config{d_symlink}) { - test 59, eval { symlink $TAINT, '' } eq '', 'symlink'; - test 60, $@ =~ /^Insecure dependency/, $@; - } - else { - for (59..60) { print "ok $_ # Skipped: symlink() is not available\n" } - } -} - -# Operations which affect directories can't use tainted data. -{ - test 61, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir'; - test 62, $@ =~ /^Insecure dependency/, $@; - - test 63, eval { rmdir $TAINT } eq '', 'rmdir'; - test 64, $@ =~ /^Insecure dependency/, $@; - - test 65, eval { chdir $TAINT } eq '', 'chdir'; - test 66, $@ =~ /^Insecure dependency/, $@; - - if ($Config{d_chroot}) { - test 67, eval { chroot $TAINT } eq '', 'chroot'; - test 68, $@ =~ /^Insecure dependency/, $@; - } - else { - for (67..68) { print "ok $_ # Skipped: chroot() is not available\n" } - } -} - -# Some operations using files can't use tainted data. -{ - my $foo = "imaginary library" . $TAINT; - test 69, eval { require $foo } eq '', 'require'; - test 70, $@ =~ /^Insecure dependency/, $@; - - my $filename = "./taintB$$"; # NB: $filename isn't tainted! - END { unlink $filename if defined $filename } - $foo = $filename . $TAINT; - unlink $filename; # in any case - - test 71, eval { open FOO, $foo } eq '', 'open for read'; - test 72, $@ eq '', $@; # NB: This should be allowed - - # Try first new style but allow also old style. - test 73, $!{ENOENT} || - $! == 2 || # File not found - ($Is_Dos && $! == 22) || - ($^O eq 'mint' && $! == 33); - - test 74, eval { open FOO, "> $foo" } eq '', 'open for write'; - test 75, $@ =~ /^Insecure dependency/, $@; -} - -# Commands to the system can't use tainted data -{ - my $foo = $TAINT; - - if ($^O eq 'amigaos') { - for (76..79) { print "ok $_ # Skipped: open('|') is not available\n" } - } - else { - test 76, eval { open FOO, "| x$foo" } eq '', 'popen to'; - test 77, $@ =~ /^Insecure dependency/, $@; - - test 78, eval { open FOO, "x$foo |" } eq '', 'popen from'; - test 79, $@ =~ /^Insecure dependency/, $@; - } - - test 80, eval { exec $TAINT } eq '', 'exec'; - test 81, $@ =~ /^Insecure dependency/, $@; - - test 82, eval { system $TAINT } eq '', 'system'; - test 83, $@ =~ /^Insecure dependency/, $@; - - $foo = "*"; - taint_these $foo; - - test 84, eval { `$echo 1$foo` } eq '', 'backticks'; - test 85, $@ =~ /^Insecure dependency/, $@; - - if ($Is_VMS) { # wildcard expansion doesn't invoke shell, so is safe - test 86, join('', eval { glob $foo } ) ne '', 'globbing'; - test 87, $@ eq '', $@; - } - else { - for (86..87) { print "ok $_ # Skipped: this is not VMS\n"; } - } -} - -# Operations which affect processes can't use tainted data. -{ - test 88, eval { kill 0, $TAINT } eq '', 'kill'; - test 89, $@ =~ /^Insecure dependency/, $@; - - if ($Config{d_setpgrp}) { - test 90, eval { setpgrp 0, $TAINT } eq '', 'setpgrp'; - test 91, $@ =~ /^Insecure dependency/, $@; - } - else { - for (90..91) { print "ok $_ # Skipped: setpgrp() is not available\n" } - } - - if ($Config{d_setprior}) { - test 92, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority'; - test 93, $@ =~ /^Insecure dependency/, $@; - } - else { - for (92..93) { print "ok $_ # Skipped: setpriority() is not available\n" } - } -} - -# Some miscellaneous operations can't use tainted data. -{ - if ($Config{d_syscall}) { - test 94, eval { syscall $TAINT } eq '', 'syscall'; - test 95, $@ =~ /^Insecure dependency/, $@; - } - else { - for (94..95) { print "ok $_ # Skipped: syscall() is not available\n" } - } - - { - my $foo = "x" x 979; - taint_these $foo; - local *FOO; - my $temp = "./taintC$$"; - END { unlink $temp } - test 96, open(FOO, "> $temp"), "Couldn't open $temp for write: $!"; - - test 97, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl'; - test 98, $@ =~ /^Insecure dependency/, $@; - - if ($Config{d_fcntl}) { - test 99, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl'; - test 100, $@ =~ /^Insecure dependency/, $@; - } - else { - for (99..100) { print "ok $_ # Skipped: fcntl() is not available\n" } - } - - close FOO; - } -} - -# Some tests involving references -{ - my $foo = 'abc' . $TAINT; - my $fooref = \$foo; - test 101, not tainted $fooref; - test 102, tainted $$fooref; - test 103, tainted $foo; -} - -# Some tests involving assignment -{ - my $foo = $TAINT0; - my $bar = $foo; - test 104, all_tainted $foo, $bar; - test 105, tainted($foo = $bar); - test 106, tainted($bar = $bar); - test 107, tainted($bar += $bar); - test 108, tainted($bar -= $bar); - test 109, tainted($bar *= $bar); - test 110, tainted($bar++); - test 111, tainted($bar /= $bar); - test 112, tainted($bar += 0); - test 113, tainted($bar -= 2); - test 114, tainted($bar *= -1); - test 115, tainted($bar /= 1); - test 116, tainted($bar--); - test 117, $bar == 0; -} - -# Test assignment and return of lists -{ - my @foo = ("A", "tainted" . $TAINT, "B"); - test 118, not tainted $foo[0]; - test 119, tainted $foo[1]; - test 120, not tainted $foo[2]; - my @bar = @foo; - test 121, not tainted $bar[0]; - test 122, tainted $bar[1]; - test 123, not tainted $bar[2]; - my @baz = eval { "A", "tainted" . $TAINT, "B" }; - test 124, not tainted $baz[0]; - test 125, tainted $baz[1]; - test 126, not tainted $baz[2]; - my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ]; - test 127, not tainted $plugh[0]; - test 128, tainted $plugh[1]; - test 129, not tainted $plugh[2]; - my $nautilus = sub { "A", "tainted" . $TAINT, "B" }; - test 130, not tainted ((&$nautilus)[0]); - test 131, tainted ((&$nautilus)[1]); - test 132, not tainted ((&$nautilus)[2]); - my @xyzzy = &$nautilus; - test 133, not tainted $xyzzy[0]; - test 134, tainted $xyzzy[1]; - test 135, not tainted $xyzzy[2]; - my $red_october = sub { return "A", "tainted" . $TAINT, "B" }; - test 136, not tainted ((&$red_october)[0]); - test 137, tainted ((&$red_october)[1]); - test 138, not tainted ((&$red_october)[2]); - my @corge = &$red_october; - test 139, not tainted $corge[0]; - test 140, tainted $corge[1]; - test 141, not tainted $corge[2]; -} - -# Test for system/library calls returning string data of dubious origin. -{ - # No reliable %Config check for getpw* - if (eval { setpwent(); getpwent(); 1 }) { - setpwent(); - my @getpwent = getpwent(); - die "getpwent: $!\n" unless (@getpwent); - test 142,( not tainted $getpwent[0] - and tainted $getpwent[1] - and not tainted $getpwent[2] - and not tainted $getpwent[3] - and not tainted $getpwent[4] - and not tainted $getpwent[5] - and tainted $getpwent[6] # ge?cos - and not tainted $getpwent[7] - and tainted $getpwent[8]); # shell - endpwent(); - } else { - for (142) { print "ok $_ # Skipped: getpwent() is not available\n" } - } - - if ($Config{d_readdir}) { # pretty hard to imagine not - local(*D); - opendir(D, "op") or die "opendir: $!\n"; - my $readdir = readdir(D); - test 143, tainted $readdir; - closedir(OP); - } else { - for (143) { print "ok $_ # Skipped: readdir() is not available\n" } - } - - if ($Config{d_readlink} && $Config{d_symlink}) { - my $symlink = "sl$$"; - unlink($symlink); - symlink("/something/naughty", $symlink) or die "symlink: $!\n"; - my $readlink = readlink($symlink); - test 144, tainted $readlink; - unlink($symlink); - } else { - for (144) { print "ok $_ # Skipped: readlink() or symlink() is not available\n"; } - } -} - -# test bitwise ops (regression bug) -{ - my $why = "y"; - my $j = "x" | $why; - test 145, not tainted $j; - $why = $TAINT."y"; - $j = "x" | $why; - test 146, tainted $j; -} - -# test target of substitution (regression bug) -{ - my $why = $TAINT."y"; - $why =~ s/y/z/; - test 147, tainted $why; - - my $z = "[z]"; - $why =~ s/$z/zee/; - test 148, tainted $why; - - $why =~ s/e/'-'.$$/ge; - test 149, tainted $why; -} - -# test shmread -{ - unless ($ipcsysv) { - print "ok 150 # skipped: no IPC::SysV\n"; - last; - } - if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $Config{d_shm}) { - no strict 'subs'; - my $sent = "foobar"; - my $rcvd; - my $size = 2000; - my $id = shmget(IPC_PRIVATE, $size, S_IRWXU); - - if (defined $id) { - if (shmwrite($id, $sent, 0, 60)) { - if (shmread($id, $rcvd, 0, 60)) { - substr($rcvd, index($rcvd, "\0")) = ''; - } else { - warn "# shmread failed: $!\n"; - } - } else { - warn "# shmwrite failed: $!\n"; - } - shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n"; - } else { - warn "# shmget failed: $!\n"; - } - - if ($rcvd eq $sent) { - test 150, tainted $rcvd; - } else { - print "ok 150 # Skipped: SysV shared memory operation failed\n"; - } - } else { - print "ok 150 # Skipped: SysV shared memory is not available\n"; - } -} - -# test msgrcv -{ - unless ($ipcsysv) { - print "ok 151 # skipped: no IPC::SysV\n"; - last; - } - if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $Config{d_msg}) { - no strict 'subs'; - my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); - - my $sent = "message"; - my $type_sent = 1234; - my $rcvd; - my $type_rcvd; - - if (defined $id) { - if (msgsnd($id, pack("l! a*", $type_sent, $sent), 0)) { - if (msgrcv($id, $rcvd, 60, 0, 0)) { - ($type_rcvd, $rcvd) = unpack("l! a*", $rcvd); - } else { - warn "# msgrcv failed\n"; - } - } else { - warn "# msgsnd failed\n"; - } - msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n"; - } else { - warn "# msgget failed\n"; - } - - if ($rcvd eq $sent && $type_sent == $type_rcvd) { - test 151, tainted $rcvd; - } else { - print "ok 151 # Skipped: SysV message queue operation failed\n"; - } - } else { - print "ok 151 # Skipped: SysV message queues are not available\n"; - } -} - -{ - # bug id 20001004.006 - - open IN, "./TEST" or warn "$0: cannot read ./TEST: $!" ; - local $/; - my $a = <IN>; - my $b = <IN>; - print "not " unless tainted($a) && tainted($b) && !defined($b); - print "ok 152\n"; - close IN; -} - -{ - # bug id 20001004.007 - - open IN, "./TEST" or warn "$0: cannot read ./TEST: $!" ; - my $a = <IN>; - - my $c = { a => 42, - b => $a }; - print "not " unless !tainted($c->{a}) && tainted($c->{b}); - print "ok 153\n"; - - my $d = { a => $a, - b => 42 }; - print "not " unless tainted($d->{a}) && !tainted($d->{b}); - print "ok 154\n"; - - my $e = { a => 42, - b => { c => $a, d => 42 } }; - print "not " unless !tainted($e->{a}) && - !tainted($e->{b}) && - tainted($e->{b}->{c}) && - !tainted($e->{b}->{d}); - print "ok 155\n"; - - close IN; -} - diff --git a/contrib/perl5/t/op/tie.t b/contrib/perl5/t/op/tie.t deleted file mode 100755 index cbf92c6..0000000 --- a/contrib/perl5/t/op/tie.t +++ /dev/null @@ -1,187 +0,0 @@ -#!./perl - -# This test harness will (eventually) test the "tie" functionality -# without the need for a *DBM* implementation. - -# Currently it only tests the untie warning - -chdir 't' if -d 't'; -@INC = '../lib'; -$ENV{PERL5LIB} = "../lib"; - -$|=1; - -# catch warnings into fatal errors -$SIG{__WARN__} = sub { die "WARNING: @_" } ; - -undef $/; -@prgs = split "\n########\n", <DATA>; -print "1..", scalar @prgs, "\n"; - -for (@prgs){ - my($prog,$expected) = split(/\nEXPECT\n/, $_); - eval "$prog" ; - $status = $?; - $results = $@ ; - $results =~ s/\n+$//; - $expected =~ s/\n+$//; - if ( $status or $results and $results !~ /^WARNING: $expected/){ - print STDERR "STATUS: $status\n"; - print STDERR "PROG: $prog\n"; - print STDERR "EXPECTED:\n$expected\n"; - print STDERR "GOT:\n$results\n"; - print "not "; - } - print "ok ", ++$i, "\n"; -} - -__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 -######## - -# 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 -######## - -# 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 -######## - -# 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 -######## - -# verify no leak when underlying object is selfsame tied variable -my ($a, $b); -sub Self::TIEHASH { bless $_[1], $_[0] } -sub Self::DESTROY { $b = $_[0] + 0; } -{ - my %b5; - $a = \%b5 + 0; - tie %b5, 'Self', \%b5; -} -die unless $a == $b; -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 diff --git a/contrib/perl5/t/op/tiearray.t b/contrib/perl5/t/op/tiearray.t deleted file mode 100755 index 8e78b2f..0000000 --- a/contrib/perl5/t/op/tiearray.t +++ /dev/null @@ -1,210 +0,0 @@ -#!./perl - - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -my %seen; - -package Implement; - -sub TIEARRAY -{ - $seen{'TIEARRAY'}++; - my ($class,@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,@_); -} - -sub PUSH -{ - $seen{'PUSH'}++; - my $ob = shift;; - push(@$ob,@_); -} - -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,@_); -} - -package main; - -print "1..31\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(':',@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(':',@ary) eq '1:2:3'; -print "ok ", $test++,"\n"; - -{my @thing = @ary; -print "not " unless join(':',@thing) eq '1:2:3'; -print "ok ", $test++,"\n"; - -tie @thing,'Implement'; -@thing = @ary; -print "not " unless join(':',@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(':',@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(':',@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(':',@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(':',@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(':',@ary) eq '5:6:7:4'; -print "ok ", $test++,"\n"; - -@ary = split(/:/,'1:2:3'); -print "not " unless join(':',@ary) eq '1:2:3'; -print "ok ", $test++,"\n"; - -my $t = 0; -foreach $n (@ary) - { - print "not " unless $n == ++$t; - print "ok ", $test++,"\n"; - } - -@ary = qw(3 2 1); -print "not " unless join(':',@ary) eq '3:2:1'; -print "ok ", $test++,"\n"; - -untie @ary; - -} - -print "not " unless $seen{'DESTROY'} == 2; -print "ok ", $test++,"\n"; - - - diff --git a/contrib/perl5/t/op/tiehandle.t b/contrib/perl5/t/op/tiehandle.t deleted file mode 100755 index b04bdb7..0000000 --- a/contrib/perl5/t/op/tiehandle.t +++ /dev/null @@ -1,167 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -my @expect; -my $data = ""; -my @data = (); -my $test = 1; - -sub ok { print "not " unless shift; print "ok ",$test++,"\n"; } - -package Implement; - -BEGIN { *ok = \*main::ok } - -sub compare { - return unless @expect; - return ok(0) unless(@_ == @expect); - - my $i; - for($i = 0 ; $i < @_ ; $i++) { - next if $_[$i] eq $expect[$i]; - return ok(0); - } - - ok(1); -} - -sub TIEHANDLE { - compare(TIEHANDLE => @_); - my ($class,@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; - -print "1..33\n"; - -my $fh = gensym; - -@expect = (TIEHANDLE => 'Implement'); -my $ob = tie *$fh,'Implement'; -ok(ref($ob) eq 'Implement'); -ok(tied(*$fh) == $ob); - -@expect = (PRINT => $ob,"some","text"); -$r = print $fh @expect[2,3]; -ok($r == 1); - -@expect = (PRINTF => $ob,"%s","text"); -$r = printf $fh @expect[2,3]; -ok($r == 2); - -$text = (@data = ("the line\n"))[0]; -@expect = (READLINE => $ob); -$ln = <$fh>; -ok($ln eq $text); - -@expect = (); -@in = @data = qw(a line at a time); -@line = <$fh>; -@expect = @in; -Implement::compare(@line); - -@expect = (GETC => $ob); -$data = "abc"; -$ch = getc $fh; -ok($ch eq "a"); - -$buf = "xyz"; -@expect = (READ => $ob, $buf, 3); -$data = "abc"; -$r = read $fh,$buf,3; -ok($r == 3); -ok($buf eq "abc"); - - -$buf = "xyzasd"; -@expect = (READ => $ob, $buf, 3,3); -$data = "abc"; -$r = sysread $fh,$buf,3,3; -ok($r == 3); -ok($buf eq "xyzabc"); - -$buf = "qwerty"; -@expect = (WRITE => $ob, $buf, 4,1); -$data = ""; -$r = syswrite $fh,$buf,4,1; -ok($r == 4); -ok($data eq "wert"); - -$buf = "qwerty"; -@expect = (WRITE => $ob, $buf, 4); -$data = ""; -$r = syswrite $fh,$buf,4; -ok($r == 4); -ok($data eq "qwer"); - -$buf = "qwerty"; -@expect = (WRITE => $ob, $buf, 6); -$data = ""; -$r = syswrite $fh,$buf; -ok($r == 6); -ok($data eq "qwerty"); - -@expect = (CLOSE => $ob); -$r = close $fh; -ok($r == 5); - -# Does aliasing work with tied FHs? -*ALIAS = *$fh; -@expect = (PRINT => $ob,"some","text"); -$r = print ALIAS @expect[2,3]; -ok($r == 1); - -{ - use warnings; - # Special case of aliasing STDERR, which used - # to dump core when warnings were enabled - *STDERR = *$fh; - @expect = (PRINT => $ob,"some","text"); - $r = print STDERR @expect[2,3]; - ok($r == 1); -} diff --git a/contrib/perl5/t/op/time.t b/contrib/perl5/t/op/time.t deleted file mode 100755 index caf2c14..0000000 --- a/contrib/perl5/t/op/time.t +++ /dev/null @@ -1,53 +0,0 @@ -#!./perl - -# $RCSfile: time.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:32 $ - -if ($does_gmtime = gmtime(time)) { print "1..6\n" } -else { print "1..3\n" } - -($beguser,$begsys) = times; - -$beg = time; - -while (($now = time) == $beg) { sleep 1 } - -if ($now > $beg && $now - $beg < 10){print "ok 1\n";} else {print "not ok 1\n";} - -for ($i = 0; $i < 100000; $i++) { - ($nowuser, $nowsys) = times; - $i = 200000 if $nowuser > $beguser && ( $nowsys > $begsys || - (!$nowsys && !$begsys)); - last if time - $beg > 20; -} - -if ($i >= 200000) {print "ok 2\n";} else {print "not ok 2\n";} - -($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($beg); -($xsec,$foo) = localtime($now); -$localyday = $yday; - -if ($sec != $xsec && $mday && $year) - {print "ok 3\n";} -else - {print "not ok 3\n";} - -exit 0 unless $does_gmtime; - -($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($beg); -($xsec,$foo) = localtime($now); - -if ($sec != $xsec && $mday && $year) - {print "ok 4\n";} -else - {print "not ok 4\n";} - -if (index(" :0:1:-1:364:365:-364:-365:",':' . ($localyday - $yday) . ':') > 0) - {print "ok 5\n";} -else - {print "not ok 5\n";} - -# This could be stricter. -if (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\d\d\d)$/) - {print "ok 6\n";} -else - {print "not ok 6\n";} diff --git a/contrib/perl5/t/op/tr.t b/contrib/perl5/t/op/tr.t deleted file mode 100755 index c7ba0d8..0000000 --- a/contrib/perl5/t/op/tr.t +++ /dev/null @@ -1,311 +0,0 @@ -# tr.t - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..54\n"; - -$_ = "abcdefghijklmnopqrstuvwxyz"; - -tr/a-z/A-Z/; - -print "not " unless $_ eq "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; -print "ok 1\n"; - -tr/A-Z/a-z/; - -print "not " unless $_ eq "abcdefghijklmnopqrstuvwxyz"; -print "ok 2\n"; - -tr/b-y/B-Y/; - -print "not " unless $_ eq "aBCDEFGHIJKLMNOPQRSTUVWXYz"; -print "ok 3\n"; - -# 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/; - - print "not " unless $_ eq "i\xcaj"; - print "ok 4\n"; -} -# - -# make sure that tr cancels IOK and NOK -($x = 12) =~ tr/1/3/; -(my $y = 12) =~ tr/1/3/; -($f = 1.5) =~ tr/1/3/; -(my $g = 1.5) =~ tr/1/3/; -print "not " unless $x + $y + $f + $g == 71; -print "ok 5\n"; - -# make sure tr is harmless if not updating - see [ID 20000511.005] -$_ = 'fred'; -/([a-z]{2})/; -$1 =~ tr/A-Z//; -s/^(\s*)f/$1F/; -print "not " if $_ ne 'Fred'; -print "ok 6\n"; - -# check tr handles UTF8 correctly -($x = 256.65.258) =~ tr/a/b/; -print "not " if $x ne 256.65.258 or length $x != 3; -print "ok 7\n"; -$x =~ tr/A/B/; -if (ord("\t") == 9) { # ASCII - print "not " if $x ne 256.66.258 or length $x != 3; -} -else { - print "not " if $x ne 256.65.258 or length $x != 3; -} -print "ok 8\n"; -# EBCDIC variants of the above tests -($x = 256.193.258) =~ tr/a/b/; -print "not " if $x ne 256.193.258 or length $x != 3; -print "ok 9\n"; -$x =~ tr/A/B/; -if (ord("\t") == 9) { # ASCII - print "not " if $x ne 256.193.258 or length $x != 3; -} -else { - print "not " if $x ne 256.194.258 or length $x != 3; -} -print "ok 10\n"; - -{ -if (ord("\t") == 9) { # ASCII - use utf8; -} -# 11 - changing UTF8 characters in a UTF8 string, same length. -$l = chr(300); $r = chr(400); -$x = 200.300.400; -$x =~ tr/\x{12c}/\x{190}/; -printf "not (%vd) ", $x if $x ne 200.400.400 or length $x != 3; -print "ok 11\n"; - -# 12 - changing UTF8 characters in UTF8 string, more bytes. -$x = 200.300.400; -$x =~ tr/\x{12c}/\x{be8}/; -printf "not (%vd) ", $x if $x ne 200.3048.400 or length $x != 3; -print "ok 12\n"; - -# 13 - introducing UTF8 characters to non-UTF8 string. -$x = 100.125.60; -$x =~ tr/\x{64}/\x{190}/; -printf "not (%vd) ", $x if $x ne 400.125.60 or length $x != 3; -print "ok 13\n"; - -# 14 - removing UTF8 characters from UTF8 string -$x = 400.125.60; -$x =~ tr/\x{190}/\x{64}/; -printf "not (%vd) ", $x if $x ne 100.125.60 or length $x != 3; -print "ok 14\n"; - -# 15 - counting UTF8 chars in UTF8 string -$x = 400.125.60.400; -$y = $x =~ tr/\x{190}/\x{190}/; -print "not " if $y != 2; -print "ok 15\n"; - -# 16 - counting non-UTF8 chars in UTF8 string -$x = 60.400.125.60.400; -$y = $x =~ tr/\x{3c}/\x{3c}/; -print "not " if $y != 2; -print "ok 16\n"; - -# 17 - counting UTF8 chars in non-UTF8 string -$x = 200.125.60; -$y = $x =~ tr/\x{190}/\x{190}/; -print "not " if $y != 0; -print "ok 17\n"; -} - -# 18: test brokenness with tr/a-z-9//; -$_ = "abcdefghijklmnopqrstuvwxyz"; -eval "tr/a-z-9/ /"; -print (($@ =~ /^Ambiguous range in transliteration operator/ || $^V lt v5.7.0) - ? '' : 'not ', "ok 18\n"); - -# 19-21: Make sure leading and trailing hyphens still work -$_ = "car-rot9"; -tr/-a-m/./; -print (($_ eq '..r.rot9') ? '' : 'not ', "ok 19\n"); - -$_ = "car-rot9"; -tr/a-m-/./; -print (($_ eq '..r.rot9') ? '' : 'not ', "ok 20\n"); - -$_ = "car-rot9"; -tr/-a-m-/./; -print (($_ eq '..r.rot9') ? '' : 'not ', "ok 21\n"); - -$_ = "abcdefghijklmnop"; -tr/ae-hn/./; -print (($_ eq '.bcd....ijklm.op') ? '' : 'not ', "ok 22\n"); - -$_ = "abcdefghijklmnop"; -tr/a-cf-kn-p/./; -print (($_ eq '...de......lm...') ? '' : 'not ', "ok 23\n"); - -$_ = "abcdefghijklmnop"; -tr/a-ceg-ikm-o/./; -print (($_ eq '...d.f...j.l...p') ? '' : 'not ', "ok 24\n"); - -# 25: Test reversed range check -# 20000705 MJD -eval "tr/m-d/ /"; -print (($@ =~ /^Invalid \[\] range "m-d" in transliteration operator/ || $^V lt v5.7.0) - ? '' : 'not ', "ok 25\n"); - -# 26: test cannot update if read-only -eval '$1 =~ tr/x/y/'; -print (($@ =~ /^Modification of a read-only value attempted/) ? '' : 'not ', - "ok 26\n"); - -# 27: test can count read-only -'abcdef' =~ /(bcd)/; -print (( eval '$1 =~ tr/abcd//' == 3) ? '' : 'not ', "ok 27\n"); - -# 28: test lhs OK if not updating -print ((eval '"123" =~ tr/12//' == 2) ? '' : 'not ', "ok 28\n"); - -# 29: test lhs bad if updating -eval '"123" =~ tr/1/1/'; -print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|) - ? '' : 'not ', "ok 29\n"); - -# 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/; -print "not " unless $a eq v300.197.172.300.197.172; -print "ok 30\n"; - -($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/; -print "not " unless $a eq v300.197.172.300.197.172; -print "ok 31\n"; - -($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/; -print "not " unless $a eq v300.197.172.300.197.172; -print "ok 32\n"; - -($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/; -print "not " unless $a eq v300.197.172.300.197.172; -print "ok 33\n"; - -# Transliterate a byte to a wide character. - -($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/; -print "not " unless $a eq v300.301.172.300.301.172; -print "ok 34\n"; - -# Transliterate a wide character to a byte. - -($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/; -print "not " unless $a eq v195.196.172.195.196.172; -print "ok 35\n"; - -# Transliterate a wide character to a wide character. - -($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/; -print "not " unless $a eq v301.196.172.301.196.172; -print "ok 36\n"; - -# Transliterate both ways. - -($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/; -print "not " unless $a eq v195.301.172.195.301.172; -print "ok 37\n"; - -# Transliterate all (four) ways. - -($a = v300.196.172.300.196.172.400.198.144) =~ - tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/; -print "not " unless $a eq v197.301.173.197.301.173.401.198.144; -print "ok 38\n"; - -# Transliterate and count. - -print "not " - unless (($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/) == 2; -print "ok 39\n"; - -print "not " - unless (($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/) == 2; -print "ok 40\n"; - -# Transliterate with complement. - -($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c; -print "not " unless $a eq v301.196.301.301.196.301; -print "ok 41\n"; - -($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c; -print "not " unless $a eq v300.197.197.300.197.197; -print "ok 42\n"; - -# Transliterate with deletion. - -($a = v300.196.172.300.196.172) =~ tr/\xc4//d; -print "not " unless $a eq v300.172.300.172; -print "ok 43\n"; - -($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d; -print "not " unless $a eq v196.172.196.172; -print "ok 44\n"; - -# Transliterate with squeeze. - -($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s; -print "not " unless $a eq v197.172.300.300.197.172; -print "ok 45\n"; - -($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s; -print "not " unless $a eq v196.172.301.196.172.172; -print "ok 46\n"; - -# Tricky cases by Simon Cozens. - -($a = v196.172.200) =~ tr/\x{12c}/a/; -print "not " unless sprintf("%vd", $a) eq '196.172.200'; -print "ok 47\n"; - -($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/; -print "not " unless sprintf("%vd", $a) eq '196.172.200'; -print "ok 48\n"; - -($a = v196.172.200) =~ tr/\x{12c}//d; -print "not " unless sprintf("%vd", $a) eq '196.172.200'; -print "ok 49\n"; - -# UTF8 range - -($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/; -print "not " unless $a eq v192.196.172.194.197.172; -print "ok 50\n"; - -($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/; -print "not " unless $a eq v300.300.172.302.301.172; -print "ok 51\n"; - -# misc -($a = "R0_001") =~ tr/R_//d; -print "not " if hex($a) != 1; -print "ok 52\n"; - -@a = (1,2); map { y/1/./ for $_ } @a; -print "not " if "@a" ne ". 2"; -print "ok 53\n"; - -@a = (1,2); map { y/1/./ for $_.'' } @a; -print "not " if "@a" ne "1 2"; -print "ok 54\n"; diff --git a/contrib/perl5/t/op/undef.t b/contrib/perl5/t/op/undef.t deleted file mode 100755 index f6e36a5..0000000 --- a/contrib/perl5/t/op/undef.t +++ /dev/null @@ -1,81 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..27\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"; -} diff --git a/contrib/perl5/t/op/universal.t b/contrib/perl5/t/op/universal.t deleted file mode 100755 index e6db8e6..0000000 --- a/contrib/perl5/t/op/universal.t +++ /dev/null @@ -1,142 +0,0 @@ -#!./perl -# -# check UNIVERSAL -# - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; - $| = 1; -} - -print "1..80\n"; - -$a = {}; -bless $a, "Bob"; -print "not " unless $a->isa("Bob"); -print "ok 1\n"; - -package Human; -sub eat {} - -package Female; -@ISA=qw(Human); - -package Alice; -@ISA=qw(Bob Female); -sub drink {} -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; - -my $i = 2; -sub test { print "not " unless shift; print "ok $i\n"; $i++; } - -$a = new Alice; - -test $a->isa("Alice"); - -test $a->isa("Bob"); - -test $a->isa("Female"); - -test $a->isa("Human"); - -test ! $a->isa("Male"); - -test ! $a->isa('Programmer'); - -test $a->can("drink"); - -test $a->can("eat"); - -test ! $a->can("sleep"); - -test (!Cedric->isa('Programmer')); - -test (Cedric->isa('Human')); - -push(@Cedric::ISA,'Programmer'); - -test (Cedric->isa('Programmer')); - -{ - package Alice; - base::->import('Programmer'); -} - -test $a->isa('Programmer'); -test $a->isa("Female"); - -@Cedric::ISA = qw(Bob); - -test (!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++) { - test UNIVERSAL::isa($vals[$p], $refs[$q]) eq ($p==$q or $p+$q==1); - }; -}; - -test ! UNIVERSAL::can(23, "can"); - -test $a->can("VERSION"); - -test $a->can("can"); -test ! $a->can("export_tags"); # a method in Exporter - -test (eval { $a->VERSION }) == 2.718; - -test ! (eval { $a->VERSION(2.719) }) && - $@ =~ /^Alice version 2.71(?:9|8999\d+) required--this is only version 2.718 at /; - -test (eval { $a->VERSION(2.718) }) && ! $@; - -my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; -if ('a' lt 'A') { - test $subs eq "can isa VERSION"; -} else { - test $subs eq "VERSION can isa"; -} - -test $a->isa("UNIVERSAL"); - -# now use UNIVERSAL.pm and see what changes -eval "use UNIVERSAL"; - -test $a->isa("UNIVERSAL"); - -my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; -# XXX import being here is really a bug -if ('a' lt 'A') { - test $sub2 eq "can import isa VERSION"; -} else { - test $sub2 eq "VERSION can import isa"; -} - -eval 'sub UNIVERSAL::sleep {}'; -test $a->can("sleep"); - -test ! UNIVERSAL::can($b, "can"); - -test ! $a->can("export_tags"); # a method in Exporter - -test ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH'); diff --git a/contrib/perl5/t/op/unshift.t b/contrib/perl5/t/op/unshift.t deleted file mode 100755 index 68d3775..0000000 --- a/contrib/perl5/t/op/unshift.t +++ /dev/null @@ -1,14 +0,0 @@ -#!./perl - -# $RCSfile: unshift.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:35 $ - -print "1..2\n"; - -@a = (1,2,3); -$cnt1 = unshift(a,0); - -if (join(' ',@a) eq '0 1 2 3') {print "ok 1\n";} else {print "not ok 1\n";} -$cnt2 = unshift(a,3,2,1); -if (join(' ',@a) eq '3 2 1 0 1 2 3') {print "ok 2\n";} else {print "not ok 2\n";} - - diff --git a/contrib/perl5/t/op/utf8decode.t b/contrib/perl5/t/op/utf8decode.t deleted file mode 100755 index 4d05a6b8..0000000 --- a/contrib/perl5/t/op/utf8decode.t +++ /dev/null @@ -1,183 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -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 $WARNCNT; - my $id; - - local $SIG{__WARN__} = - sub { - print "# $id: @_"; - $WARNCNT++; - $WARNMSG = "@_"; - }; - - sub moan { - print "$id: @_"; - } - - sub test_unpack_U { - $WARNCNT = 0; - $WARNMSG = ""; - unpack('U*', $_[0]); - } - - 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, $error) = - ($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"; - } - } - if ($okay eq 'y') { - test_unpack_U($bytes); - if ($WARNCNT) { - moan "unpack('U*') false negative\n"; - print "not "; - } - } elsif ($okay eq 'n') { - test_unpack_U($bytes); - if ($WARNCNT == 0 || ($error ne '' && $WARNMSG !~ /$error/)) { - moan "unpack('U*') false positive\n"; - print "not "; - } - } - print "ok $test\n"; - $test++; - } else { - moan "unknown format\n"; - } - } -} diff --git a/contrib/perl5/t/op/vec.t b/contrib/perl5/t/op/vec.t deleted file mode 100755 index 7fe0974..0000000 --- a/contrib/perl5/t/op/vec.t +++ /dev/null @@ -1,80 +0,0 @@ -#!./perl - -print "1..30\n"; - -print vec($foo,0,1) == 0 ? "ok 1\n" : "not ok 1\n"; -print length($foo) == 0 ? "ok 2\n" : "not ok 2\n"; -vec($foo,0,1) = 1; -print length($foo) == 1 ? "ok 3\n" : "not ok 3\n"; -print unpack('C',$foo) == 1 ? "ok 4\n" : "not ok 4\n"; -print vec($foo,0,1) == 1 ? "ok 5\n" : "not ok 5\n"; - -print vec($foo,20,1) == 0 ? "ok 6\n" : "not ok 6\n"; -vec($foo,20,1) = 1; -print vec($foo,20,1) == 1 ? "ok 7\n" : "not ok 7\n"; -print length($foo) == 3 ? "ok 8\n" : "not ok 8\n"; -print vec($foo,1,8) == 0 ? "ok 9\n" : "not ok 9\n"; -vec($foo,1,8) = 0xf1; -print vec($foo,1,8) == 0xf1 ? "ok 10\n" : "not ok 10\n"; -print ((unpack('C',substr($foo,1,1)) & 255) == 0xf1 ? "ok 11\n" : "not ok 11\n"); -print vec($foo,2,4) == 1 ? "ok 12\n" : "not ok 12\n"; -print vec($foo,3,4) == 15 ? "ok 13\n" : "not ok 13\n"; -vec($Vec, 0, 32) = 0xbaddacab; -print $Vec eq "\xba\xdd\xac\xab" ? "ok 14\n" : "not ok 14\n"; -print vec($Vec, 0, 32) == 3135089835 ? "ok 15\n" : "not ok 15\n"; - -# ensure vec() handles numericalness correctly -$foo = $bar = $baz = 0; -vec($foo = 0,0,1) = 1; -vec($bar = 0,1,1) = 1; -$baz = $foo | $bar; -print $foo eq "1" && $foo == 1 ? "ok 16\n" : "not ok 16\n"; -print $bar eq "2" && $bar == 2 ? "ok 17\n" : "not ok 17\n"; -print "$foo $bar $baz" eq "1 2 3" ? "ok 18\n" : "not ok 18\n"; - -# error cases - -$x = eval { vec $foo, 0, 3 }; -print "not " if defined $x or $@ !~ /^Illegal number of bits in vec/; -print "ok 19\n"; -$x = eval { vec $foo, 0, 0 }; -print "not " if defined $x or $@ !~ /^Illegal number of bits in vec/; -print "ok 20\n"; -$x = eval { vec $foo, 0, -13 }; -print "not " if defined $x or $@ !~ /^Illegal number of bits in vec/; -print "ok 21\n"; -$x = eval { vec($foo, -1, 4) = 2 }; -print "not " if defined $x or $@ !~ /^Assigning to negative offset in vec/; -print "ok 22\n"; -print "not " if vec('abcd', 7, 8); -print "ok 23\n"; - -# UTF8 -# N.B. currently curiously coded to circumvent bugs elswhere in UTF8 handling - -$foo = "\x{100}" . "\xff\xfe"; -$x = substr $foo, 1; -print "not " if vec($x, 0, 8) != 255; -print "ok 24\n"; -eval { vec($foo, 1, 8) }; -print "not " if $@; -print "ok 25\n"; -eval { vec($foo, 1, 8) = 13 }; -print "not " if $@; -print "ok 26\n"; -print "not " if $foo ne "\xc4\x0d\xc3\xbf\xc3\xbe"; -print "ok 27\n"; -$foo = "\x{100}" . "\xff\xfe"; -$x = substr $foo, 1; -vec($x, 2, 4) = 7; -print "not " if $x ne "\xff\xf7"; -print "ok 28\n"; - -# mixed magic - -$foo = "\x61\x62\x63\x64\x65\x66"; -print "not " if vec(substr($foo, 2, 2), 0, 16) != 25444; -print "ok 29\n"; -vec(substr($foo, 1,3), 5, 4) = 3; -print "not " if $foo ne "\x61\x62\x63\x34\x65\x66"; -print "ok 30\n"; diff --git a/contrib/perl5/t/op/ver.t b/contrib/perl5/t/op/ver.t deleted file mode 100755 index edfebd2..0000000 --- a/contrib/perl5/t/op/ver.t +++ /dev/null @@ -1,181 +0,0 @@ -#!./perl - -BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; -} - -print "1..28\n"; - -my $test = 1; - -use v5.5.640; -require v5.5.640; -print "ok $test\n"; ++$test; - -# printing characters should work -if (ord("\t") == 9) { # ASCII - print v111; - print v107.32; - print "$test\n"; ++$test; - - # hash keys too - $h{v111.107} = "ok"; - print "$h{ok} $test\n"; ++$test; -} -else { # EBCDIC - print v150; - print v146.64; - print "$test\n"; ++$test; - - # hash keys too - $h{v150.146} = "ok"; - print "$h{ok} $test\n"; ++$test; -} - -# poetry optimization should also -sub v77 { "ok" } -$x = v77; -print "$x $test\n"; ++$test; - -# but not when dots are involved -if (ord("\t") == 9) { # ASCII - $x = v77.78.79; -} -else { - $x = v212.213.214; -} -print "not " unless $x eq "MNO"; -print "ok $test\n"; ++$test; - -print "not " unless v1.20.300.4000 eq "\x{1}\x{14}\x{12c}\x{fa0}"; -print "ok $test\n"; ++$test; - -# -# now do the same without the "v" -use 5.5.640; -require 5.5.640; -print "ok $test\n"; ++$test; - -# hash keys too -if (ord("\t") == 9) { # ASCII - $h{111.107.32} = "ok"; -} -else { - $h{150.146.64} = "ok"; -} -print "$h{ok } $test\n"; ++$test; - -if (ord("\t") == 9) { # ASCII - $x = 77.78.79; -} -else { - $x = 212.213.214; -} -print "not " unless $x eq "MNO"; -print "ok $test\n"; ++$test; - -print "not " unless 1.20.300.4000 eq "\x{1}\x{14}\x{12c}\x{fa0}"; -print "ok $test\n"; ++$test; - -# test sprintf("%vd"...) etc -if (ord("\t") == 9) { # ASCII - print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; -} -else { - print "not " unless sprintf("%vd", "Perl") eq '215.133.153.147'; -} -print "ok $test\n"; ++$test; - -print "not " unless sprintf("%vd", v1.22.333.4444) eq '1.22.333.4444'; -print "ok $test\n"; ++$test; - -if (ord("\t") == 9) { # ASCII - print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; -} -else { - print "not " unless sprintf("%vx", "Perl") eq 'd7.85.99.93'; -} -print "ok $test\n"; ++$test; - -print "not " unless sprintf("%vX", 1.22.333.4444) eq '1.16.14D.115C'; -print "ok $test\n"; ++$test; - -if (ord("\t") == 9) { # ASCII - print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; -} -else { - print "not " unless sprintf("%*v#o", ":", "Perl") eq '0327:0205:0231:0223'; -} -print "ok $test\n"; ++$test; - -print "not " unless sprintf("%*vb", "##", v1.22.333.4444) - eq '1##10110##101001101##1000101011100'; -print "ok $test\n"; ++$test; - -print "not " unless sprintf("%vd", join("", map { chr } - unpack "U*", v2001.2002.2003)) - eq '2001.2002.2003'; -print "ok $test\n"; ++$test; - -{ - use bytes; - if (ord("\t") == 9) { # ASCII - print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; - } - else { - print "not " unless sprintf("%vd", "Perl") eq '215.133.153.147'; - } - print "ok $test\n"; ++$test; - - print "not " unless - sprintf("%vd", 1.22.333.4444) eq '1.22.197.141.225.133.156'; - print "ok $test\n"; ++$test; - - if (ord("\t") == 9) { # ASCII - print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; - } - else { - print "not " unless sprintf("%vx", "Perl") eq 'd7.85.99.93'; - } - print "ok $test\n"; ++$test; - - print "not " unless sprintf("%vX", v1.22.333.4444) eq '1.16.C5.8D.E1.85.9C'; - print "ok $test\n"; ++$test; - - if (ord("\t") == 9) { # ASCII - print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; - } - else { - print "not " unless sprintf("%*v#o", ":", "Perl") eq '0327:0205:0231:0223'; - } - print "ok $test\n"; ++$test; - - print "not " unless sprintf("%*vb", "##", v1.22.333.4444) - eq '1##10110##11000101##10001101##11100001##10000101##10011100'; - print "ok $test\n"; ++$test; -} - -{ - # bug id 20000323.056 - - print "not " unless "\x{41}" eq +v65; - print "ok $test\n"; - $test++; - - print "not " unless "\x41" eq +v65; - print "ok $test\n"; - $test++; - - print "not " unless "\x{c8}" eq +v200; - print "ok $test\n"; - $test++; - - print "not " unless "\xc8" eq +v200; - print "ok $test\n"; - $test++; - - print "not " unless "\x{221b}" eq v8731; - print "ok $test\n"; - $test++; -} diff --git a/contrib/perl5/t/op/wantarray.t b/contrib/perl5/t/op/wantarray.t deleted file mode 100755 index 4b6f37c..0000000 --- a/contrib/perl5/t/op/wantarray.t +++ /dev/null @@ -1,20 +0,0 @@ -#!./perl - -print "1..7\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); -1; diff --git a/contrib/perl5/t/op/write.t b/contrib/perl5/t/op/write.t deleted file mode 100755 index 5b01eb7..0000000 --- a/contrib/perl5/t/op/write.t +++ /dev/null @@ -1,220 +0,0 @@ -#!./perl - -print "1..9\n"; - -my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat'; - -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"; - -$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; - -$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"; 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; - -$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"; 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; - -$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"; 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; - -$right = -"fit\n"; - -if (`$CAT Op_write.tmp` eq $right) - { print "ok 6\n"; 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; -} -# 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; -if (`$CAT Op_write.tmp` eq "1\n") { - print "ok 9\n"; - unlink "Op_write.tmp"; - } -else { - print "not ok 9\n"; - } |
