From 4fcbc3669aa997848e15198cc9fb856287a6788c Mon Sep 17 00:00:00 2001 From: markm Date: Wed, 9 Sep 1998 07:00:04 +0000 Subject: Initial import of Perl5. The king is dead; long live the king! --- contrib/perl5/t/op/append.t | 21 ++ contrib/perl5/t/op/arith.t | 12 + contrib/perl5/t/op/array.t | 208 +++++++++++++ contrib/perl5/t/op/assignwarn.t | 61 ++++ contrib/perl5/t/op/auto.t | 52 ++++ contrib/perl5/t/op/avhv.t | 110 +++++++ contrib/perl5/t/op/bop.t | 64 ++++ contrib/perl5/t/op/chop.t | 87 ++++++ contrib/perl5/t/op/closure.t | 482 ++++++++++++++++++++++++++++++ contrib/perl5/t/op/cmp.t | 35 +++ contrib/perl5/t/op/cond.t | 12 + contrib/perl5/t/op/context.t | 18 ++ contrib/perl5/t/op/defins.t | 147 ++++++++++ contrib/perl5/t/op/delete.t | 51 ++++ contrib/perl5/t/op/die.t | 43 +++ contrib/perl5/t/op/die_exit.t | 53 ++++ contrib/perl5/t/op/do.t | 44 +++ contrib/perl5/t/op/each.t | 122 ++++++++ contrib/perl5/t/op/eval.t | 81 ++++++ contrib/perl5/t/op/exec.t | 35 +++ contrib/perl5/t/op/exp.t | 27 ++ contrib/perl5/t/op/flip.t | 29 ++ contrib/perl5/t/op/fork.t | 26 ++ contrib/perl5/t/op/glob.t | 37 +++ contrib/perl5/t/op/goto.t | 90 ++++++ contrib/perl5/t/op/goto_xs.t | 98 +++++++ contrib/perl5/t/op/groups.t | 50 ++++ contrib/perl5/t/op/gv.t | 98 +++++++ contrib/perl5/t/op/hashwarn.t | 71 +++++ contrib/perl5/t/op/inc.t | 52 ++++ contrib/perl5/t/op/index.t | 42 +++ contrib/perl5/t/op/int.t | 17 ++ contrib/perl5/t/op/join.t | 12 + contrib/perl5/t/op/list.t | 83 ++++++ contrib/perl5/t/op/local.t | 200 +++++++++++++ contrib/perl5/t/op/magic.t | 209 +++++++++++++ contrib/perl5/t/op/method.t | 128 ++++++++ contrib/perl5/t/op/misc.t | 420 +++++++++++++++++++++++++++ contrib/perl5/t/op/mkdir.t | 18 ++ contrib/perl5/t/op/my.t | 94 ++++++ contrib/perl5/t/op/nothread.t | 35 +++ contrib/perl5/t/op/oct.t | 14 + contrib/perl5/t/op/ord.t | 18 ++ contrib/perl5/t/op/pack.t | 205 +++++++++++++ contrib/perl5/t/op/pat.t | 597 ++++++++++++++++++++++++++++++++++++++ contrib/perl5/t/op/pos.t | 16 + contrib/perl5/t/op/push.t | 56 ++++ contrib/perl5/t/op/quotemeta.t | 38 +++ contrib/perl5/t/op/rand.t | 348 ++++++++++++++++++++++ contrib/perl5/t/op/range.t | 48 +++ contrib/perl5/t/op/re_tests | 485 +++++++++++++++++++++++++++++++ contrib/perl5/t/op/read.t | 19 ++ contrib/perl5/t/op/readdir.t | 25 ++ contrib/perl5/t/op/recurse.t | 86 ++++++ contrib/perl5/t/op/ref.t | 287 ++++++++++++++++++ contrib/perl5/t/op/regexp.t | 97 +++++++ contrib/perl5/t/op/regexp_noamp.t | 10 + contrib/perl5/t/op/repeat.t | 42 +++ contrib/perl5/t/op/runlevel.t | 317 ++++++++++++++++++++ contrib/perl5/t/op/sleep.t | 8 + contrib/perl5/t/op/sort.t | 127 ++++++++ contrib/perl5/t/op/splice.t | 34 +++ contrib/perl5/t/op/split.t | 113 ++++++++ contrib/perl5/t/op/sprintf.t | 33 +++ contrib/perl5/t/op/stat.t | 252 ++++++++++++++++ contrib/perl5/t/op/study.t | 69 +++++ contrib/perl5/t/op/subst.t | 310 ++++++++++++++++++++ contrib/perl5/t/op/substr.t | 211 ++++++++++++++ contrib/perl5/t/op/sysio.t | 194 +++++++++++++ contrib/perl5/t/op/taint.t | 596 +++++++++++++++++++++++++++++++++++++ contrib/perl5/t/op/tie.t | 155 ++++++++++ contrib/perl5/t/op/tiearray.t | 210 ++++++++++++++ contrib/perl5/t/op/tiehandle.t | 137 +++++++++ contrib/perl5/t/op/time.t | 47 +++ contrib/perl5/t/op/undef.t | 56 ++++ contrib/perl5/t/op/universal.t | 104 +++++++ contrib/perl5/t/op/unshift.t | 14 + contrib/perl5/t/op/vec.t | 27 ++ contrib/perl5/t/op/wantarray.t | 16 + contrib/perl5/t/op/write.t | 169 +++++++++++ 80 files changed, 9164 insertions(+) create mode 100755 contrib/perl5/t/op/append.t create mode 100755 contrib/perl5/t/op/arith.t create mode 100755 contrib/perl5/t/op/array.t create mode 100755 contrib/perl5/t/op/assignwarn.t create mode 100755 contrib/perl5/t/op/auto.t create mode 100755 contrib/perl5/t/op/avhv.t create mode 100755 contrib/perl5/t/op/bop.t create mode 100755 contrib/perl5/t/op/chop.t create mode 100755 contrib/perl5/t/op/closure.t create mode 100755 contrib/perl5/t/op/cmp.t create mode 100755 contrib/perl5/t/op/cond.t create mode 100755 contrib/perl5/t/op/context.t create mode 100755 contrib/perl5/t/op/defins.t create mode 100755 contrib/perl5/t/op/delete.t create mode 100755 contrib/perl5/t/op/die.t create mode 100755 contrib/perl5/t/op/die_exit.t create mode 100755 contrib/perl5/t/op/do.t create mode 100755 contrib/perl5/t/op/each.t create mode 100755 contrib/perl5/t/op/eval.t create mode 100755 contrib/perl5/t/op/exec.t create mode 100755 contrib/perl5/t/op/exp.t create mode 100755 contrib/perl5/t/op/flip.t create mode 100755 contrib/perl5/t/op/fork.t create mode 100755 contrib/perl5/t/op/glob.t create mode 100755 contrib/perl5/t/op/goto.t create mode 100755 contrib/perl5/t/op/goto_xs.t create mode 100755 contrib/perl5/t/op/groups.t create mode 100755 contrib/perl5/t/op/gv.t create mode 100755 contrib/perl5/t/op/hashwarn.t create mode 100755 contrib/perl5/t/op/inc.t create mode 100755 contrib/perl5/t/op/index.t create mode 100755 contrib/perl5/t/op/int.t create mode 100755 contrib/perl5/t/op/join.t create mode 100755 contrib/perl5/t/op/list.t create mode 100755 contrib/perl5/t/op/local.t create mode 100755 contrib/perl5/t/op/magic.t create mode 100755 contrib/perl5/t/op/method.t create mode 100755 contrib/perl5/t/op/misc.t create mode 100755 contrib/perl5/t/op/mkdir.t create mode 100755 contrib/perl5/t/op/my.t create mode 100755 contrib/perl5/t/op/nothread.t create mode 100755 contrib/perl5/t/op/oct.t create mode 100755 contrib/perl5/t/op/ord.t create mode 100755 contrib/perl5/t/op/pack.t create mode 100755 contrib/perl5/t/op/pat.t create mode 100755 contrib/perl5/t/op/pos.t create mode 100755 contrib/perl5/t/op/push.t create mode 100755 contrib/perl5/t/op/quotemeta.t create mode 100755 contrib/perl5/t/op/rand.t create mode 100755 contrib/perl5/t/op/range.t create mode 100644 contrib/perl5/t/op/re_tests create mode 100755 contrib/perl5/t/op/read.t create mode 100755 contrib/perl5/t/op/readdir.t create mode 100755 contrib/perl5/t/op/recurse.t create mode 100755 contrib/perl5/t/op/ref.t create mode 100755 contrib/perl5/t/op/regexp.t create mode 100755 contrib/perl5/t/op/regexp_noamp.t create mode 100755 contrib/perl5/t/op/repeat.t create mode 100755 contrib/perl5/t/op/runlevel.t create mode 100755 contrib/perl5/t/op/sleep.t create mode 100755 contrib/perl5/t/op/sort.t create mode 100755 contrib/perl5/t/op/splice.t create mode 100755 contrib/perl5/t/op/split.t create mode 100755 contrib/perl5/t/op/sprintf.t create mode 100755 contrib/perl5/t/op/stat.t create mode 100755 contrib/perl5/t/op/study.t create mode 100755 contrib/perl5/t/op/subst.t create mode 100755 contrib/perl5/t/op/substr.t create mode 100755 contrib/perl5/t/op/sysio.t create mode 100755 contrib/perl5/t/op/taint.t create mode 100755 contrib/perl5/t/op/tie.t create mode 100755 contrib/perl5/t/op/tiearray.t create mode 100755 contrib/perl5/t/op/tiehandle.t create mode 100755 contrib/perl5/t/op/time.t create mode 100755 contrib/perl5/t/op/undef.t create mode 100755 contrib/perl5/t/op/universal.t create mode 100755 contrib/perl5/t/op/unshift.t create mode 100755 contrib/perl5/t/op/vec.t create mode 100755 contrib/perl5/t/op/wantarray.t create mode 100755 contrib/perl5/t/op/write.t (limited to 'contrib/perl5/t/op') diff --git a/contrib/perl5/t/op/append.t b/contrib/perl5/t/op/append.t new file mode 100755 index 0000000..d115146 --- /dev/null +++ b/contrib/perl5/t/op/append.t @@ -0,0 +1,21 @@ +#!./perl + +# $RCSfile: append.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:36 $ + +print "1..3\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";} diff --git a/contrib/perl5/t/op/arith.t b/contrib/perl5/t/op/arith.t new file mode 100755 index 0000000..43af807 --- /dev/null +++ b/contrib/perl5/t/op/arith.t @@ -0,0 +1,12 @@ +#!./perl + +print "1..4\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; diff --git a/contrib/perl5/t/op/array.t b/contrib/perl5/t/op/array.t new file mode 100755 index 0000000..8dea44d --- /dev/null +++ b/contrib/perl5/t/op/array.t @@ -0,0 +1,208 @@ +#!./perl + +print "1..63\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 bar burbl blah); +t("@foo" eq "foo bar burbl 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 +} + diff --git a/contrib/perl5/t/op/assignwarn.t b/contrib/perl5/t/op/assignwarn.t new file mode 100755 index 0000000..57e89c4 --- /dev/null +++ b/contrib/perl5/t/op/assignwarn.t @@ -0,0 +1,61 @@ +#!./perl + +# +# Verify which OP= operators warn if their targets are undefined. +# Based on redef.t, contributed by Graham Barr +# -- Robin Barker +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use strict; + +$^W = 1; +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..23\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; } + +ok 23, $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/auto.t b/contrib/perl5/t/op/auto.t new file mode 100755 index 0000000..2eb0097 --- /dev/null +++ b/contrib/perl5/t/op/auto.t @@ -0,0 +1,52 @@ +#!./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 new file mode 100755 index 0000000..55cc992 --- /dev/null +++ b/contrib/perl5/t/op/avhv.t @@ -0,0 +1,110 @@ +#!./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..12\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"; + diff --git a/contrib/perl5/t/op/bop.t b/contrib/perl5/t/op/bop.t new file mode 100755 index 0000000..b247341 --- /dev/null +++ b/contrib/perl5/t/op/bop.t @@ -0,0 +1,64 @@ +#!./perl + +# +# test the bit operators '&', '|', '^', '~', '<<', and '>>' +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..18\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; $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"); + diff --git a/contrib/perl5/t/op/chop.t b/contrib/perl5/t/op/chop.t new file mode 100755 index 0000000..77263ad --- /dev/null +++ b/contrib/perl5/t/op/chop.t @@ -0,0 +1,87 @@ +#!./perl + +# $RCSfile: chop.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:40 $ + +print "1..28\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"; diff --git a/contrib/perl5/t/op/closure.t b/contrib/perl5/t/op/closure.t new file mode 100755 index 0000000..95d44f5 --- /dev/null +++ b/contrib/perl5/t/op/closure.t @@ -0,0 +1,482 @@ +#!./perl +# -*- Mode: Perl -*- +# closure.t: +# Original written by Ulrich Pfeifer on 2 Jan 1997. +# Greatly extended by Tom Phoenix on 28 Jan 1997. +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Config; + +print "1..169\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) +}; + +# Additional tests by Tom Phoenix . + +{ + 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 '', ; + $errors = join '', ; } + 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 '', } + close PERL; + } else { + my $outfile = "tout$$"; $outfile++ while -e $outfile; + push @tmpfiles, $outfile; + system "$cmd >$outfile"; + { local $/; open IN, $outfile; $output = ; 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 = ; 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 new file mode 100755 index 0000000..4a7e68d --- /dev/null +++ b/contrib/perl5/t/op/cmp.t @@ -0,0 +1,35 @@ +#!./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/cond.t b/contrib/perl5/t/op/cond.t new file mode 100755 index 0000000..427efb4 --- /dev/null +++ b/contrib/perl5/t/op/cond.t @@ -0,0 +1,12 @@ +#!./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 new file mode 100755 index 0000000..4625441 --- /dev/null +++ b/contrib/perl5/t/op/context.t @@ -0,0 +1,18 @@ +#!./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 new file mode 100755 index 0000000..33c74ea --- /dev/null +++ b/contrib/perl5/t/op/defins.t @@ -0,0 +1,147 @@ +#!./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 = ) + { + $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 = ); + +print "not " unless $seen; +print "ok 3\n"; + + +seek(FILE,0,0); +$seen = 0; +while (($seen ? $dummy : $name) = ) + { + $seen++ if $name eq '0'; + } +print "not " unless $seen; +print "ok 4\n"; + +seek(FILE,0,0); +$seen = 0; +my %where; +while ($where{$seen} = ) + { + $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 new file mode 100755 index 0000000..6cc4475 --- /dev/null +++ b/contrib/perl5/t/op/delete.t @@ -0,0 +1,51 @@ +#!./perl + +# $RCSfile: delete.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:44 $ + +print "1..16\n"; + +$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";} +if ($foo{2} eq '') {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";} +if ($foo{4} eq '') {print "ok 10\n";} else {print "not ok 10 $foo{4}\n";} +if ($foo{5} eq '') {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"; diff --git a/contrib/perl5/t/op/die.t b/contrib/perl5/t/op/die.t new file mode 100755 index 0000000..d473ed6 --- /dev/null +++ b/contrib/perl5/t/op/die.t @@ -0,0 +1,43 @@ +#!./perl + +print "1..10\n"; + +$SIG{__DIE__} = sub { print ref($_[0]) ? ("ok ",$_[0]->[0]++,"\n") : @_ } ; + +$err = "ok 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 new file mode 100755 index 0000000..ffbb1e0 --- /dev/null +++ b/contrib/perl5/t/op/die_exit.t @@ -0,0 +1,53 @@ +#!./perl + +# +# Verify that C return the return code +# -- Robin Barker +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -e '../lib'; +} +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 => [ 42, 42, '{ local *F; open F, q[TEST]; close F } 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\nnot ", $exit, $bang, $query + 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 new file mode 100755 index 0000000..87ec08d --- /dev/null +++ b/contrib/perl5/t/op/do.t @@ -0,0 +1,44 @@ +#!./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 new file mode 100755 index 0000000..9063c2c --- /dev/null +++ b/contrib/perl5/t/op/each.t @@ -0,0 +1,122 @@ +#!./perl + +# $RCSfile: each.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:47 $ + +print "1..16\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" } diff --git a/contrib/perl5/t/op/eval.t b/contrib/perl5/t/op/eval.t new file mode 100755 index 0000000..9368281 --- /dev/null +++ b/contrib/perl5/t/op/eval.t @@ -0,0 +1,81 @@ +#!./perl + +# $RCSfile: eval.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:48 $ + +print "1..23\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(); +} diff --git a/contrib/perl5/t/op/exec.t b/contrib/perl5/t/op/exec.t new file mode 100755 index 0000000..098a455 --- /dev/null +++ b/contrib/perl5/t/op/exec.t @@ -0,0 +1,35 @@ +#!./perl + +# $RCSfile: exec.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:49 $ + +$| = 1; # flush stdout + +if ($^O eq 'MSWin32') { + print "# exec is unsupported on Win32\n"; + # XXX the system tests could be written to use ./perl and so work on Win32 + print "1..0\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 ((system "/bin/sh -c 'exit 1'") != 256) { print "not "; } +print "ok 5\n"; + +if ((system "lskdfj") == 255 << 8) {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/exp.t b/contrib/perl5/t/op/exp.t new file mode 100755 index 0000000..5efc9ba --- /dev/null +++ b/contrib/perl5/t/op/exp.t @@ -0,0 +1,27 @@ +#!./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/flip.t b/contrib/perl5/t/op/flip.t new file mode 100755 index 0000000..20167f3 --- /dev/null +++ b/contrib/perl5/t/op/flip.t @@ -0,0 +1,29 @@ +#!./perl + +# $RCSfile: flip.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:52 $ + +print "1..9\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,'../Configure'); +while () { + (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";} diff --git a/contrib/perl5/t/op/fork.t b/contrib/perl5/t/op/fork.t new file mode 100755 index 0000000..9790ff0 --- /dev/null +++ b/contrib/perl5/t/op/fork.t @@ -0,0 +1,26 @@ +#!./perl + +# $RCSfile: fork.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:53 $ + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + unless ($Config{'d_fork'}) { + print "1..0\n"; + exit 0; + } +} + +$| = 1; +print "1..2\n"; + +if ($cid = fork) { + sleep 2; + if ($result = (kill 9, $cid)) {print "ok 2\n";} else {print "not ok 2 $result\n";} +} +else { + $| = 1; + print "ok 1\n"; + sleep 10; +} diff --git a/contrib/perl5/t/op/glob.t b/contrib/perl5/t/op/glob.t new file mode 100755 index 0000000..253e4a3 --- /dev/null +++ b/contrib/perl5/t/op/glob.t @@ -0,0 +1,37 @@ +#!./perl + +# $RCSfile: glob.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:55 $ + +print "1..6\n"; + +@oops = @ops = ; + +if ($^O eq 'MSWin32') { + map { $files{lc($_)}++ } ; + map { delete $files{"op/$_"} } split /[\s\n]/, `cmd /c "dir /b /l op & dir /b /l /ah op 2>nul"`, +} +else { + map { $files{$_}++ } ; + 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 () { + $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 new file mode 100755 index 0000000..1b34acd --- /dev/null +++ b/contrib/perl5/t/op/goto.t @@ -0,0 +1,90 @@ +#!./perl + +# $RCSfile: goto.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:56 $ + +# "This IS structured code. It's just randomly structured." + +print "1..9\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'; +$x = `$PERL -e "goto foo;" 2>&1`; +if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. -e "goto foo;"`; } + +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 9\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"; + +$wherever = FINALE; +goto $wherever; diff --git a/contrib/perl5/t/op/goto_xs.t b/contrib/perl5/t/op/goto_xs.t new file mode 100755 index 0000000..a35575e --- /dev/null +++ b/contrib/perl5/t/op/goto_xs.t @@ -0,0 +1,98 @@ +#!./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/groups.t b/contrib/perl5/t/op/groups.t new file mode 100755 index 0000000..47aabe3 --- /dev/null +++ b/contrib/perl5/t/op/groups.t @@ -0,0 +1,50 @@ +#!./perl + +if (! -x ($groups = '/usr/ucb/groups') && + ! -x ($groups = '/usr/bin/groups') && + ! -x ($groups = '/bin/groups') +) { + print "1..0\n"; + exit 0; +} + +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, $_); + } +} + +$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 new file mode 100755 index 0000000..c253e4b --- /dev/null +++ b/contrib/perl5/t/op/gv.t @@ -0,0 +1,98 @@ +#!./perl + +# +# various typeglob tests +# + +print "1..23\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 } +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] }; + local $^W = 1; + *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"; + + diff --git a/contrib/perl5/t/op/hashwarn.t b/contrib/perl5/t/op/hashwarn.t new file mode 100755 index 0000000..6343a2a --- /dev/null +++ b/contrib/perl5/t/op/hashwarn.t @@ -0,0 +1,71 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use strict; + +use vars qw{ @warnings }; + +BEGIN { + $^W |= 1; # Insist upon warnings + # ...and save 'em as we go + $SIG{'__WARN__'} = sub { push @warnings, @_ }; + $| = 1; + print "1..7\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; + + $_ = { 1..10 }; + test 7, ! @warnings, "Unexpected warning"; +} diff --git a/contrib/perl5/t/op/inc.t b/contrib/perl5/t/op/inc.t new file mode 100755 index 0000000..e5a2a92 --- /dev/null +++ b/contrib/perl5/t/op/inc.t @@ -0,0 +1,52 @@ +#!./perl + + +# $RCSfile$ + +print "1..6\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";} diff --git a/contrib/perl5/t/op/index.t b/contrib/perl5/t/op/index.t new file mode 100755 index 0000000..0b08f08 --- /dev/null +++ b/contrib/perl5/t/op/index.t @@ -0,0 +1,42 @@ +#!./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 new file mode 100755 index 0000000..eb060ac --- /dev/null +++ b/contrib/perl5/t/op/int.t @@ -0,0 +1,17 @@ +#!./perl + +# $RCSfile: int.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:00 $ + +print "1..4\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";} diff --git a/contrib/perl5/t/op/join.t b/contrib/perl5/t/op/join.t new file mode 100755 index 0000000..eec4611 --- /dev/null +++ b/contrib/perl5/t/op/join.t @@ -0,0 +1,12 @@ +#!./perl + +# $RCSfile: join.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:01 $ + +print "1..3\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";} diff --git a/contrib/perl5/t/op/list.t b/contrib/perl5/t/op/list.t new file mode 100755 index 0000000..a4230b6 --- /dev/null +++ b/contrib/perl5/t/op/list.t @@ -0,0 +1,83 @@ +#!./perl + +# $RCSfile: list.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:02 $ + +print "1..27\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; +} + diff --git a/contrib/perl5/t/op/local.t b/contrib/perl5/t/op/local.t new file mode 100755 index 0000000..2f674d1 --- /dev/null +++ b/contrib/perl5/t/op/local.t @@ -0,0 +1,200 @@ +#!./perl + +# $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $ + +print "1..58\n"; + +# XXX known to leak scalars +$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; + +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"; + diff --git a/contrib/perl5/t/op/magic.t b/contrib/perl5/t/op/magic.t new file mode 100755 index 0000000..7f08e06 --- /dev/null +++ b/contrib/perl5/t/op/magic.t @@ -0,0 +1,209 @@ +#!./perl + +BEGIN { + $^W = 1; + $| = 1; + chdir 't' if -d 't'; + @INC = '../lib'; + $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; +} + +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'; +$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`); + } + else { + $wd = '.'; + } + my $perl = "$wd/perl"; + my $headmaybe = ''; + my $tailmaybe = ''; + $script = "$wd/show-shebang"; + if ($Is_MSWin32) { + chomp($wd = `cd`); + $perl = "$wd\\perl.exe"; + $script = "$wd\\show-shebang.bat"; + $headmaybe = <$script"), $!; + ok 20, print(SCRIPT $headmaybe . <= 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}; + $ENV{foo} = "bar"; + %ENV = (); + $ENV{PATH} = $PATH; + 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 "not " }; + $! = 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",1; + ok "33 # skipped",1; + ok "34 # skipped",1; + ok "35 # skipped",1; +} diff --git a/contrib/perl5/t/op/method.t b/contrib/perl5/t/op/method.t new file mode 100755 index 0000000..f1b1888 --- /dev/null +++ b/contrib/perl5/t/op/method.t @@ -0,0 +1,128 @@ +#!./perl + +# +# test method calls and autoloading. +# + +print "1..26\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" +} + +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"); diff --git a/contrib/perl5/t/op/misc.t b/contrib/perl5/t/op/misc.t new file mode 100755 index 0000000..7292ffe --- /dev/null +++ b/contrib/perl5/t/op/misc.t @@ -0,0 +1,420 @@ +#!./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", ; +print "1..", scalar @prgs, "\n"; + +$tmpfile = "misctmp000"; +1 while -f ++$tmpfile; +END { 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/, $_); + if ($^O eq 'MSWin32') { + open TEST, "| .\\perl -I../lib $switch >$tmpfile 2>&1"; + } + else { + open TEST, "| sh -c './perl $switch' >$tmpfile 2>&1"; + } + print TEST $prog, "\n"; + close TEST; + $status = $?; + $results = `$CAT $tmpfile`; + $results =~ s/\n+$//; + $results =~ s/syntax error/syntax error/i; + $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); +$, = " "; +print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, ($cusp + 1) % 8, "!\n"; +EXPECT +7 0 0 1 ! +######## +$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 .= ); +######## +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 = <>); +######## +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 deref in repeat 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 "-- ", , " --\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 at - line 1. +######## +/(?{"{"}})/ # Check it outside of eval too +EXPECT +Unmatched right 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) } +BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" } +END { print "end <",shift,">\nargv <@ARGV>\n" } +INIT { print "init <",shift,">\n" } +EXPECT +argv +begin +init +end +argv <> +######## +-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; +select STDERR; $| = 1; print fileno STDERR; +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 +######## diff --git a/contrib/perl5/t/op/mkdir.t b/contrib/perl5/t/op/mkdir.t new file mode 100755 index 0000000..5ba0a0f --- /dev/null +++ b/contrib/perl5/t/op/mkdir.t @@ -0,0 +1,18 @@ +#!./perl + +# $RCSfile: mkdir.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:06 $ + +print "1..7\n"; + +$^O eq 'MSWin32' ? `del /s /q blurfl 2>&1` : `rm -rf blurfl`; + +# tests 3 and 7 rather naughtily expect English error messages +$ENV{'LC_ALL'} = 'C'; + +print (mkdir('blurfl',0777) ? "ok 1\n" : "not ok 1\n"); +print (mkdir('blurfl',0777) ? "not ok 2\n" : "ok 2\n"); +print ($! =~ /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 ($! =~ /such|exist/ ? "ok 7\n" : "not ok 7\n"); diff --git a/contrib/perl5/t/op/my.t b/contrib/perl5/t/op/my.t new file mode 100755 index 0000000..1777e88 --- /dev/null +++ b/contrib/perl5/t/op/my.t @@ -0,0 +1,94 @@ +#!./perl + +# $RCSfile: my.t,v $ + +print "1..30\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 (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"; + diff --git a/contrib/perl5/t/op/nothread.t b/contrib/perl5/t/op/nothread.t new file mode 100755 index 0000000..a0d444d --- /dev/null +++ b/contrib/perl5/t/op/nothread.t @@ -0,0 +1,35 @@ +#!./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{'usethreads'}) + { + print "1..0\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/oct.t b/contrib/perl5/t/op/oct.t new file mode 100755 index 0000000..24b5c43 --- /dev/null +++ b/contrib/perl5/t/op/oct.t @@ -0,0 +1,14 @@ +#!./perl + +# $RCSfile: oct.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:08 $ + +print "1..8\n"; + +print +(oct('01234') == 01234) ? "ok" : "not ok", " 1\n"; +print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 2\n"; +print +(hex('01234') == 0x1234) ? "ok" : "not ok", " 3\n"; +print +(oct('20000000000') == 020000000000) ? "ok" : "not ok", " 4\n"; +print +(oct('x80000000') == 0x80000000) ? "ok" : "not ok", " 5\n"; +print +(hex('80000000') == 0x80000000) ? "ok" : "not ok", " 6\n"; +print +(oct('1234') == 668) ? "ok" : "not ok", " 7\n"; +print +(hex('1234') == 4660) ? "ok" : "not ok", " 8\n"; diff --git a/contrib/perl5/t/op/ord.t b/contrib/perl5/t/op/ord.t new file mode 100755 index 0000000..ba943f4 --- /dev/null +++ b/contrib/perl5/t/op/ord.t @@ -0,0 +1,18 @@ +#!./perl + +# $RCSfile: ord.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:09 $ + +print "1..3\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";} + +# run time evaluation + +$x = 'ABC'; +if (ord($x) == 65 || ord($x) == 193) {print "ok 2\n";} else {print "not ok 2\n";} + +if (chr 65 == 'A' || chr 193 == 'A') {print "ok 3\n";} else {print "not ok 3\n";} diff --git a/contrib/perl5/t/op/pack.t b/contrib/perl5/t/op/pack.t new file mode 100755 index 0000000..9b7bc35 --- /dev/null +++ b/contrib/perl5/t/op/pack.t @@ -0,0 +1,205 @@ +#!./perl + +# $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $ + +print "1..60\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); +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 ($^O eq 'os390'); # An EBCDIC variant. + +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++ } +{ + local $^W = 1; + 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 + +$in = join "", map { chr } 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'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+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("`&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(" &1F +&8%P: +EOUU + +print "not " unless unpack('u', $uu) eq $in; +print "ok ", $test++, "\n"; + +# 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. diff --git a/contrib/perl5/t/op/pat.t b/contrib/perl5/t/op/pat.t new file mode 100755 index 0000000..7d4278f --- /dev/null +++ b/contrib/perl5/t/op/pat.t @@ -0,0 +1,597 @@ +#!./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..141\n"; + +BEGIN { + chdir 't' if -d 't'; + @INC = "../lib" if -d "../lib"; +} +eval 'use Config'; # Defaults assumed if this fails + +# XXX known to leak scalars +$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; + +$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 = /(? 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; +} + +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++; + +@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 "not " unless $1 eq $ans; + print "ok $test\n"; + $test++; +} + +$_ = 'a'; +foreach $ans ('', 'a', '') { + /^|a|$/g; + print "not " 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++; + + 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++; +} + +{ + 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 $^W; local %SIG; + eval 'BEGIN { $^W = 1; $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=]]/'); +&$for_future('q(a.[b].) =~ /[x[.foo.]]/'); + +# 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++; + diff --git a/contrib/perl5/t/op/pos.t b/contrib/perl5/t/op/pos.t new file mode 100755 index 0000000..46811b7 --- /dev/null +++ b/contrib/perl5/t/op/pos.t @@ -0,0 +1,16 @@ +#!./perl + +print "1..3\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";} + diff --git a/contrib/perl5/t/op/push.t b/contrib/perl5/t/op/push.t new file mode 100755 index 0000000..a67caed --- /dev/null +++ b/contrib/perl5/t/op/push.t @@ -0,0 +1,56 @@ +#!./perl + +# $RCSfile: push.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:13 $ + +@tests = split(/\n/, < 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" if -d "../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); + $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 >= (1 << $randbits)) { # Just in case... + print "not 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 "not 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 ) { + print "ok 11\n"; + last AUTOSRAND; + } + } else { + $first = ; + } + 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 new file mode 100755 index 0000000..7999b86 --- /dev/null +++ b/contrib/perl5/t/op/range.t @@ -0,0 +1,48 @@ +#!./perl + +print "1..10\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"; + diff --git a/contrib/perl5/t/op/re_tests b/contrib/perl5/t/op/re_tests new file mode 100644 index 0000000..a5295f5 --- /dev/null +++ b/contrib/perl5/t/op/re_tests @@ -0,0 +1,485 @@ +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 - /a[b-a]/: invalid [] range in regexp +a[]b - c - /a[]b/: unmatched [] in regexp +a[ - c - /a[/: unmatched [] in regexp +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 - /*a/: ?+*{} follows nothing in regexp +(*)b - c - /(*)b/: ?+*{} follows nothing in regexp +$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 - /abc)/: unmatched () in regexp +(abc - c - /(abc/: unmatched () in regexp +((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 - /a**/: nested *?+ in regexp +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 () in regexp +[^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 - /\1/: reference to nonexistent group +\2 - c - /\2/: reference to nonexistent group +(a)|\1 a y - - +(a)|\1 x n - - +(a)|\2 - c - /(a)|\2/: 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 - /a[b-a]/: invalid [] range in regexp +'a[]b'i - c - /a[]b/: unmatched [] in regexp +'a['i - c - /a[/: unmatched [] in regexp +'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 - /*a/: ?+*{} follows nothing in regexp +'(*)b'i - c - /(*)b/: ?+*{} follows nothing in regexp +'$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 - /abc)/: unmatched () in regexp +'(abc'i - c - /(abc/: unmatched () in regexp +'((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 - /a**/: nested *?+ in regexp +'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 () in regexp +'[^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 - - +(?:(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 - - +(?a+)ab aaab n - - +(?>a+)b aaab y - - +([[:]+) a:[b]: y $1 :[ +([[=]+) a=[b]= y $1 =[ +([[.]+) a.[b]. y $1 .[ +[a[:xyz: - c - /[a[:xyz:/: unmatched [] in regexp +[a[:xyz:] - c - /[a[:xyz:]/: unmatched [] in regexp +([a[:xyz:]b]+) pbaq y $1 ba +((?>a+)b) aaab y $1 aaab +(?>(a+))b aaab y $1 aaa +((?>[^()]+)|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x +(?<=x+)y - c - /(?<=x+)y/: variable length lookbehind not implemented +a{37,17} - c - /a{37,17}/: Can't do {n,m} with n > m +a\Z a\nb\n n - - +b\Z a\nb\n y - - +b\z a\nb\n n - - +b\Z a\nb y - - +b\z a\nb y - - diff --git a/contrib/perl5/t/op/read.t b/contrib/perl5/t/op/read.t new file mode 100755 index 0000000..2746970 --- /dev/null +++ b/contrib/perl5/t/op/read.t @@ -0,0 +1,19 @@ +#!./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 new file mode 100755 index 0000000..ca19ebc --- /dev/null +++ b/contrib/perl5/t/op/readdir.t @@ -0,0 +1,25 @@ +#!./perl + +eval 'opendir(NOSUCH, "no/such/directory");'; +if ($@) { print "1..0\n"; exit; } + +print "1..3\n"; + +if (opendir(OP, "op")) { print "ok 1\n"; } else { print "not ok 1\n"; } +@D = grep(/^[^\.].*\.t$/i, readdir(OP)); +closedir(OP); + +if (@D > 20 && @D < 100) { print "ok 2\n"; } else { print "not ok 2\n"; } + +@R = sort @D; +@G = sort ; +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,); +} +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 new file mode 100755 index 0000000..6594940 --- /dev/null +++ b/contrib/perl5/t/op/recurse.t @@ -0,0 +1,86 @@ +#!./perl + +# +# test recursive functions. +# + +print "1..23\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"; diff --git a/contrib/perl5/t/op/ref.t b/contrib/perl5/t/op/ref.t new file mode 100755 index 0000000..1d70f9f --- /dev/null +++ b/contrib/perl5/t/op/ref.t @@ -0,0 +1,287 @@ +#!./perl + +print "1..55\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 global destruction + +package FINALE; + +{ + $ref3 = bless ["ok 55\n"]; # package destruction + my $ref2 = bless ["ok 54\n"]; # lexical destruction + local $ref1 = bless ["ok 53\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 new file mode 100755 index 0000000..11b3ee3 --- /dev/null +++ b/contrib/perl5/t/op/regexp.t @@ -0,0 +1,97 @@ +#!./perl + +# XXX known to leak scalars +$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; + +# 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 +# +# Columns 4 and 5 are used only if column 3 contains C or 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. +# +# \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' if -d '../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 () { } +$numtests = $.; +seek(TESTS,0,0); +$. = 0; + +$bang = sprintf "\\%03o", ord "!"; # \41 would not be portable. + +$| = 1; +print "1..$numtests\n# $iters iterations\n"; +TEST: +while () { + chomp; + s/\\n/\n/g; + ($pat, $subject, $result, $repl, $expect) = split(/\t/,$_); + $input = join(':',$pat,$subject,$result,$repl,$expect); + infty_subst(\$pat); + infty_subst(\$expect); + $pat = "'$pat'" unless $pat =~ /^[:']/; + $pat =~ s/\\n/\n/g; + $pat =~ s/(\$\{\w+\})/$1/eeg; + $subject =~ s/\\n/\n/g; + $expect =~ s/\\n/\n/g; + $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/; + 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 ($@) { + 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 new file mode 100755 index 0000000..03c19e9 --- /dev/null +++ b/contrib/perl5/t/op/regexp_noamp.t @@ -0,0 +1,10 @@ +#!./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/repeat.t b/contrib/perl5/t/op/repeat.t new file mode 100755 index 0000000..54fa590 --- /dev/null +++ b/contrib/perl5/t/op/repeat.t @@ -0,0 +1,42 @@ +#!./perl + +# $RCSfile: repeat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:21 $ + +print "1..19\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"; diff --git a/contrib/perl5/t/op/runlevel.t b/contrib/perl5/t/op/runlevel.t new file mode 100755 index 0000000..307e2a0 --- /dev/null +++ b/contrib/perl5/t/op/runlevel.t @@ -0,0 +1,317 @@ +#!./perl + +## +## Many of these tests are originally from Michael Schroeder +## +## Adapted and expanded by Gurusamy Sarathy +## + +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", ; +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` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + `sh -c './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 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" outside a 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 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 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 diff --git a/contrib/perl5/t/op/sleep.t b/contrib/perl5/t/op/sleep.t new file mode 100755 index 0000000..5f6c4c0 --- /dev/null +++ b/contrib/perl5/t/op/sleep.t @@ -0,0 +1,8 @@ +#!./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 new file mode 100755 index 0000000..70341b9 --- /dev/null +++ b/contrib/perl5/t/op/sort.t @@ -0,0 +1,127 @@ +#!./perl + +# $RCSfile: sort.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:24 $ + +print "1..21\n"; + +sub backwards { $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 @george, 'to', @harry); +$expected = $upperfirst ? + 'AbelAxedCaincatchaseddoggonepunishedtoxyz' : + 'catchaseddoggonepunishedtoxyzAbelAxedCain' ; +print "# 3: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ?"ok 3\n":"not ok 3\n"); + +@a = (); +@b = reverse @a; +print ("@b" eq "" ? "ok 4\n" : "not ok 4 (@b)\n"); + +@a = (1); +@b = reverse @a; +print ("@b" eq "1" ? "ok 5\n" : "not ok 5 (@b)\n"); + +@a = (1,2); +@b = reverse @a; +print ("@b" eq "2 1" ? "ok 6\n" : "not ok 6 (@b)\n"); + +@a = (1,2,3); +@b = reverse @a; +print ("@b" eq "3 2 1" ? "ok 7\n" : "not ok 7 (@b)\n"); + +@a = (1,2,3,4); +@b = reverse @a; +print ("@b" eq "4 3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n"); + +@a = (10,2,3,4); +@b = sort {$a <=> $b;} @a; +print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n"); + +$sub = 'backwards'; +$x = join('', sort $sub @harry); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print "# 10: x = $x, expected = '$expected'\n"; +print ($x eq $expected ? "ok 10\n" : "not ok 10\n"); + +# literals, combinations + +@b = sort (4,1,3,2); +print ("@b" eq '1 2 3 4' ? "ok 11\n" : "not ok 11\n"); +print "# x = '@b'\n"; + +@b = sort grep { $_ } (4,1,3,2); +print ("@b" eq '1 2 3 4' ? "ok 12\n" : "not ok 12\n"); +print "# x = '@b'\n"; + +@b = sort map { $_ } (4,1,3,2); +print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n"); +print "# x = '@b'\n"; + +@b = sort reverse (4,1,3,2); +print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); +print "# x = '@b'\n"; + +$^W = 0; +# 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 15\n" : "not ok 15\n"); + +# redefining sort subs outside the sort should not fail +eval { *twoface = sub { &backwards } }; +print $@ ? "not ok 16\n" : "ok 16\n"; + +eval { @b = sort twoface 4,1,3,2 }; +print ("@b" eq '4 3 2 1' ? "ok 17\n" : "not ok 17 |@b|\n"); + +*twoface = sub { *twoface = *backwards; $a <=> $b }; +eval { @b = sort twoface 4,1 }; +print ($@ =~ /redefine active sort/ ? "ok 18\n" : "not ok 18\n"); + +*twoface = sub { + eval 'sub twoface { $a <=> $b }'; + die($@ =~ /redefine active sort/ ? "ok 19\n" : "not ok 19\n"); + $a <=> $b; + }; +eval { @b = sort twoface 4,1 }; +print $@ ? "$@" : "not ok 19\n"; + +eval <<'CODE'; + my @result = sort main'backwards 'one', 'two'; +CODE +print $@ ? "not ok 20\n# $@" : "ok 20\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 21\n# $@" : "ok 21\n"; diff --git a/contrib/perl5/t/op/splice.t b/contrib/perl5/t/op/splice.t new file mode 100755 index 0000000..06e3509 --- /dev/null +++ b/contrib/perl5/t/op/splice.t @@ -0,0 +1,34 @@ +#!./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 new file mode 100755 index 0000000..7f0acce --- /dev/null +++ b/contrib/perl5/t/op/split.t @@ -0,0 +1,113 @@ +#!./perl + +# $RCSfile: split.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:26 $ + +print "1..25\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` } +else { $foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1` } +if ($foo =~ /DCL-W-NOCOMD/) { + $foo = `\$ mcr sys\$disk:[]perl. "-D1024" -e "(\$a,\$b) = split;"`; +} +print $foo =~ /DEBUGGING/ || $foo =~ /SV = 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";} diff --git a/contrib/perl5/t/op/sprintf.t b/contrib/perl5/t/op/sprintf.t new file mode 100755 index 0000000..b9b4751 --- /dev/null +++ b/contrib/perl5/t/op/sprintf.t @@ -0,0 +1,33 @@ +#!./perl + +# $RCSfile: sprintf.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:27 $ + +print "1..4\n"; + +$^W = 1; +$SIG{__WARN__} = sub { + if ($_[0] =~ /^Invalid conversion/) { + $w++; + } else { + warn @_; + } +}; + +$w = 0; +$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f","hi",123,0,456,0,ord('A'),3.0999); +if ($x eq ' hi 123 %foo 456 0A3.1' && $w == 0) { + print "ok 1\n"; +} else { + print "not ok 1 '$x'\n"; +} + +for $i (2 .. 4) { + $f = ('%6 .6s', '%6. 6s', '%6.6 s')[$i - 2]; + $w = 0; + $x = sprintf($f, ''); + if ($x eq $f && $w == 1) { + print "ok $i\n"; + } else { + print "not ok $i '$x' '$f' '$w'\n"; + } +} diff --git a/contrib/perl5/t/op/stat.t b/contrib/perl5/t/op/stat.t new file mode 100755 index 0000000..2207b40 --- /dev/null +++ b/contrib/perl5/t/op/stat.t @@ -0,0 +1,252 @@ +#!./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; +chop($cwd = ($Is_MSWin32 ? `cd` : `pwd`)); + +$DEV = `ls -l /dev` unless $Is_Dosish; + +unlink "Op.stat.tmp"; +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 "not ok 1\n";} +if ($Is_MSWin32 || ($mtime && $mtime == $ctime)) {print "ok 2\n";} +else {print "# |$mtime| vs |$ctime|\nnot ok 2\n";} + +print FOO "Now is the time for all good men to come to.\n"; +close(FOO); + +sleep 2; + +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 + || ($cwd =~ m#^/tmp# and $mtime && $mtime==$ctime) # Solaris tmpfs bug + || $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 :$mtime: should != :$ctime:\n"; + +unlink "Op.stat.tmp"; +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'; +$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 +} + +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 'amigaos' or $Is_Dosish) { + 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; +($bin) = grep {-d} ($^O eq 'machten' ? qw(/usr/bin /bin) : qw(/bin /usr/bin)) + or print ("not ok 35\n"), goto tty_test; +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 { + unless (open(tty,"/dev/tty")) { + print STDERR "Can't open /dev/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); + } + 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";} + $_ = ; + 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'); + $_ = ; + 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'; diff --git a/contrib/perl5/t/op/study.t b/contrib/perl5/t/op/study.t new file mode 100755 index 0000000..ea3b366 --- /dev/null +++ b/contrib/perl5/t/op/study.t @@ -0,0 +1,69 @@ +#!./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 new file mode 100755 index 0000000..afa06ab --- /dev/null +++ b/contrib/perl5/t/op/subst.t @@ -0,0 +1,310 @@ +#!./perl + +print "1..71\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 ($^O eq 'os390') { # An EBCDIC variant. + 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/(?/g; +$foo = '<>' . ('<>' x 20) ; +print ($_ eq $foo ? "ok 71\n" : "not ok 71\n#'$_'\n#'$foo'\n"); diff --git a/contrib/perl5/t/op/substr.t b/contrib/perl5/t/op/substr.t new file mode 100755 index 0000000..87efcb4 --- /dev/null +++ b/contrib/perl5/t/op/substr.t @@ -0,0 +1,211 @@ +#!./perl + +print "1..106\n"; + +#P = start of string Q = start of substr R = end of substr S = end of string + +$a = 'abcdefxyz'; +BEGIN { $^W = 1 }; + +$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 fail { !defined(shift) && $w-- }; + +print (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n"); # P=Q R S +print (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n"); # P Q R S +print (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n"); # P Q S R +print (fail(substr($a,999,999)) ? "ok 4\n" : "not ok 4\n"); # P R Q S +print (substr($a,0,-6) eq 'abc' ? "ok 5\n" : "not ok 5\n"); # P=Q R S +print (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n"); # P Q R S + +$[ = 1; + +print (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n"); # P=Q R S +print (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n"); # P Q R S +print (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n"); # P Q S R +print (fail(substr($a,999,999)) ? "ok 10\n" : "not ok 10\n");# P R Q S +print (substr($a,1,-6) eq 'abc' ? "ok 11\n" : "not ok 11\n");# P=Q R S +print (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n"); # P Q R S + +$[ = 0; + +substr($a,3,3) = 'XYZ'; +print $a eq 'abcXYZxyz' ? "ok 13\n" : "not ok 13\n"; +substr($a,0,2) = ''; +print $a eq 'cXYZxyz' ? "ok 14\n" : "not ok 14\n"; +substr($a,0,0) = 'ab'; +print $a eq 'abcXYZxyz' ? "ok 15\n" : "not ok 15 $a\n"; +substr($a,0,0) = '12345678'; +print $a eq '12345678abcXYZxyz' ? "ok 16\n" : "not ok 16\n"; +substr($a,-3,3) = 'def'; +print $a eq '12345678abcXYZdef' ? "ok 17\n" : "not ok 17\n"; +substr($a,-3,3) = '<'; +print $a eq '12345678abcXYZ<' ? "ok 18\n" : "not ok 18\n"; +substr($a,-1,1) = '12345678'; +print $a eq '12345678abcXYZ12345678' ? "ok 19\n" : "not ok 19\n"; + +$a = 'abcdefxyz'; + +print (substr($a,6) eq 'xyz' ? "ok 20\n" : "not ok 20\n"); # P Q R=S +print (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n"); # P Q R=S +print (fail(substr($a,999)) ? "ok 22\n" : "not ok 22\n"); # P R=S Q +print (substr($a,0) eq 'abcdefxyz' ? "ok 23\n" : "not ok 23\n");# P=Q R=S +print (substr($a,9) eq '' ? "ok 24\n" : "not ok 24\n"); # P Q=R=S +print (substr($a,-11) eq 'abcdefxyz' ? "ok 25\n" : "not ok 25\n");# Q P R=S +print (substr($a,-9) eq 'abcdefxyz' ? "ok 26\n" : "not ok 26\n"); # P=Q R=S + +$a = '54321'; + +print (fail(substr($a,-7, 1)) ? "ok 27\n" : "not ok 27\n"); # Q R P S +print (fail(substr($a,-7,-6)) ? "ok 28\n" : "not ok 28\n"); # Q R P S +print (substr($a,-5,-7) eq '' ? "ok 29\n" : "not ok 29\n"); # R P=Q S +print (substr($a, 2,-7) eq '' ? "ok 30\n" : "not ok 30\n"); # R P Q S +print (substr($a,-3,-7) eq '' ? "ok 31\n" : "not ok 31\n"); # R P Q S +print (substr($a, 2,-5) eq '' ? "ok 32\n" : "not ok 32\n"); # P=R Q S +print (substr($a,-3,-5) eq '' ? "ok 33\n" : "not ok 33\n"); # P=R Q S +print (substr($a, 2,-4) eq '' ? "ok 34\n" : "not ok 34\n"); # P R Q S +print (substr($a,-3,-4) eq '' ? "ok 35\n" : "not ok 35\n"); # P R Q S +print (substr($a, 5,-6) eq '' ? "ok 36\n" : "not ok 36\n"); # R P Q=S +print (substr($a, 5,-5) eq '' ? "ok 37\n" : "not ok 37\n"); # P=R Q S +print (substr($a, 5,-3) eq '' ? "ok 38\n" : "not ok 38\n"); # P R Q=S +print (fail(substr($a, 7,-7)) ? "ok 39\n" : "not ok 39\n"); # R P S Q +print (fail(substr($a, 7,-5)) ? "ok 40\n" : "not ok 40\n"); # P=R S Q +print (fail(substr($a, 7,-3)) ? "ok 41\n" : "not ok 41\n"); # P R S Q +print (fail(substr($a, 7, 0)) ? "ok 42\n" : "not ok 42\n"); # P S Q=R + +print (substr($a,-7,2) eq '' ? "ok 43\n" : "not ok 43\n"); # Q P=R S +print (substr($a,-7,4) eq '54' ? "ok 44\n" : "not ok 44\n"); # Q P R S +print (substr($a,-7,7) eq '54321' ? "ok 45\n" : "not ok 45\n");# Q P R=S +print (substr($a,-7,9) eq '54321' ? "ok 46\n" : "not ok 46\n");# Q P S R +print (substr($a,-5,0) eq '' ? "ok 47\n" : "not ok 47\n"); # P=Q=R S +print (substr($a,-5,3) eq '543' ? "ok 48\n" : "not ok 48\n");# P=Q R S +print (substr($a,-5,5) eq '54321' ? "ok 49\n" : "not ok 49\n");# P=Q R=S +print (substr($a,-5,7) eq '54321' ? "ok 50\n" : "not ok 50\n");# P=Q S R +print (substr($a,-3,0) eq '' ? "ok 51\n" : "not ok 51\n"); # P Q=R S +print (substr($a,-3,3) eq '321' ? "ok 52\n" : "not ok 52\n");# P Q R=S +print (substr($a,-2,3) eq '21' ? "ok 53\n" : "not ok 53\n"); # P Q S R +print (substr($a,0,-5) eq '' ? "ok 54\n" : "not ok 54\n"); # P=Q=R S +print (substr($a,2,-3) eq '' ? "ok 55\n" : "not ok 55\n"); # P Q=R S +print (substr($a,0,0) eq '' ? "ok 56\n" : "not ok 56\n"); # P=Q=R S +print (substr($a,0,5) eq '54321' ? "ok 57\n" : "not ok 57\n");# P=Q R=S +print (substr($a,0,7) eq '54321' ? "ok 58\n" : "not ok 58\n");# P=Q S R +print (substr($a,2,0) eq '' ? "ok 59\n" : "not ok 59\n"); # P Q=R S +print (substr($a,2,3) eq '321' ? "ok 60\n" : "not ok 60\n"); # P Q R=S +print (substr($a,5,0) eq '' ? "ok 61\n" : "not ok 61\n"); # P Q=R=S +print (substr($a,5,2) eq '' ? "ok 62\n" : "not ok 62\n"); # P Q=S R +print (substr($a,-7,-5) eq '' ? "ok 63\n" : "not ok 63\n"); # Q P=R S +print (substr($a,-7,-2) eq '543' ? "ok 64\n" : "not ok 64\n");# Q P R S +print (substr($a,-5,-5) eq '' ? "ok 65\n" : "not ok 65\n"); # P=Q=R S +print (substr($a,-5,-2) eq '543' ? "ok 66\n" : "not ok 66\n");# P=Q R S +print (substr($a,-3,-3) eq '' ? "ok 67\n" : "not ok 67\n"); # P Q=R S +print (substr($a,-3,-1) eq '32' ? "ok 68\n" : "not ok 68\n");# P Q R S + +$a = ''; + +print (substr($a,-2,2) eq '' ? "ok 69\n" : "not ok 69\n"); # Q P=R=S +print (substr($a,0,0) eq '' ? "ok 70\n" : "not ok 70\n"); # P=Q=R=S +print (substr($a,0,1) eq '' ? "ok 71\n" : "not ok 71\n"); # P=Q=S R +print (substr($a,-2,3) eq '' ? "ok 72\n" : "not ok 72\n"); # Q P=S R +print (substr($a,-2) eq '' ? "ok 73\n" : "not ok 73\n"); # Q P=R=S +print (substr($a,0) eq '' ? "ok 74\n" : "not ok 74\n"); # P=Q=R=S + + +print (substr($a,0,-1) eq '' ? "ok 75\n" : "not ok 75\n"); # R P=Q=S +print (fail(substr($a,-2,0)) ? "ok 76\n" : "not ok 76\n"); # Q=R P=S +print (fail(substr($a,-2,1)) ? "ok 77\n" : "not ok 77\n"); # Q R P=S +print (fail(substr($a,-2,-1)) ? "ok 78\n" : "not ok 78\n"); # Q R P=S +print (fail(substr($a,-2,-2)) ? "ok 79\n" : "not ok 79\n"); # Q=R P=S +print (fail(substr($a,1,-2)) ? "ok 80\n" : "not ok 81\n"); # R P=S Q +print (fail(substr($a,1,1)) ? "ok 81\n" : "not ok 81\n"); # P=S Q R +print (fail(substr($a,1,0)) ? "ok 82\n" : "not ok 82\n"); # P=S Q=R +print (fail(substr($a,1)) ? "ok 83\n" : "not ok 83\n"); # P=R=S Q + + +my $a = 'zxcvbnm'; +substr($a,2,0) = ''; +print $a eq 'zxcvbnm' ? "ok 84\n" : "not ok 84\n"; +substr($a,7,0) = ''; +print $a eq 'zxcvbnm' ? "ok 85\n" : "not ok 85\n"; +substr($a,5,0) = ''; +print $a eq 'zxcvbnm' ? "ok 86\n" : "not ok 86\n"; +substr($a,0,2) = 'pq'; +print $a eq 'pqcvbnm' ? "ok 87\n" : "not ok 87\n"; +substr($a,2,0) = 'r'; +print $a eq 'pqrcvbnm' ? "ok 88\n" : "not ok 88\n"; +substr($a,8,0) = 'asd'; +print $a eq 'pqrcvbnmasd' ? "ok 89\n" : "not ok 89\n"; +substr($a,0,2) = 'iop'; +print $a eq 'ioprcvbnmasd' ? "ok 90\n" : "not ok 90\n"; +substr($a,0,5) = 'fgh'; +print $a eq 'fghvbnmasd' ? "ok 91\n" : "not ok 91\n"; +substr($a,3,5) = 'jkl'; +print $a eq 'fghjklsd' ? "ok 92\n" : "not ok 92\n"; +substr($a,3,2) = '1234'; +print $a eq 'fgh1234lsd' ? "ok 93\n" : "not ok 93\n"; + + +# with lexicals (and in re-entered scopes) +for (0,1) { + my $txt; + unless ($_) { + $txt = "Foo"; + substr($txt, -1) = "X"; + print $txt eq "FoX" ? "ok 94\n" : "not ok 94\n"; + } + else { + local $^W = 0; # because of (spurious?) "uninitialised value" + substr($txt, 0, 1) = "X"; + print $txt eq "X" ? "ok 95\n" : "not ok 95\n"; + } +} + +# coercion of references +{ + my $s = []; + substr($s, 0, 1) = 'Foo'; + print substr($s,0,7) eq "FooRRAY" && !($w-=2) ? "ok 96\n" : "not ok 96\n"; +} + +# check no spurious warnings +print $w ? "not ok 97\n" : "ok 97\n"; + +# check new 4 arg replacement syntax +$a = "abcxyz"; +$w = 0; +print "not " unless substr($a, 0, 3, "") eq "abc" && $a eq "xyz"; +print "ok 98\n"; +print "not " unless substr($a, 0, 0, "abc") eq "" && $a eq "abcxyz"; +print "ok 99\n"; +print "not " unless substr($a, 3, -1, "") eq "xy" && $a eq "abcz"; +print "ok 100\n"; + +print "not " unless substr($a, 3, undef, "xy") eq "" && $a eq "abcxyz" + && $w == 3; +print "ok 101\n"; +$w = 0; + +print "not " unless substr($a, 3, 9999999, "") eq "xyz" && $a eq "abc"; +print "ok 102\n"; +print "not " unless fail(substr($a, -99, 0, "")); +print "ok 103\n"; +print "not " unless fail(substr($a, 99, 3, "")); +print "ok 104\n"; + +substr($a, 0, length($a), "foo"); +print "not " unless $a eq "foo" && !$w; +print "ok 105\n"; + +# using 4 arg substr as lvalue is a compile time error +eval 'substr($a,0,0,"") = "abc"'; +print "not " unless $@ && $@ =~ /Can't modify substr/ && $a eq "foo"; +print "ok 106\n"; diff --git a/contrib/perl5/t/op/sysio.t b/contrib/perl5/t/op/sysio.t new file mode 100755 index 0000000..826cf38 --- /dev/null +++ b/contrib/perl5/t/op/sysio.t @@ -0,0 +1,194 @@ +#!./perl + +print "1..36\n"; + +chdir('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'); + +$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"; + +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) == 7); +print "ok 29\n"; +# this we should have +print 'not ' unless ($b eq '#!ererl'); +print "ok 30\n"; + +# test sysseek + +print 'not ' unless sysseek(I, 2, 0) == 2; +print "ok 31\n"; +sysread(I, $b, 3); +print 'not ' unless $b eq 'ere'; +print "ok 32\n"; + +print 'not ' unless sysseek(I, -2, 1) == 3; +print "ok 33\n"; +sysread(I, $b, 4); +print 'not ' unless $b eq 'rerl'; +print "ok 34\n"; + +print 'not ' unless sysseek(I, 0, 0) eq '0 but true'; +print "ok 35\n"; +print 'not ' if defined sysseek(I, -1, 1); +print "ok 36\n"; + +close(I); + +unlink $outfile; + +chdir('..'); + +1; + +# eof diff --git a/contrib/perl5/t/op/taint.t b/contrib/perl5/t/op/taint.t new file mode 100755 index 0000000..d2cae8e --- /dev/null +++ b/contrib/perl5/t/op/taint.t @@ -0,0 +1,596 @@ +#!./perl -T +# +# Taint tests by Tom Phoenix . +# +# 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' if -d '../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 }; + +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 < $ECHO" or die "Can't create $ECHO: $!"; +print PROG 'print "@ARGV\n"', "\n"; +close PROG; +my $echo = "$Invoke_Perl $ECHO"; + +print "1..149\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(/tmp /var/tmp /usr/tmp /sys$scratch), + @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 = ; + 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 ($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 || ($Is_Dos && $! == 22); # File not found + + 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, "| $foo" } eq '', 'popen to'; + test 77, $@ =~ /^Insecure dependency/, $@; + + test 78, eval { open FOO, "$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 not 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] # gecos + and not tainted $getpwent[7] + and not tainted $getpwent[8]); + 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; +} diff --git a/contrib/perl5/t/op/tie.t b/contrib/perl5/t/op/tie.t new file mode 100755 index 0000000..77e74db --- /dev/null +++ b/contrib/perl5/t/op/tie.t @@ -0,0 +1,155 @@ +#!./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", ; +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, 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 warning 'untie'; +local $^W = 1 ; +use Tie::Hash ; +tie %h, Tie::StdHash; +untie %h; +EXPECT +######## + +# strict behaviour, with 1 extra references generating an error +#use warning 'untie'; +local $^W = 1 ; +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 warning 'untie'; +local $^W = 1 ; +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 warning 'untie'; +local $^W = 1 ; +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 warning 'untie'; +local $^W = 1 ; +use Tie::Hash ; +tie %h, Tie::StdHash; +$a = tied %h; +$a = 0 ; +untie %h; +EXPECT +######## + +# strict error behaviour, with 2 extra references +#use warning 'untie'; +local $^W = 1 ; +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 warning 'untie'; +local $^W = 0 ; +use Tie::Hash ; +$A = tie %H, Tie::StdHash; +$C = $B = tied %H ; +{ + #use warning 'untie'; + local $^W = 1 ; + use Tie::Hash ; + tie %h, Tie::StdHash; + untie %h; +} +untie %H; +EXPECT diff --git a/contrib/perl5/t/op/tiearray.t b/contrib/perl5/t/op/tiearray.t new file mode 100755 index 0000000..8e78b2f --- /dev/null +++ b/contrib/perl5/t/op/tiearray.t @@ -0,0 +1,210 @@ +#!./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 new file mode 100755 index 0000000..e3d2472 --- /dev/null +++ b/contrib/perl5/t/op/tiehandle.t @@ -0,0 +1,137 @@ +#!./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]); + 4; +} + +sub CLOSE { + compare(CLOSE => @_); + + 5; +} + +package main; + +use Symbol; + +print "1..23\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"); + +@expect = (CLOSE => $ob); +$r = close $fh; +ok($r == 5); diff --git a/contrib/perl5/t/op/time.t b/contrib/perl5/t/op/time.t new file mode 100755 index 0000000..1bec442 --- /dev/null +++ b/contrib/perl5/t/op/time.t @@ -0,0 +1,47 @@ +#!./perl + +# $RCSfile: time.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:32 $ + +if ($does_gmtime = gmtime(time)) { print "1..5\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";} diff --git a/contrib/perl5/t/op/undef.t b/contrib/perl5/t/op/undef.t new file mode 100755 index 0000000..8ab2ec4 --- /dev/null +++ b/contrib/perl5/t/op/undef.t @@ -0,0 +1,56 @@ +#!./perl + +# $RCSfile: undef.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:34 $ + +print "1..21\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"; diff --git a/contrib/perl5/t/op/universal.t b/contrib/perl5/t/op/universal.t new file mode 100755 index 0000000..bde78fd --- /dev/null +++ b/contrib/perl5/t/op/universal.t @@ -0,0 +1,104 @@ +#!./perl +# +# check UNIVERSAL +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; +} + +print "1..72\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 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->can("drink"); + +test $a->can("eat"); + +test ! $a->can("sleep"); + +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.719 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 diff --git a/contrib/perl5/t/op/unshift.t b/contrib/perl5/t/op/unshift.t new file mode 100755 index 0000000..68d3775 --- /dev/null +++ b/contrib/perl5/t/op/unshift.t @@ -0,0 +1,14 @@ +#!./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/vec.t b/contrib/perl5/t/op/vec.t new file mode 100755 index 0000000..7117144 --- /dev/null +++ b/contrib/perl5/t/op/vec.t @@ -0,0 +1,27 @@ +#!./perl + +# $RCSfile: vec.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:36 $ + +print "1..15\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 ord($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 ((ord(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"; + diff --git a/contrib/perl5/t/op/wantarray.t b/contrib/perl5/t/op/wantarray.t new file mode 100755 index 0000000..0a47b6d --- /dev/null +++ b/contrib/perl5/t/op/wantarray.t @@ -0,0 +1,16 @@ +#!./perl + +print "1..3\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); +1; diff --git a/contrib/perl5/t/op/write.t b/contrib/perl5/t/op/write.t new file mode 100755 index 0000000..705fa79 --- /dev/null +++ b/contrib/perl5/t/op/write.t @@ -0,0 +1,169 @@ +#!./perl + +# $RCSfile: write.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:38 $ + +print "1..5\n"; + +my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat'; + +format OUT = +the quick brown @<< +$fox +jumped +@* +$multiline +^<<<<<<<<< +$foo +^<<<<<<<<< +$foo +^<<<<<<... +$foo +now @<>>> 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 @<>>> 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 @<>>> 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 = < 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"; + -- cgit v1.1