diff options
Diffstat (limited to 't/op')
| -rwxr-xr-x | t/op/array.t | 4 | ||||
| -rwxr-xr-x | t/op/chop.t | 44 | ||||
| -rwxr-xr-x | t/op/delete.t | 10 | ||||
| -rwxr-xr-x | t/op/flip.t | 4 | ||||
| -rwxr-xr-x | t/op/goto.t | 2 | ||||
| -rwxr-xr-x | t/op/magic.t | 2 | ||||
| -rwxr-xr-x | t/op/misc.t | 174 | ||||
| -rwxr-xr-x | t/op/pat.t | 26 | ||||
| -rwxr-xr-x | t/op/quotemeta.t | 26 | ||||
| -rwxr-xr-x | t/op/rand.t | 25 | ||||
| -rw-r--r-- | t/op/re_tests | 65 | ||||
| -rwxr-xr-x | t/op/read.t | 2 | ||||
| -rwxr-xr-x | t/op/readdir.t | 7 | ||||
| -rwxr-xr-x | t/op/ref.t | 23 | ||||
| -rwxr-xr-x | t/op/sort.t | 2 | ||||
| -rwxr-xr-x | t/op/split.t | 3 | ||||
| -rwxr-xr-x | t/op/substr.t | 4 | ||||
| -rwxr-xr-x | t/op/time.t | 8 | ||||
| -rwxr-xr-x | t/op/write.t | 24 |
19 files changed, 386 insertions, 69 deletions
diff --git a/t/op/array.t b/t/op/array.t index 089fb5528e..ed471b4c4d 100755 --- a/t/op/array.t +++ b/t/op/array.t @@ -23,9 +23,9 @@ 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 we can recover element 5 +$#ary += 1; # see if element 5 gone for good if ($#ary == 5) {print "ok 10\n";} else {print "not ok 10\n";} -if ($ary[5] == 5) {print "ok 11\n";} else {print "not ok 11\n";} +if (defined $ary[5]) {print "not ok 11\n";} else {print "ok 11\n";} $[ = 0; @foo = (); diff --git a/t/op/chop.t b/t/op/chop.t index d20b546465..3516c2d18c 100755 --- a/t/op/chop.t +++ b/t/op/chop.t @@ -2,7 +2,7 @@ # $RCSfile: chop.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:40 $ -print "1..4\n"; +print "1..22\n"; # optimized @@ -28,3 +28,45 @@ 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"; diff --git a/t/op/delete.t b/t/op/delete.t index 86ed9b47ba..010cbf1003 100755 --- a/t/op/delete.t +++ b/t/op/delete.t @@ -2,7 +2,7 @@ # $RCSfile: delete.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:44 $ -print "1..6\n"; +print "1..7\n"; $foo{1} = 'a'; $foo{2} = 'b'; @@ -27,3 +27,11 @@ $foo{'bar'} = 'y'; $foo = join('',values(foo)); if ($foo eq 'xy' || $foo eq 'yx') {print "ok 6\n";} else {print "not ok 6\n";} + +$refhash{"top"}->{"foo"} = "FOO"; +$refhash{"top"}->{"bar"} = "BAR"; + +delete $refhash{"top"}->{"bar"}; +@list = keys %{$refhash{"top"}}; + +print "@list" eq "foo" ? "ok 7\n" : "not ok 7 @list\n"; diff --git a/t/op/flip.t b/t/op/flip.t index 72425da3a2..475f55a8c8 100755 --- a/t/op/flip.t +++ b/t/op/flip.t @@ -17,9 +17,9 @@ if ($y eq '12E0123E0') {print "ok 7\n";} else {print "not ok 7\n";} @a = ('a','b','c','d','e','f','g'); -open(of,'../Makefile'); +open(of,'../Configure'); while (<of>) { - (3 .. 5) && $foo .= $_; + (3 .. 5) && ($foo .= $_); } $x = ($foo =~ y/\n/\n/); diff --git a/t/op/goto.t b/t/op/goto.t index 21a35c1de3..087331907e 100755 --- a/t/op/goto.t +++ b/t/op/goto.t @@ -32,6 +32,8 @@ print "#2\t:$foo: == 4\n"; if ($foo == 4) {print "ok 2\n";} else {print "not ok 2\n";} $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 { diff --git a/t/op/magic.t b/t/op/magic.t index 3243c625ce..b43f71c809 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -12,7 +12,7 @@ if (`echo \$foo` eq "hi there\n") {print "ok 1\n";} else {print "not ok 1\n";} unlink 'ajslkdfpqjsjfk'; $! = 0; open(foo,'ajslkdfpqjsjfk'); -if ($! == 2) {print "ok 2\n";} else {print "not ok 2\n";} +if ($!) {print "ok 2\n";} else {print "not ok 2\n";} # the next tests are embedded inside system simply because sh spits out # a newline onto stderr when a child process kills itself with SIGINT. diff --git a/t/op/misc.t b/t/op/misc.t new file mode 100755 index 0000000000..decba2d609 --- /dev/null +++ b/t/op/misc.t @@ -0,0 +1,174 @@ +#!./perl + +chdir 't' if -d 't'; +@INC = "../lib"; +$ENV{PERL5LIB} = "../lib"; + +$|=1; + +undef $/; +@prgs = split "\n########\n", <DATA>; +print "1..", scalar @prgs, "\n"; + +$tmpfile = "misctmp000"; +1 while -f ++$tmpfile; +END { unlink $tmpfile if $tmpfile; } + +for (@prgs){ + my $switch; + if (s/^\s*-\w+//){ + $switch = $&; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + open TEST, "| sh -c './perl $switch' >$tmpfile 2>&1"; + print TEST $prog, "\n"; + close TEST; + $status = $?; + $results = `cat $tmpfile`; + $results =~ s/\n+$//; + $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__ +$foo=undef; $foo->go; +EXPECT +Can't call method "go" without a package or object reference at - line 1. +######## +BEGIN + { + "foo"; + } +######## +-P +use POSIX; +######## +$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 .= <STDIN>); +######## +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 coerce HASH to string in repeat at - line 1. +######## +$_="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. diff --git a/t/op/pat.t b/t/op/pat.t index a669526177..d93e6d66e2 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -2,7 +2,7 @@ # $RCSfile: pat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:12 $ -print "1..51\n"; +print "1..60\n"; $x = "abc\ndef\n"; @@ -73,7 +73,7 @@ while ($_ = shift(XXX)) { /not ok 26/ && reset 'X'; } -while (($key,$val) = each(XXX)) { +while (($key,$val) = each(%XXX)) { print "not ok 27\n"; exit; } @@ -182,3 +182,25 @@ print "abc" =~ /^abc$|$xyz/ ? "ok 49\n" : "not ok 49\n"; 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"; +$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"; +$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"; diff --git a/t/op/quotemeta.t b/t/op/quotemeta.t new file mode 100755 index 0000000000..09794571b1 --- /dev/null +++ b/t/op/quotemeta.t @@ -0,0 +1,26 @@ +#!./perl +print "1..15\n"; + +$_=join "", grep $_=chr($_), 32..127; + +#95 characters - 52 letters - 10 digits = 33 backslashes +#95 characters + 33 backslashes = 128 characters +$_=quotemeta $_; +if ( length == 128 ){print "ok 1\n"} else {print "not ok 1\n"} +if (tr/\\//cd == 94){print "ok 2\n"} else {print "not ok 2\n"} + +#perl5a11 bus errors on this: +if (length quotemeta "" == 0){print "ok 3\n"} else {print "not ok 3\n"} + +print "aA\UbB\LcC\EdD" eq "aABBccdD" ? "ok 4\n" : "not ok 4 \n"; +print "aA\LbB\UcC\EdD" eq "aAbbCCdD" ? "ok 5\n" : "not ok 5 \n"; +print "\L\upERL" eq "Perl" ? "ok 6\n" : "not ok 6 \n"; +print "\u\LpERL" eq "Perl" ? "ok 7\n" : "not ok 7 \n"; +print "\U\lPerl" eq "pERL" ? "ok 8\n" : "not ok 8 \n"; +print "\l\UPerl" eq "pERL" ? "ok 9\n" : "not ok 9 \n"; +print "\u\LpE\Q#X#\ER\EL" eq "Pe\\#x\\#rL" ? "ok 10\n" : "not ok 10 \n"; +print "\l\UPe\Q!x!\Er\El" eq "pE\\!X\\!Rl" ? "ok 11\n" : "not ok 11 \n"; +print "\Q\u\LpE.X.R\EL\E." eq "Pe\\.x\\.rL." ? "ok 12\n" : "not ok 12 \n"; +print "\Q\l\UPe*x*r\El\E*" eq "pE\\*X\\*Rl*" ? "ok 13\n" : "not ok 13 \n"; +print "\U\lPerl\E\E\E\E" eq "pERL" ? "ok 14\n" : "not ok 14 \n"; +print "\l\UPerl\E\E\E\E" eq "pERL" ? "ok 15\n" : "not ok 15 \n"; diff --git a/t/op/rand.t b/t/op/rand.t new file mode 100755 index 0000000000..14e6ccfbed --- /dev/null +++ b/t/op/rand.t @@ -0,0 +1,25 @@ +#!./perl + +#From jhi@snakemail.hut.fi Mon May 16 10:36:46 1994 +#Date: Sun, 15 May 1994 20:39:09 +0300 +#From: Jarkko Hietaniemi <jhi@snakemail.hut.fi> + +print "1..2\n"; + +$n = 1000; + +$c = 0; +for (1..$n) { + last if (rand() > 1 || rand() < 0); + $c++; +} + +if ($c == $n) {print "ok 1\n";} else {print "not ok 1\n"} + +$c = 0; +for (1..$n) { + last if (rand(10) > 10 || rand(10) < 0); + $c++; +} + +if ($c == $n) {print "ok 2\n";} else {print "not ok 2\n"} diff --git a/t/op/re_tests b/t/op/re_tests index ee03d6fdbd..f8c4c6eafb 100644 --- a/t/op/re_tests +++ b/t/op/re_tests @@ -56,10 +56,7 @@ a[^]b]c adc y $& adc ab|cd abc y $& ab ab|cd abcd y $& ab ()ef def y $&-$1 ef- -()* - c - - *a - c - - -^* - c - - -$* - c - - (*)b - c - - $b b n - - a\ - c - - @@ -74,19 +71,13 @@ abc) - c - - a+b+c aabbabc y $& abc a{1,}b{1,}c aabbabc y $& abc a** - c - - -a*? - c - - -(a*)* - c - - -(a*)+ - c - - -(a|)* - c - - -(a*|b)* - c - - +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 - - -(ab|)* - c - - )( - c - - [^ab]* cde y $& cde abc n - - @@ -95,7 +86,6 @@ a* y $& ([abc])*bcd abcd y $&-$1 abcd-a a|b|c|d|e e y $& e (a|b|c|d|e)f ef y $&-$1 ef-e -((a*|b))* - c - - abcd*efg abcdefg y $& abcdefg ab* xabyabbbz y $& ab ab* xayabbbz y $& a @@ -144,23 +134,23 @@ a[-]?c ac y $& ac '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 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 +'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 @@ -170,7 +160,7 @@ a[-]?c ac y $& ac '$'i ABC y $& 'a.c'i ABC y $& ABC 'a.c'i AXC y $& AXC -'a.*c'i AXYZC y $& AXYZC +'a.*?c'i AXYZC y $& AXYZC 'a.*c'i AXYZD n - - 'a[bc]d'i ABC n - - 'a[bc]d'i ABD y $& ABD @@ -193,10 +183,7 @@ a[-]?c ac y $& ac 'ab|cd'i ABC y $& AB 'ab|cd'i ABCD y $& AB '()ef'i DEF y $&-$1 EF- -'()*'i - c - - '*a'i - c - - -'^*'i - c - - -'$*'i - c - - '(*)b'i - c - - '$b'i B n - - 'a\'i - c - - @@ -211,19 +198,16 @@ a[-]?c ac y $& ac 'a+b+c'i AABBABC y $& ABC 'a{1,}b{1,}c'i AABBABC y $& ABC 'a**'i - c - - -'a*?'i - c - - -'(a*)*'i - c - - -'(a*)+'i - c - - -'(a|)*'i - c - - -'(a*|b)*'i - c - - +'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 -'(^)*'i - c - - -'(ab|)*'i - c - - +'(a+|b){0,1}?'i AB y $&-$1 - ')('i - c - - '[^ab]*'i CDE y $& CDE 'abc'i n - - @@ -232,7 +216,6 @@ a[-]?c ac y $& ac '([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 -'((a*|b))*'i - c - - 'abcd*efg'i ABCDEFG y $& ABCDEFG 'ab*'i XABYABBBZ y $& AB 'ab*'i XAYABBBZ y $& A @@ -262,6 +245,8 @@ a[-]?c ac y $& ac '((((((((((a))))))))))\41'i AA n - - '((((((((((a))))))))))\41'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 @@ -272,3 +257,11 @@ a[-]?c ac y $& ac '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|e){1,2}?|d)+?(.) ace y $1$2 ce +^(.+)?B AB y $1 A diff --git a/t/op/read.t b/t/op/read.t index 8c571c035b..2746970d15 100755 --- a/t/op/read.t +++ b/t/op/read.t @@ -12,7 +12,7 @@ $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,20000,0); +seek (FOO,0,2) || seek(FOO,20000,0); $got = read(FOO,$buf,4); print ($got == 0 ? "ok 3\n" : "not ok 3\n"); diff --git a/t/op/readdir.t b/t/op/readdir.t index 18006991cd..1215f11c8a 100755 --- a/t/op/readdir.t +++ b/t/op/readdir.t @@ -6,13 +6,18 @@ 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$/, readdir(OP)); +@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 = <op/*.t>; +if ($G[0] =~ m#.*\](\w+\.t)#i) { + # grep is to convert filespecs returned from glob under VMS to format + # identical to that returned by readdir + @G = grep(s#.*\](\w+\.t).*#op/$1#i,<op/*.t>); +} while (@R && @G && "op/".$R[0] eq $G[0]) { shift(@R); shift(@G); diff --git a/t/op/ref.t b/t/op/ref.t index 60bb75ce33..73a54ff3c8 100755 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -1,6 +1,6 @@ #!./perl -print "1..40\n"; +print "1..41\n"; # Test glob operations. @@ -73,7 +73,7 @@ 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 18\n"; +print $ref->[2]->[0] == 3 ? "ok 19\n" : "not ok 19\n"; # Test references to hashes of references. @@ -151,8 +151,8 @@ DESTROY { return unless $string; print $string; - # Test that the object has already been "cursed". - print ref shift eq HASH ? "ok 35\n" : "not ok 35\n"; + # 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. @@ -180,12 +180,21 @@ sub BASEOBJ'doit { $ref->{shift}; } +package UNIVERSAL; +@ISA = 'LASTCHANCE'; + +package LASTCHANCE; +sub foo { print $_[1] } + +package WHATEVER; +foo WHATEVER "ok 38\n"; + package FINALE; { - $ref3 = bless ["ok 40\n"]; # package destruction - my $ref2 = bless ["ok 39\n"]; # lexical destruction - local $ref1 = bless ["ok 38\n"]; # dynamic destruction + $ref3 = bless ["ok 41\n"]; # package destruction + my $ref2 = bless ["ok 40\n"]; # lexical destruction + local $ref1 = bless ["ok 39\n"]; # dynamic destruction 1; # flush any temp values on stack } diff --git a/t/op/sort.t b/t/op/sort.t index 56a0fd3e92..dc01e5f11d 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -12,7 +12,7 @@ sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0; } $x = join('', sort @harry); print ($x eq 'AbelCaincatdogx' ? "ok 1\n" : "not ok 1\n"); -$x = join('', sort backwards @harry); +$x = join('', sort( backwards @harry)); print ($x eq 'xdogcatCainAbel' ? "ok 2\n" : "not ok 2\n"); $x = join('', sort @george, 'to', @harry); diff --git a/t/op/split.t b/t/op/split.t index d87998e098..2354530817 100755 --- a/t/op/split.t +++ b/t/op/split.t @@ -48,6 +48,9 @@ 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? $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? diff --git a/t/op/substr.t b/t/op/substr.t index 25336365b9..08e1c39969 100755 --- a/t/op/substr.t +++ b/t/op/substr.t @@ -10,7 +10,7 @@ print (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n"); print (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n"); print (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n"); print (substr($a,999,999) eq '' ? "ok 4\n" : "not ok 4\n"); -print (substr($a,6,-1) eq '' ? "ok 5\n" : "not ok 5\n"); +print (substr($a,0,-6) eq 'abc' ? "ok 5\n" : "not ok 5\n"); print (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n"); $[ = 1; @@ -19,7 +19,7 @@ print (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n"); print (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n"); print (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n"); print (substr($a,999,999) eq '' ? "ok 10\n" : "not ok 10\n"); -print (substr($a,7,-1) eq '' ? "ok 11\n" : "not ok 11\n"); +print (substr($a,1,-6) eq 'abc' ? "ok 11\n" : "not ok 11\n"); print (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n"); $[ = 0; diff --git a/t/op/time.t b/t/op/time.t index 6d23832dfa..186a81cf8a 100755 --- a/t/op/time.t +++ b/t/op/time.t @@ -2,7 +2,8 @@ # $RCSfile: time.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:32 $ -print "1..5\n"; +if ($does_gmtime = gmtime(time)) { print "1..5\n" } +else { print "1..3\n" } ($beguser,$begsys) = times; @@ -14,7 +15,8 @@ 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; + $i = 200000 if $nowuser > $beguser && ( $nowsys > $begsys || + (!$nowsys && !$begsys)); last if time - $beg > 20; } @@ -29,6 +31,8 @@ if ($sec != $xsec && $mday && $year) 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); diff --git a/t/op/write.t b/t/op/write.t index eb00d81b59..bfb4785155 100755 --- a/t/op/write.t +++ b/t/op/write.t @@ -17,10 +17,12 @@ $foo ^<<<<<<... $foo now @<<the@>>>> for all@|||||men to come @<<<< -'i' . 's', "time\n", $good, 'to' +{ + 'i' . 's', "time\n", $good, 'to' +} . -open(OUT, '>Op.write.tmp') || die "Can't create Op.write.tmp"; +open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; $fox = 'foxiness'; $good = 'good'; @@ -40,8 +42,8 @@ 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'; } +if (`cat Op_write.tmp` eq $right) + { print "ok 1\n"; unlink 'Op_write.tmp'; } else { print "not ok 1\n"; } @@ -57,7 +59,7 @@ now @<<the@>>>> for all@|||||men to come @<<<< 'i' . 's', "time\n", $good, 'to' . -open OUT2, '>Op.write.tmp' or die "Can't create Op.write.tmp"; +open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp"; $fox = 'foxiness'; $good = 'good'; @@ -80,8 +82,8 @@ 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'; } +if (`cat Op_write.tmp` eq $right) + { print "ok 2\n"; unlink 'Op_write.tmp'; } else { print "not ok 2\n"; } @@ -92,6 +94,7 @@ $fox jumped @* $multiline +and ^<<<<<<<<< ~~ $foo now @<<the@>>>> for all@|||||men to come @<<<< @@ -99,7 +102,7 @@ now @<<the@>>>> for all@|||||men to come @<<<< . EOFORMAT -open(OUT2, '>Op.write.tmp') || die "Can't create Op.write.tmp"; +open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp"; $fox = 'foxiness'; $good = 'good'; @@ -114,6 +117,7 @@ jumped forescore and seven years +and when in the course of human @@ -122,8 +126,8 @@ 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'; } +if (`cat Op_write.tmp` eq $right) + { print "ok 3\n"; unlink 'Op_write.tmp'; } else { print "not ok 3\n"; } |