diff options
author | Larry Wall <lwall@netlabs.com> | 1991-03-21 00:00:00 +0000 |
---|---|---|
committer | Larry Wall <lwall@netlabs.com> | 1991-03-21 00:00:00 +0000 |
commit | fe14fcc35f78a371a174a1d14256c2f35ae4262b (patch) | |
tree | d472cb1055c47b9701cb0840969aacdbdbc9354a /t/op | |
parent | 27e2fb84680b9cc1db17238d5bf10b97626f477f (diff) | |
download | perl-fe14fcc35f78a371a174a1d14256c2f35ae4262b.tar.gz |
perl 4.0.00: (no release announcement available)perl-4.0.00
So far, 4.0 is still a beta test version. For the last production
version, look in pub/perl.3.0/kits@44.
Diffstat (limited to 't/op')
-rw-r--r-- | t/op/append.t | 21 | ||||
-rw-r--r-- | t/op/array.t | 120 | ||||
-rw-r--r-- | t/op/auto.t | 48 | ||||
-rw-r--r-- | t/op/chop.t | 30 | ||||
-rw-r--r-- | t/op/cond.t | 12 | ||||
-rw-r--r-- | t/op/dbm.t | 105 | ||||
-rw-r--r-- | t/op/delete.t | 29 | ||||
-rw-r--r-- | t/op/do.t | 44 | ||||
-rw-r--r-- | t/op/each.t | 53 | ||||
-rw-r--r-- | t/op/eval.t | 42 | ||||
-rw-r--r-- | t/op/exec.t | 21 | ||||
-rw-r--r-- | t/op/exp.t | 27 | ||||
-rw-r--r-- | t/op/flip.t | 26 | ||||
-rw-r--r-- | t/op/fork.t | 16 | ||||
-rw-r--r-- | t/op/glob.t | 22 | ||||
-rw-r--r-- | t/op/goto.t | 34 | ||||
-rw-r--r-- | t/op/groups.t | 18 | ||||
-rw-r--r-- | t/op/index.t | 42 | ||||
-rw-r--r-- | t/op/int.t | 17 | ||||
-rw-r--r-- | t/op/join.t | 12 | ||||
-rw-r--r-- | t/op/list.t | 83 | ||||
-rw-r--r-- | t/op/local.t | 45 | ||||
-rw-r--r-- | t/op/magic.t | 32 | ||||
-rw-r--r-- | t/op/mkdir.t | 15 | ||||
-rw-r--r-- | t/op/oct.t | 9 | ||||
-rw-r--r-- | t/op/ord.t | 14 | ||||
-rw-r--r-- | t/op/pack.t | 20 | ||||
-rw-r--r-- | t/op/pat.t | 120 | ||||
-rw-r--r-- | t/op/push.t | 44 | ||||
-rw-r--r-- | t/op/range.t | 36 | ||||
-rw-r--r-- | t/op/re_tests | 137 | ||||
-rw-r--r-- | t/op/read.t | 19 | ||||
-rw-r--r-- | t/op/regexp.t | 33 | ||||
-rw-r--r-- | t/op/repeat.t | 42 | ||||
-rw-r--r-- | t/op/s.t | 179 | ||||
-rw-r--r-- | t/op/sleep.t | 8 | ||||
-rw-r--r-- | t/op/sort.t | 39 | ||||
-rw-r--r-- | t/op/split.t | 57 | ||||
-rw-r--r-- | t/op/sprintf.t | 8 | ||||
-rw-r--r-- | t/op/stat.t | 153 | ||||
-rw-r--r-- | t/op/study.t | 69 | ||||
-rw-r--r-- | t/op/substr.t | 47 | ||||
-rw-r--r-- | t/op/time.t | 43 | ||||
-rw-r--r-- | t/op/undef.t | 56 | ||||
-rw-r--r-- | t/op/unshift.t | 14 | ||||
-rw-r--r-- | t/op/vec.t | 24 | ||||
-rw-r--r-- | t/op/write.t | 129 |
47 files changed, 2214 insertions, 0 deletions
diff --git a/t/op/append.t b/t/op/append.t new file mode 100644 index 0000000000..9140c16b83 --- /dev/null +++ b/t/op/append.t @@ -0,0 +1,21 @@ +#!./perl + +# $Header: append.t,v 4.0 91/03/20 01:51:23 lwall Locked $ + +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/t/op/array.t b/t/op/array.t new file mode 100644 index 0000000000..18fe288356 --- /dev/null +++ b/t/op/array.t @@ -0,0 +1,120 @@ +#!./perl + +# $Header: array.t,v 4.0 91/03/20 01:51:31 lwall Locked $ + +print "1..36\n"; + +@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 we can recover element 5 +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";} + +$[ = 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"; diff --git a/t/op/auto.t b/t/op/auto.t new file mode 100644 index 0000000000..e1122a5774 --- /dev/null +++ b/t/op/auto.t @@ -0,0 +1,48 @@ +#!./perl + +# $Header: auto.t,v 4.0 91/03/20 01:51:35 lwall Locked $ + +print "1..34\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";} diff --git a/t/op/chop.t b/t/op/chop.t new file mode 100644 index 0000000000..ba6d6262b3 --- /dev/null +++ b/t/op/chop.t @@ -0,0 +1,30 @@ +#!./perl + +# $Header: chop.t,v 4.0 91/03/20 01:51:42 lwall Locked $ + +print "1..4\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"; diff --git a/t/op/cond.t b/t/op/cond.t new file mode 100644 index 0000000000..31baf9d05f --- /dev/null +++ b/t/op/cond.t @@ -0,0 +1,12 @@ +#!./perl + +# $Header: cond.t,v 4.0 91/03/20 01:51:47 lwall Locked $ + +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/t/op/dbm.t b/t/op/dbm.t new file mode 100644 index 0000000000..c31a2489c1 --- /dev/null +++ b/t/op/dbm.t @@ -0,0 +1,105 @@ +#!./perl + +# $Header: dbm.t,v 4.0 91/03/20 01:51:52 lwall Locked $ + +if (!-r '/usr/include/dbm.h' && !-r '/usr/include/ndbm.h') { + print "1..0\n"; + exit; +} + +print "1..12\n"; + +unlink <Op.dbmx.*>; +umask(0); +print (dbmopen(h,'Op.dbmx',0640) ? "ok 1\n" : "not ok 1\n"); +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('Op.dbmx.pag'); +print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n"); +while (($key,$value) = each(h)) { + $i++; +} +print (!$i ? "ok 3\n" : "not ok 3\n"); + +$h{'goner1'} = 'snork'; + +$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{'goner2'} = 'snork'; +delete $h{'goner2'}; + +dbmclose(h); +print (dbmopen(h,'Op.dbmx',0640) ? "ok 4\n" : "not ok 4\n"); + +$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'; + +$h{'goner3'} = 'snork'; + +delete $h{'goner1'}; +delete $h{'goner3'}; + +@keys = keys(%h); +@values = values(%h); + +if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";} + +while (($key,$value) = each(h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) { + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; + } +} + +if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";} + +@keys = ('blurfl', keys(h), 'dyick'); +if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";} + +$h{'foo'} = ''; +$h{''} = 'bar'; + +# check cache overflow and numeric keys and contents +$ok = 1; +for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; } +for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; } +print ($ok ? "ok 8\n" : "not ok 8\n"); + +($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat('Op.dbmx.pag'); +print ($size > 0 ? "ok 9\n" : "not ok 9\n"); + +@h{0..200} = 200..400; +@foo = @h{0..200}; +print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n"; + +print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n"); +print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n"); + +unlink 'Op.dbmx.dir', 'Op.dbmx.pag'; diff --git a/t/op/delete.t b/t/op/delete.t new file mode 100644 index 0000000000..b5920dd397 --- /dev/null +++ b/t/op/delete.t @@ -0,0 +1,29 @@ +#!./perl + +# $Header: delete.t,v 4.0 91/03/20 01:51:56 lwall Locked $ + +print "1..6\n"; + +$foo{1} = 'a'; +$foo{2} = 'b'; +$foo{3} = 'c'; + +$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";} + +$foo = join('',values(foo)); +if ($foo eq 'ac' || $foo eq 'ca') {print "ok 5\n";} else {print "not ok 5\n";} + +foreach $key (keys foo) { + delete $foo{$key}; +} + +$foo{'foo'} = 'x'; +$foo{'bar'} = 'y'; + +$foo = join('',values(foo)); +if ($foo eq 'xy' || $foo eq 'yx') {print "ok 6\n";} else {print "not ok 6\n";} diff --git a/t/op/do.t b/t/op/do.t new file mode 100644 index 0000000000..f75ca3010e --- /dev/null +++ b/t/op/do.t @@ -0,0 +1,44 @@ +#!./perl + +# $Header: do.t,v 4.0 91/03/20 01:52:08 lwall Locked $ + +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/t/op/each.t b/t/op/each.t new file mode 100644 index 0000000000..d759fda549 --- /dev/null +++ b/t/op/each.t @@ -0,0 +1,53 @@ +#!./perl + +# $Header: each.t,v 4.0 91/03/20 01:52:14 lwall Locked $ + +print "1..3\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";} + +while (($key,$value) = each(h)) { + if ($key eq $keys[$i] && $value eq $values[$i] && $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";} diff --git a/t/op/eval.t b/t/op/eval.t new file mode 100644 index 0000000000..464162c0a3 --- /dev/null +++ b/t/op/eval.t @@ -0,0 +1,42 @@ +#!./perl + +# $Header: eval.t,v 4.0 91/03/20 01:52:20 lwall Locked $ + +print "1..10\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 $@; diff --git a/t/op/exec.t b/t/op/exec.t new file mode 100644 index 0000000000..f3012fd2f9 --- /dev/null +++ b/t/op/exec.t @@ -0,0 +1,21 @@ +#!./perl + +# $Header: exec.t,v 4.0 91/03/20 01:52:25 lwall Locked $ + +$| = 1; # flush stdout +print "1..8\n"; + +print "not ok 1\n" if system "echo ok \\1"; # 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 + +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/t/op/exp.t b/t/op/exp.t new file mode 100644 index 0000000000..776d2634da --- /dev/null +++ b/t/op/exp.t @@ -0,0 +1,27 @@ +#!./perl + +# $Header: exp.t,v 4.0 91/03/20 01:52:31 lwall Locked $ + +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/t/op/flip.t b/t/op/flip.t new file mode 100644 index 0000000000..35f100cdef --- /dev/null +++ b/t/op/flip.t @@ -0,0 +1,26 @@ +#!./perl + +# $Header: flip.t,v 4.0 91/03/20 01:52:36 lwall Locked $ + +print "1..8\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,'../Makefile'); +while (<of>) { + (3 .. 5) && $foo .= $_; +} +$x = ($foo =~ y/\n/\n/); + +if ($x eq 3) {print "ok 8\n";} else {print "not ok 8 $x:$foo:\n";} diff --git a/t/op/fork.t b/t/op/fork.t new file mode 100644 index 0000000000..55696fd98f --- /dev/null +++ b/t/op/fork.t @@ -0,0 +1,16 @@ +#!./perl + +# $Header: fork.t,v 4.0 91/03/20 01:52:43 lwall Locked $ + +$| = 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/t/op/glob.t b/t/op/glob.t new file mode 100644 index 0000000000..1250a72542 --- /dev/null +++ b/t/op/glob.t @@ -0,0 +1,22 @@ +#!./perl + +# $Header: glob.t,v 4.0 91/03/20 01:52:49 lwall Locked $ + +print "1..4\n"; + +@ops = <op/*>; +$list = join(' ',@ops); + +chop($otherway = `echo op/*`); + +print $list eq $otherway ? "ok 1\n" : "not ok 1\n$list\n$otherway\n"; + +print $/ eq "\n" ? "ok 2\n" : "not ok 2\n"; + +while (<jskdfjskdfj* op/* jskdjfjkosvk*>) { + $not = "not " unless $_ eq shift @ops; + $not = "not at all " if $/ eq "\0"; +} +print "${not}ok 3\n"; + +print $/ eq "\n" ? "ok 4\n" : "not ok 4\n"; diff --git a/t/op/goto.t b/t/op/goto.t new file mode 100644 index 0000000000..b76d44d3ba --- /dev/null +++ b/t/op/goto.t @@ -0,0 +1,34 @@ +#!./perl + +# $Header: goto.t,v 4.0 91/03/20 01:52:52 lwall Locked $ + +print "1..3\n"; + +while (0) { + $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";} + +$x = `./perl -e 'goto foo;' 2>&1`; +print "#3\t/label/ in :$x"; +if ($x =~ /label/) {print "ok 3\n";} else {print "not ok 3\n";} diff --git a/t/op/groups.t b/t/op/groups.t new file mode 100644 index 0000000000..73ec3a0d9a --- /dev/null +++ b/t/op/groups.t @@ -0,0 +1,18 @@ +#!./perl + +if (! -x '/usr/ucb/groups') { + print "1..0\n"; + exit 0; +} + +print "1..1\n"; + +for (split(' ', $()) { + next if $seen{$_}++; + push(@gr, (getgrgid($_))[0]); +} +$gr1 = join(' ',sort @gr); +$gr2 = join(' ', sort split(' ',`groups`)); +#print "gr1 is <$gr1>\n"; +#print "gr2 is <$gr2>\n"; +print +($gr1 eq $gr2) ? "ok 1\n" : "not ok 1\n"; diff --git a/t/op/index.t b/t/op/index.t new file mode 100644 index 0000000000..7cc4fca5ca --- /dev/null +++ b/t/op/index.t @@ -0,0 +1,42 @@ +#!./perl + +# $Header: index.t,v 4.0 91/03/20 01:53:05 lwall Locked $ + +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/t/op/int.t b/t/op/int.t new file mode 100644 index 0000000000..ff351aa0a3 --- /dev/null +++ b/t/op/int.t @@ -0,0 +1,17 @@ +#!./perl + +# $Header: int.t,v 4.0 91/03/20 01:53:08 lwall Locked $ + +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/t/op/join.t b/t/op/join.t new file mode 100644 index 0000000000..b219af380d --- /dev/null +++ b/t/op/join.t @@ -0,0 +1,12 @@ +#!./perl + +# $Header: join.t,v 4.0 91/03/20 01:53:17 lwall Locked $ + +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/t/op/list.t b/t/op/list.t new file mode 100644 index 0000000000..56fe09ca0a --- /dev/null +++ b/t/op/list.t @@ -0,0 +1,83 @@ +#!./perl + +# $Header: list.t,v 4.0 91/03/20 01:53:24 lwall Locked $ + +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/t/op/local.t b/t/op/local.t new file mode 100644 index 0000000000..1f7608934f --- /dev/null +++ b/t/op/local.t @@ -0,0 +1,45 @@ +#!./perl + +# $Header: local.t,v 4.0 91/03/20 01:53:29 lwall Locked $ + +print "1..20\n"; + +sub foo { + local($a, $b) = @_; + local($c, $d); + $c = "ok 3\n"; + $d = "ok 4\n"; + { local($a,$c) = ("ok 9\n", "ok 10\n"); ($x, $y) = ($a, $c); } + print $a, $b; + $c . $d; +} + +$a = "ok 5\n"; +$b = "ok 6\n"; +$c = "ok 7\n"; +$d = "ok 8\n"; + +print do 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 do foo2("ok 11\n","ok 12\n"); + +print $a,@b,@c,%d,$x,$y; diff --git a/t/op/magic.t b/t/op/magic.t new file mode 100644 index 0000000000..f027d60d42 --- /dev/null +++ b/t/op/magic.t @@ -0,0 +1,32 @@ +#!./perl + +# $Header: magic.t,v 4.0 91/03/20 01:53:35 lwall Locked $ + +$| = 1; # command buffering + +print "1..5\n"; + +eval '$ENV{"foo"} = "hi there";'; # check that ENV is inited inside eval +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";} + +# 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', '$| = 1; # command buffering', + +'-e', '$SIG{"INT"} = "ok3"; kill 2,$$;', +'-e', '$SIG{"INT"} = "IGNORE"; kill 2,$$; print "ok 4\n";', +'-e', '$SIG{"INT"} = "DEFAULT"; kill 2,$$; print "not ok\n";', + +'-e', 'sub ok3 { print "ok 3\n" if pop(@_) eq "INT"; }'; + +@val1 = @ENV{keys(%ENV)}; # can we slice ENV? +@val2 = values(%ENV); + +print join(':',@val1) eq join(':',@val2) ? "ok 5\n" : "not ok 5\n"; diff --git a/t/op/mkdir.t b/t/op/mkdir.t new file mode 100644 index 0000000000..9186aa54e3 --- /dev/null +++ b/t/op/mkdir.t @@ -0,0 +1,15 @@ +#!./perl + +# $Header: mkdir.t,v 4.0 91/03/20 01:53:39 lwall Locked $ + +print "1..7\n"; + +`rm -rf blurfl`; + +print (mkdir('blurfl',0777) ? "ok 1\n" : "not ok 1\n"); +print (mkdir('blurfl',0777) ? "not ok 2\n" : "ok 2\n"); +print ($! =~ /exist/ ? "ok 3\n" : "not 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/t/op/oct.t b/t/op/oct.t new file mode 100644 index 0000000000..1a9a92ec58 --- /dev/null +++ b/t/op/oct.t @@ -0,0 +1,9 @@ +#!./perl + +# $Header: oct.t,v 4.0 91/03/20 01:53:43 lwall Locked $ + +print "1..3\n"; + +if (oct('01234') == 01234) {print "ok 1\n";} else {print "not ok 1\n";} +if (oct('0x1234') == 0x1234) {print "ok 2\n";} else {print "not ok 2\n";} +if (hex('01234') == 0x1234) {print "ok 3\n";} else {print "not ok 3\n";} diff --git a/t/op/ord.t b/t/op/ord.t new file mode 100644 index 0000000000..d95824f731 --- /dev/null +++ b/t/op/ord.t @@ -0,0 +1,14 @@ +#!./perl + +# $Header: ord.t,v 4.0 91/03/20 01:53:50 lwall Locked $ + +print "1..2\n"; + +# compile time evaluation + +if (ord('A') == 65) {print "ok 1\n";} else {print "not ok 1\n";} + +# run time evaluation + +$x = 'ABC'; +if (ord($x) == 65) {print "ok 2\n";} else {print "not ok 2\n";} diff --git a/t/op/pack.t b/t/op/pack.t new file mode 100644 index 0000000000..aa498c5846 --- /dev/null +++ b/t/op/pack.t @@ -0,0 +1,20 @@ +#!./perl + +# $Header: pack.t,v 4.0 91/03/20 01:53:57 lwall Locked $ + +print "1..3\n"; + +$format = "c2x5CCxsdila6"; +# 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"); diff --git a/t/op/pat.t b/t/op/pat.t new file mode 100644 index 0000000000..c770391dce --- /dev/null +++ b/t/op/pat.t @@ -0,0 +1,120 @@ +#!./perl + +# $Header: pat.t,v 4.0 91/03/20 01:54:01 lwall Locked $ + +print "1..43\n"; + +$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"; diff --git a/t/op/push.t b/t/op/push.t new file mode 100644 index 0000000000..721b63f2f7 --- /dev/null +++ b/t/op/push.t @@ -0,0 +1,44 @@ +#!./perl + +# $Header: push.t,v 4.0 91/03/20 01:54:07 lwall Locked $ + +@tests = split(/\n/, <<EOF); +0 3, 0 1 2, 3 4 5 6 7 +0 0 a b c, , a b c 0 1 2 3 4 5 6 7 +8 0 a b c, , 0 1 2 3 4 5 6 7 a b c +7 0 6.5, , 0 1 2 3 4 5 6 6.5 7 +1 0 a b c d e f g h i j,, 0 a b c d e f g h i j 1 2 3 4 5 6 7 +0 1 a, 0, a 1 2 3 4 5 6 7 +1 6 x y z, 1 2 3 4 5 6, 0 x y z 7 +0 7 x y z, 0 1 2 3 4 5 6, x y z 7 +1 7 x y z, 1 2 3 4 5 6 7, 0 x y z +4, 4 5 6 7, 0 1 2 3 +-4, 4 5 6 7, 0 1 2 3 +EOF + +print "1..", 2 + @tests, "\n"; +die "blech" unless @tests; + +@x = (1,2,3); +push(@x,@x); +if (join(':',@x) eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} +push(x,4); +if (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";} + +$test = 3; +foreach $line (@tests) { + ($list,$get,$leave) = split(/,\t*/,$line); + @list = split(' ',$list); + @get = split(' ',$get); + @leave = split(' ',$leave); + @x = (0,1,2,3,4,5,6,7); + @got = splice(@x,@list); + if (join(':',@got) eq join(':',@get) && + join(':',@x) eq join(':',@leave)) { + print "ok ",$test++,"\n"; + } + else { + print "not ok ",$test++," got: @got == @get left: @x == @leave\n"; + } +} + diff --git a/t/op/range.t b/t/op/range.t new file mode 100644 index 0000000000..9ab7892636 --- /dev/null +++ b/t/op/range.t @@ -0,0 +1,36 @@ +#!./perl + +# $Header: range.t,v 4.0 91/03/20 01:54:11 lwall Locked $ + +print "1..8\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"; diff --git a/t/op/re_tests b/t/op/re_tests new file mode 100644 index 0000000000..01d9940216 --- /dev/null +++ b/t/op/re_tests @@ -0,0 +1,137 @@ +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 +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 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 - c - - +a[ - c - - +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 +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 - - +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 - c - - +((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*? - c - - +(a*)* - c - - +(a*)+ - c - - +(a|)* - c - - +(a*|b)* - c - - +(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 - - +a* y $& +([abc])*d abbbcd y $&-$1 abbbcd-c +([abc])*bcd abcd y $&-$1 abcd-a +a|b|c|d|e e y $& e +(a|b|c|d|e)f ef y $&-$1 ef-e +((a*|b))* - c - - +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))))))))))\41 aa n - - +((((((((((a))))))))))\41 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 diff --git a/t/op/read.t b/t/op/read.t new file mode 100644 index 0000000000..019324ce33 --- /dev/null +++ b/t/op/read.t @@ -0,0 +1,19 @@ +#!./perl + +# $Header: read.t,v 4.0 91/03/20 01:54:16 lwall Locked $ + +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,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/t/op/regexp.t b/t/op/regexp.t new file mode 100644 index 0000000000..92f084a7f0 --- /dev/null +++ b/t/op/regexp.t @@ -0,0 +1,33 @@ +#!./perl + +# $Header: regexp.t,v 4.0 91/03/20 01:54:22 lwall Locked $ + +open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests') + || die "Can't open re_tests"; +while (<TESTS>) { } +$numtests = $.; +close(TESTS); + +print "1..$numtests\n"; +open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests') + || die "Can't open re_tests"; +while (<TESTS>) { + ($pat, $subject, $result, $repl, $expect) = split(/[\t\n]/,$_); + $input = join(':',$pat,$subject,$result,$repl,$expect); + eval "\$match = (\$subject =~ \$pat); \$got = \"$repl\";"; + if ($result eq 'c') { + if ($@ ne '') {print "ok $.\n";} else {print "not ok $.\n";} + } + elsif ($result eq 'n') { + if (!$match) {print "ok $.\n";} else {print "not ok $. $input => $got\n";} + } + else { + if ($match && $got eq $expect) { + print "ok $.\n"; + } + else { + print "not ok $. $input => $got\n"; + } + } +} +close(TESTS); diff --git a/t/op/repeat.t b/t/op/repeat.t new file mode 100644 index 0000000000..a494b99f96 --- /dev/null +++ b/t/op/repeat.t @@ -0,0 +1,42 @@ +#!./perl + +# $Header: repeat.t,v 4.0 91/03/20 01:54:26 lwall Locked $ + +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/t/op/s.t b/t/op/s.t new file mode 100644 index 0000000000..323d374809 --- /dev/null +++ b/t/op/s.t @@ -0,0 +1,179 @@ +#!./perl + +# $Header: s.t,v 4.0 91/03/20 01:54:30 lwall Locked $ + +print "1..51\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+/$&*2/e; # yields 'abc246xyz' +print $_ eq 'abc246xyz' ? "ok 40\n" : "not ok 40\n"; +s/\d+/sprintf("%5d",$&)/e; # yields 'abc 246xyz' +print $_ eq 'abc 246xyz' ? "ok 41\n" : "not ok 41\n"; +s/\w/$& 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"; + diff --git a/t/op/sleep.t b/t/op/sleep.t new file mode 100644 index 0000000000..c26d397d2f --- /dev/null +++ b/t/op/sleep.t @@ -0,0 +1,8 @@ +#!./perl + +# $Header: sleep.t,v 4.0 91/03/20 01:54:34 lwall Locked $ + +print "1..1\n"; + +$x = sleep 2; +if ($x >= 2 && $x <= 10) {print "ok 1\n";} else {print "not ok 1 $x\n";} diff --git a/t/op/sort.t b/t/op/sort.t new file mode 100644 index 0000000000..b1b2202d2b --- /dev/null +++ b/t/op/sort.t @@ -0,0 +1,39 @@ +#!./perl + +# $Header: sort.t,v 4.0 91/03/20 01:54:38 lwall Locked $ + +print "1..8\n"; + +sub reverse { $a lt $b ? 1 : $a gt $b ? -1 : 0; } + +@harry = ('dog','cat','x','Cain','Abel'); +@george = ('gone','chased','yz','Punished','Axed'); + +$x = join('', sort @harry); +print ($x eq 'AbelCaincatdogx' ? "ok 1\n" : "not ok 1\n"); + +$x = join('', sort reverse @harry); +print ($x eq 'xdogcatCainAbel' ? "ok 2\n" : "not ok 2\n"); + +$x = join('', sort @george, 'to', @harry); +print ($x eq 'AbelAxedCainPunishedcatchaseddoggonetoxyz'?"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"); diff --git a/t/op/split.t b/t/op/split.t new file mode 100644 index 0000000000..34327cbd42 --- /dev/null +++ b/t/op/split.t @@ -0,0 +1,57 @@ +#!./perl + +# $Header: split.t,v 4.0 91/03/20 01:54:42 lwall Locked $ + +print "1..12\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? +$foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1`; +print $foo =~ /DEBUGGING/ || $foo =~ /num\(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"; + diff --git a/t/op/sprintf.t b/t/op/sprintf.t new file mode 100644 index 0000000000..6155612aeb --- /dev/null +++ b/t/op/sprintf.t @@ -0,0 +1,8 @@ +#!./perl + +# $Header: sprintf.t,v 4.0 91/03/20 01:54:46 lwall Locked $ + +print "1..1\n"; + +$x = sprintf("%3s %-4s%%foo %5d%c%3.1f","hi",123,456,65,3.0999); +if ($x eq ' hi 123 %foo 456A3.1') {print "ok 1\n";} else {print "not ok 1 '$x'\n";} diff --git a/t/op/stat.t b/t/op/stat.t new file mode 100644 index 0000000000..8ba8e54a5d --- /dev/null +++ b/t/op/stat.t @@ -0,0 +1,153 @@ +#!./perl + +# $Header: stat.t,v 4.0 91/03/20 01:54:55 lwall Locked $ + +print "1..56\n"; + +chop($cwd = `pwd`); + +unlink "Op.stat.tmp"; +open(foo, ">Op.stat.tmp"); + +($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 ($mtime && $mtime == $ctime) {print "ok 2\n";} else {print "not ok 2\n";} + +print foo "Now is the time for all good men to come to.\n"; +close(foo); + +sleep 2; + +`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 ($nlink == 2) {print "ok 3\n";} else {print "not ok 3\n";} +if (($mtime && $mtime != $ctime) || $cwd =~ m#/afs/#) { + print "ok 4\n"; +} +else { + print "not ok 4\n"; +} +print "#4 :$mtime: != :$ctime:\n"; + +`cp /dev/null 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";} + +`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 +`echo hi >Op.stat.tmp`; +chmod 0,'Op.stat.tmp'; +eval '$> = 1;'; # so switch uid (may not be implemented) +if (!$> || ! -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 (-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 (`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";} +`rm -f Op.stat.tmp Op.stat.tmp2`; +if (! -e 'Op.stat.tmp') {print "ok 28\n";} else {print "not ok 28\n";} + +if (-c '/dev/tty') {print "ok 29\n";} else {print "not ok 29\n";} +if (! -c '.') {print "ok 30\n";} else {print "not ok 30\n";} + +if (! -e '/dev/printer' || -c '/dev/printer' || -S '/dev/printer') + {print "ok 31\n";} +else + {print "not ok 31\n";} +if (! -S '.') {print "ok 32\n";} else {print "not ok 32\n";} + +if (! -e '/dev/mt0' || -b '/dev/mt0') + {print "ok 33\n";} +else + {print "not ok 33\n";} +if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";} + +$cnt = $uid = 0; + +die "Can't run op/stat.t test 35 without pwd working" unless $cwd; +chdir '/usr/bin' || die "Can't cd to /usr/bin"; +while (defined($_ = <*>)) { + $cnt++; + $uid++ if -u; + last if $uid && $uid < $cnt; +} +chdir $cwd || die "Can't cd back to $cwd"; + +# I suppose this is going to fail somewhere... +if ($uid > 0 && $uid < $cnt) {print "ok 35\n";} else {print "not ok 35\n";} + +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";} +open(null,"/dev/null"); +if (! -t null || -e '/xenix') {print "ok 39\n";} else {print "not ok 39\n";} +close(null); +if (-t) {print "ok 40\n";} else {print "not ok 40\n";} + +# 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') {print "ok 43\n";} else {print "not ok 43\n";} +if (! -T './perl') {print "ok 44\n";} else {print "not ok 44\n";} + +open(foo,'op/stat.t'); +if (-T foo) {print "ok 45\n";} else {print "not ok 45\n";} +if (! -B foo) {print "ok 46\n";} else {print "not ok 46\n";} +$_ = <foo>; +if (/perl/) {print "ok 47\n";} else {print "not ok 47\n";} +if (-T foo) {print "ok 48\n";} else {print "not ok 48\n";} +if (! -B foo) {print "ok 49\n";} else {print "not ok 49\n";} +close(foo); + +open(foo,'op/stat.t'); +$_ = <foo>; +if (/perl/) {print "ok 50\n";} else {print "not ok 50\n";} +if (-T foo) {print "ok 51\n";} else {print "not ok 51\n";} +if (! -B foo) {print "ok 52\n";} else {print "not ok 52\n";} +seek(foo,0,0); +if (-T foo) {print "ok 53\n";} else {print "not ok 53\n";} +if (! -B foo) {print "ok 54\n";} else {print "not ok 54\n";} +close(foo); + +if (-T '/dev/null') {print "ok 55\n";} else {print "not ok 55\n";} +if (-B '/dev/null') {print "ok 56\n";} else {print "not ok 56\n";} diff --git a/t/op/study.t b/t/op/study.t new file mode 100644 index 0000000000..01e33fa613 --- /dev/null +++ b/t/op/study.t @@ -0,0 +1,69 @@ +#!./perl + +# $Header: study.t,v 4.0 91/03/20 01:54:59 lwall Locked $ + +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/t/op/substr.t b/t/op/substr.t new file mode 100644 index 0000000000..12ad531c49 --- /dev/null +++ b/t/op/substr.t @@ -0,0 +1,47 @@ +#!./perl + +# $Header: substr.t,v 4.0 91/03/20 01:55:05 lwall Locked $ + +print "1..22\n"; + +$a = 'abcdefxyz'; + +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,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n"); + +$[ = 1; + +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,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n"); + +$[ = 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"; +y/a/a/; +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"); +print (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n"); +print (substr($a,999) eq '' ? "ok 22\n" : "not ok 22\n"); diff --git a/t/op/time.t b/t/op/time.t new file mode 100644 index 0000000000..28635219fe --- /dev/null +++ b/t/op/time.t @@ -0,0 +1,43 @@ +#!./perl + +# $Header: time.t,v 4.0 91/03/20 01:55:09 lwall Locked $ + +print "1..5\n"; + +($beguser,$begsys) = times; + +$beg = time; + +while (($now = time) == $beg) {} + +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; + 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";} + +($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:365:366:-365:-366:",':' . ($localyday - $yday) . ':') > 0) + {print "ok 5\n";} +else + {print "not ok 5\n";} diff --git a/t/op/undef.t b/t/op/undef.t new file mode 100644 index 0000000000..fc73cf85d5 --- /dev/null +++ b/t/op/undef.t @@ -0,0 +1,56 @@ +#!./perl + +# $Header: undef.t,v 4.0 91/03/20 01:55:16 lwall Locked $ + +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/t/op/unshift.t b/t/op/unshift.t new file mode 100644 index 0000000000..fec68e183b --- /dev/null +++ b/t/op/unshift.t @@ -0,0 +1,14 @@ +#!./perl + +# $Header: unshift.t,v 4.0 91/03/20 01:55:21 lwall Locked $ + +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/t/op/vec.t b/t/op/vec.t new file mode 100644 index 0000000000..e8fe018ba8 --- /dev/null +++ b/t/op/vec.t @@ -0,0 +1,24 @@ +#!./perl + +# $Header: vec.t,v 4.0 91/03/20 01:55:28 lwall Locked $ + +print "1..13\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"; + diff --git a/t/op/write.t b/t/op/write.t new file mode 100644 index 0000000000..e51a09088c --- /dev/null +++ b/t/op/write.t @@ -0,0 +1,129 @@ +#!./perl + +# $Header: write.t,v 4.0 91/03/20 01:55:34 lwall Locked $ + +print "1..3\n"; + +format OUT = +the quick brown @<< +$fox +jumped +@* +$multiline +^<<<<<<<<< +$foo +^<<<<<<<<< +$foo +^<<<<<<... +$foo +now @<<the@>>>> for all@|||||men to come @<<<< +'i' . 's', "time\n", $good, 'to' +. + +open(OUT, '>Op.write.tmp') || die "Can't create Op.write.tmp"; + +$fox = 'foxiness'; +$good = 'good'; +$multiline = "forescore\nand\nseven years\n"; +$foo = 'when in the course of human events it becomes necessary'; +write(OUT); +close OUT; + +$right = +"the quick brown fox +jumped +forescore +and +seven years +when in +the course +of huma... +now is the time for all good men to come to\n"; + +if (`cat Op.write.tmp` eq $right) + { print "ok 1\n"; unlink 'Op.write.tmp'; } +else + { print "not ok 1\n"; } + +format OUT2 = +the quick brown @<< +$fox +jumped +@* +$multiline +^<<<<<<<<< ~~ +$foo +now @<<the@>>>> for all@|||||men to come @<<<< +'i' . 's', "time\n", $good, 'to' +. + +open(OUT2, '>Op.write.tmp') || 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 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 +^<<<<<<<<< ~~ +$foo +now @<<the@>>>> for all@|||||men to come @<<<< +'i' . 's', "time\n", $good, 'to' +. +EOFORMAT + +open(OUT2, '>Op.write.tmp') || die "Can't create Op.write.tmp"; + +$fox = 'foxiness'; +$good = 'good'; +$multiline = "forescore\nand\nseven years\n"; +$foo = 'when in the course of human events it becomes necessary'; +write(OUT2); +close OUT2; + +$right = +"the brown quick fox +jumped +forescore +and +seven years +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"; } + |