summaryrefslogtreecommitdiff
path: root/t/op
diff options
context:
space:
mode:
Diffstat (limited to 't/op')
-rw-r--r--t/op/64bitint.t193
-rwxr-xr-xt/op/args.t23
-rwxr-xr-xt/op/arith.t9
-rwxr-xr-xt/op/do.t10
-rwxr-xr-xt/op/gv.t52
-rw-r--r--t/op/lfs.t27
-rwxr-xr-xt/op/method.t20
-rwxr-xr-xt/op/misc.t4
-rw-r--r--t/op/my_stash.t31
-rwxr-xr-xt/op/numconvert.t8
-rwxr-xr-xt/op/pack.t12
-rwxr-xr-xt/op/pat.t11
-rw-r--r--t/op/re_tests24
-rwxr-xr-xt/op/runlevel.t15
-rwxr-xr-xt/op/split.t11
-rwxr-xr-xt/op/sprintf.t282
-rwxr-xr-xt/op/stat.t1
-rwxr-xr-xt/op/taint.t15
-rwxr-xr-xt/op/tr.t128
-rwxr-xr-xt/op/vec.t12
-rwxr-xr-xt/op/wantarray.t6
-rwxr-xr-xt/op/write.t19
22 files changed, 772 insertions, 141 deletions
diff --git a/t/op/64bitint.t b/t/op/64bitint.t
index f59c953825..691d44e240 100644
--- a/t/op/64bitint.t
+++ b/t/op/64bitint.t
@@ -123,85 +123,106 @@ $x = $q - $r;
print "not " unless $x == -11111110111 && -$x > $f;
print "ok 22\n";
-$x = $q * 1234567;
-print "not " unless $x == 15241567763770867 && $x > $f;
-print "ok 23\n";
-
-$x /= 1234567;
-print "not " unless $x == $q && $x > $f;
-print "ok 24\n";
-
-$x = 98765432109 % 12345678901;
-print "not " unless $x == 901;
-print "ok 25\n";
-
-# The following 12 tests adapted from op/inc.
-
-$a = 9223372036854775807;
-$c = $a++;
-print "not " unless $a == 9223372036854775808;
-print "ok 26\n";
-
-$a = 9223372036854775807;
-$c = ++$a;
-print "not " unless $a == 9223372036854775808 && $c == $a;
-print "ok 27\n";
-
-$a = 9223372036854775807;
-$c = $a + 1;
-print "not " unless $a == 9223372036854775807 && $c == 9223372036854775808;
-print "ok 28\n";
-
-$a = -9223372036854775808;
-$c = $a--;
-print "not " unless $a == -9223372036854775809 && $c == -9223372036854775808;
-print "ok 29\n";
-
-$a = -9223372036854775808;
-$c = --$a;
-print "not " unless $a == -9223372036854775809 && $c == $a;
-print "ok 30\n";
-
-$a = -9223372036854775808;
-$c = $a - 1;
-print "not " unless $a == -9223372036854775808 && $c == -9223372036854775809;
-print "ok 31\n";
-
-$a = 9223372036854775808;
-$a = -$a;
-$c = $a--;
-print "not " unless $a == -9223372036854775809 && $c == -9223372036854775808;
-print "ok 32\n";
-
-$a = 9223372036854775808;
-$a = -$a;
-$c = --$a;
-print "not " unless $a == -9223372036854775809 && $c == $a;
-print "ok 33\n";
-
-$a = 9223372036854775808;
-$a = -$a;
-$c = $a - 1;
-print "not " unless $a == -9223372036854775808 && $c == -9223372036854775809;
-print "ok 34\n";
-
-$a = 9223372036854775808;
-$b = -$a;
-$c = $b--;
-print "not " unless $b == -$a-1 && $c == -$a;
-print "ok 35\n";
-
-$a = 9223372036854775808;
-$b = -$a;
-$c = --$b;
-print "not " unless $b == -$a-1 && $c == $b;
-print "ok 36\n";
-
-$a = 9223372036854775808;
-$b = -$a;
-$b = $b - 1;
-print "not " unless $b == -(++$a);
-print "ok 37\n";
+if ($^O ne 'unicos') {
+ $x = $q * 1234567;
+ print "not " unless $x == 15241567763770867 && $x > $f;
+ print "ok 23\n";
+
+ $x /= 1234567;
+ print "not " unless $x == $q && $x > $f;
+ print "ok 24\n";
+
+ $x = 98765432109 % 12345678901;
+ print "not " unless $x == 901;
+ print "ok 25\n";
+
+ # The following 12 tests adapted from op/inc.
+
+ $a = 9223372036854775807;
+ $c = $a++;
+ print "not " unless $a == 9223372036854775808;
+ print "ok 26\n";
+
+ $a = 9223372036854775807;
+ $c = ++$a;
+ print "not "
+ unless $a == 9223372036854775808 && $c == $a;
+ print "ok 27\n";
+
+ $a = 9223372036854775807;
+ $c = $a + 1;
+ print "not "
+ unless $a == 9223372036854775807 && $c == 9223372036854775808;
+ print "ok 28\n";
+
+ $a = -9223372036854775808;
+ $c = $a--;
+ print "not "
+ unless $a == -9223372036854775809 && $c == -9223372036854775808;
+ print "ok 29\n";
+
+ $a = -9223372036854775808;
+ $c = --$a;
+ print "not "
+ unless $a == -9223372036854775809 && $c == $a;
+ print "ok 30\n";
+
+ $a = -9223372036854775808;
+ $c = $a - 1;
+ print "not "
+ unless $a == -9223372036854775808 && $c == -9223372036854775809;
+ print "ok 31\n";
+
+ $a = 9223372036854775808;
+ $a = -$a;
+ $c = $a--;
+ print "not "
+ unless $a == -9223372036854775809 && $c == -9223372036854775808;
+ print "ok 32\n";
+
+ $a = 9223372036854775808;
+ $a = -$a;
+ $c = --$a;
+ print "not "
+ unless $a == -9223372036854775809 && $c == $a;
+ print "ok 33\n";
+
+ $a = 9223372036854775808;
+ $a = -$a;
+ $c = $a - 1;
+ print "not "
+ unless $a == -9223372036854775808 && $c == -9223372036854775809;
+ print "ok 34\n";
+
+ $a = 9223372036854775808;
+ $b = -$a;
+ $c = $b--;
+ print "not "
+ unless $b == -$a-1 && $c == -$a;
+ print "ok 35\n";
+
+ $a = 9223372036854775808;
+ $b = -$a;
+ $c = --$b;
+ print "not "
+ unless $b == -$a-1 && $c == $b;
+ print "ok 36\n";
+
+ $a = 9223372036854775808;
+ $b = -$a;
+ $b = $b - 1;
+ print "not "
+ unless $b == -(++$a);
+ print "ok 37\n";
+
+} else {
+ # Unicos has imprecise doubles (14 decimal digits or so),
+ # especially if operating near the UV/IV limits the low-order bits
+ # become mangled even by simple arithmetic operations.
+ for (23..37) {
+ print "ok #_ # skipped: too imprecise numbers\n";
+ }
+}
$x = '';
@@ -233,17 +254,23 @@ print "ok 45\n";
print "not " unless (0x8000000000000000 | 1) == 0x8000000000000001;
print "ok 46\n";
-print "not " unless (0xf000000000000000 & 0x8000000000000000) == 0x8000000000000000;
+print "not "
+ unless (0xf000000000000000 & 0x8000000000000000) == 0x8000000000000000;
print "ok 47\n";
-print "not " unless (0xf000000000000000 ^ 0xfffffffffffffff0) == 0x0ffffffffffffff0;
+print "not "
+ unless (0xf000000000000000 ^ 0xfffffffffffffff0) == 0x0ffffffffffffff0;
print "ok 48\n";
-print "not " unless (sprintf "%b", ~0) eq '1111111111111111111111111111111111111111111111111111111111111111';
+print "not "
+ unless (sprintf "%b", ~0) eq
+ '1111111111111111111111111111111111111111111111111111111111111111';
print "ok 49\n";
-print "not " unless (sprintf "%64b", ~0) eq '1111111111111111111111111111111111111111111111111111111111111111';
+print "not "
+ unless (sprintf "%64b", ~0) eq
+ '1111111111111111111111111111111111111111111111111111111111111111';
print "ok 50\n";
print "not " unless (sprintf "%d", ~0>>1) eq '9223372036854775807';
diff --git a/t/op/args.t b/t/op/args.t
index 48bf5afec0..ce2c398865 100755
--- a/t/op/args.t
+++ b/t/op/args.t
@@ -1,6 +1,6 @@
#!./perl
-print "1..8\n";
+print "1..9\n";
# test various operations on @_
@@ -52,3 +52,24 @@ sub new4 { goto &new2 }
print "# got [@$y], expected [a b c y]\nnot " unless "@$y" eq "a b c y";
print "ok $ord\n";
}
+
+# see if POPSUB gets to see the right pad across a dounwind() with
+# a reified @_
+
+sub methimpl {
+ my $refarg = \@_;
+ die( "got: @_\n" );
+}
+
+sub method {
+ &methimpl;
+}
+
+sub try {
+ eval { method('foo', 'bar'); };
+ print "# $@" if $@;
+}
+
+for (1..5) { try() }
+++$ord;
+print "ok $ord\n";
diff --git a/t/op/arith.t b/t/op/arith.t
index fe2f0f458b..5b04f9365f 100755
--- a/t/op/arith.t
+++ b/t/op/arith.t
@@ -1,6 +1,6 @@
#!./perl
-print "1..8\n";
+print "1..12\n";
sub try ($$) {
print +($_[1] ? "ok" : "not ok"), " $_[0]\n";
@@ -21,3 +21,10 @@ try 5, abs( 13e21 % 4e21 - 1e21) < $limit;
try 6, abs(-13e21 % 4e21 - 3e21) < $limit;
try 7, abs( 13e21 % -4e21 - -3e21) < $limit;
try 8, abs(-13e21 % -4e21 - -1e21) < $limit;
+
+# UVs should behave properly
+
+try 9, 4063328477 % 65535 == 27407;
+try 10, 4063328477 % 4063328476 == 1;
+try 11, 4063328477 % 2031664238 == 1;
+try 12, 2031664238 % 4063328477 == 2031664238;
diff --git a/t/op/do.t b/t/op/do.t
index 87ec08d300..3fc44413d9 100755
--- a/t/op/do.t
+++ b/t/op/do.t
@@ -21,18 +21,18 @@ 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"; }
+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"; }
+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"; }
+if ($result eq 'value') { print "ok 8\n"; } else { print "not ok 8\n"; }
sub blather {
print @_;
diff --git a/t/op/gv.t b/t/op/gv.t
index 04905cd400..bb10b7538e 100755
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -11,7 +11,7 @@ BEGIN {
use warnings;
-print "1..30\n";
+print "1..41\n";
# type coersion on assignment
$foo = 'foo';
@@ -97,15 +97,19 @@ $x = "ok 17\n";
%x = ("ok 19" => "\n");
sub x { "ok 20\n" }
print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}};
+format x =
+ok 21
+.
+print ref *x{FORMAT} eq "FORMAT" ? "ok 21\n" : "not ok 21\n";
*x = *STDOUT;
-print *{*x{GLOB}} eq "*main::STDOUT" ? "ok 21\n" : "not ok 21\n";
-print {*x{IO}} "ok 22\n";
-print {*x{FILEHANDLE}} "ok 23\n";
+print *{*x{GLOB}} eq "*main::STDOUT" ? "ok 22\n" : "not ok 22\n";
+print {*x{IO}} "ok 23\n";
+print {*x{FILEHANDLE}} "ok 24\n";
# test if defined() doesn't create any new symbols
{
- my $test = 23;
+ my $test = 24;
my $a = "SYM000";
print "not " if defined *{$a};
@@ -128,6 +132,42 @@ print {*x{FILEHANDLE}} "ok 23\n";
++$test; &{$a};
}
+# although it *should* if you're talking about magicals
+
+{
+ my $test = 30;
+
+ my $a = "]";
+ print "not " unless defined ${$a};
+ ++$test; print "ok $test\n";
+ print "not " unless defined *{$a};
+ ++$test; print "ok $test\n";
+
+ $a = "1";
+ "o" =~ /(o)/;
+ print "not " unless ${$a};
+ ++$test; print "ok $test\n";
+ print "not " unless defined *{$a};
+ ++$test; print "ok $test\n";
+ $a = "2";
+ print "not " if ${$a};
+ ++$test; print "ok $test\n";
+ print "not " unless defined *{$a};
+ ++$test; print "ok $test\n";
+ $a = "1x";
+ print "not " if defined ${$a};
+ ++$test; print "ok $test\n";
+ print "not " if defined *{$a};
+ ++$test; print "ok $test\n";
+ $a = "11";
+ "o" =~ /(((((((((((o)))))))))))/;
+ print "not " unless ${$a};
+ ++$test; print "ok $test\n";
+ print "not " unless defined *{$a};
+ ++$test; print "ok $test\n";
+}
+
+
# does pp_readline() handle glob-ness correctly?
{
@@ -137,4 +177,4 @@ print {*x{FILEHANDLE}} "ok 23\n";
}
__END__
-ok 30
+ok 41
diff --git a/t/op/lfs.t b/t/op/lfs.t
index e704f6f57b..97c920c2cf 100644
--- a/t/op/lfs.t
+++ b/t/op/lfs.t
@@ -8,7 +8,7 @@ BEGIN {
# Don't bother if there are no quad offsets.
require Config; import Config;
if ($Config{lseeksize} < 8) {
- print "1..0\n# no 64-bit file offsets\n";
+ print "1..0 # Skip: no 64-bit file offsets\n";
exit(0);
}
}
@@ -46,14 +46,14 @@ print "# checking whether we have sparse files...\n";
# Known have-nots.
if ($^O eq 'win32' || $^O eq 'vms') {
- print "1..0\n# no sparse files (because this is $^O) \n";
+ print "1..0 # Skip: no sparse files (because this is $^O) \n";
bye();
}
# Known haves that have problems running this test
# (for example because they do not support sparse files, like UNICOS)
if ($^O eq 'unicos') {
- print "1..0\n# large files known to work but unable to test them here ($^O)\n";
+ print "1..0 # Skip: large files known to work but unable to test them here ($^O)\n";
bye();
}
@@ -102,7 +102,7 @@ zap();
unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 &&
$s1[11] == $s2[11] && $s1[12] == $s2[12]) {
- print "1..0\n#no sparse files?\n";
+ print "1..0 # Skip: no sparse files?\n";
bye;
}
@@ -110,13 +110,22 @@ print "# we seem to have sparse files...\n";
# By now we better be sure that we do have sparse files:
# if we are not, the following will hog 5 gigabytes of disk. Ooops.
+# This may fail by producing some signal; run in a subprocess first for safety
$ENV{LC_ALL} = "C";
+my $r = system '../perl', '-e', <<'EOF';
+open(BIG, ">big");
+seek(BIG, 5_000_000_000, 0);
+print BIG "big";
+exit 0;
+EOF
+
open(BIG, ">big") or do { warn "open failed: $!\n"; bye };
binmode BIG;
-unless (seek(BIG, 5_000_000_000, $SEEK_SET)) {
- print "1..0\n# seeking past 2GB failed: $!\n";
+if ($r or not seek(BIG, 5_000_000_000, $SEEK_SET)) {
+ my $err = $r ? 'signal '.($r & 0x7f) : $!;
+ print "1..0 # Skip: seeking past 2GB failed: $err\n";
explain();
bye();
}
@@ -129,9 +138,9 @@ my $close = close BIG;
print "# close failed: $!\n" unless $close;
unless ($print && $close) {
if ($! =~/too large/i) {
- print "1..0\n# writing past 2GB failed: process limits?\n";
+ print "1..0 # Skip: writing past 2GB failed: process limits?\n";
} elsif ($! =~ /quota/i) {
- print "1..0\n# filesystem quota limits?\n";
+ print "1..0 # Skip: filesystem quota limits?\n";
}
explain();
bye();
@@ -142,7 +151,7 @@ unless ($print && $close) {
print "# @s\n";
unless ($s[7] == 5_000_000_003) {
- print "1..0\n# not configured to use large files?\n";
+ print "1..0 # Skip: not configured to use large files?\n";
explain();
bye();
}
diff --git a/t/op/method.t b/t/op/method.t
index 1c6f3c5d9d..6e25310734 100755
--- a/t/op/method.t
+++ b/t/op/method.t
@@ -4,7 +4,12 @@
# test method calls and autoloading.
#
-print "1..49\n";
+BEGIN {
+ chdir 't' if -d 't';
+ unshift @INC, '../lib' if -d '../lib';
+}
+
+print "1..53\n";
@A::ISA = 'B';
@B::ISA = 'C';
@@ -167,3 +172,16 @@ test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined");
test(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1);
test(A2->foo(), "foo");
}
+
+{
+ test(do { use Config; eval 'Config->foo()';
+ $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1);
+ test(do { use Config; eval '$d = bless {}, "Config"; $d->foo()';
+ $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1);
+}
+
+test(do { eval 'E->foo()';
+ $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1);
+test(do { eval '$e = bless {}, "E"; $e->foo()';
+ $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1);
+
diff --git a/t/op/misc.t b/t/op/misc.t
index 55f459d49b..00abc99b45 100755
--- a/t/op/misc.t
+++ b/t/op/misc.t
@@ -558,3 +558,7 @@ eval "C";
M(C);
EXPECT
Modification of a read-only value attempted at - line 2.
+########
+print qw(ab a\b a\\b);
+EXPECT
+aba\ba\b
diff --git a/t/op/my_stash.t b/t/op/my_stash.t
new file mode 100644
index 0000000000..79f3f28a08
--- /dev/null
+++ b/t/op/my_stash.t
@@ -0,0 +1,31 @@
+#!./perl
+
+package Foo;
+
+BEGIN {
+ unshift @INC, "../lib";
+}
+
+use Test;
+
+plan tests => 7;
+
+use constant MyClass => 'Foo::Bar::Biz::Baz';
+
+{
+ package Foo::Bar::Biz::Baz;
+}
+
+for (qw(Foo Foo:: MyClass __PACKAGE__)) {
+ eval "sub { my $_ \$obj = shift; }";
+ ok ! $@;
+# print $@ if $@;
+}
+
+use constant NoClass => 'Nope::Foo::Bar::Biz::Baz';
+
+for (qw(Nope Nope:: NoClass)) {
+ eval "sub { my $_ \$obj = shift; }";
+ ok $@;
+# print $@ if $@;
+}
diff --git a/t/op/numconvert.t b/t/op/numconvert.t
index 8eb9b6e341..f3c9867a91 100755
--- a/t/op/numconvert.t
+++ b/t/op/numconvert.t
@@ -51,7 +51,13 @@ my $big_iv = do {use integer; $max_uv1 * 16}; # 16 is an arbitrary number here
print "# max_uv1 = $max_uv1, max_uv2 = $max_uv2, big_iv = $big_iv\n";
if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1) {
- print "1..0\n# Unsigned arithmetic is not sane\n";
+ print "1..0 # skipped: unsigned perl arithmetic is not sane";
+ eval { require Config; import Config };
+ use vars qw(%Config);
+ if ($Config{d_quad} eq 'define') {
+ print " (common in 64-bit platforms)";
+ }
+ print "\n";
exit 0;
}
diff --git a/t/op/pack.t b/t/op/pack.t
index dda1cc76d7..5c215c6f0f 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -6,7 +6,7 @@ BEGIN {
require Config; import Config;
}
-print "1..156\n";
+print "1..159\n";
$format = "c2 x5 C C x s d i l a6";
# Need the expression in here to force ary[5] to be numeric. This avoids
@@ -406,3 +406,13 @@ $z = pack <<EOP,'string','etc';
w/A* # Count a BER integer
EOP
print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++;
+
+print 'not ' unless "1.20.300.4000" eq sprintf "%vd", pack("U*",1,20,300,4000);
+print "ok $test\n"; $test++;
+print 'not ' unless "1.20.300.4000" eq
+ sprintf "%vd", pack(" U*",1,20,300,4000);
+print "ok $test\n"; $test++;
+print 'not ' unless v1.20.300.4000 ne
+ sprintf "%vd", pack("C0U*",1,20,300,4000);
+print "ok $test\n"; $test++;
+
diff --git a/t/op/pat.t b/t/op/pat.t
index e00328c91f..81591fc71b 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -4,7 +4,7 @@
# the format supported by op/regexp.t. If you want to add a test
# that does fit that format, add it to op/re_tests, not here.
-print "1..213\n";
+print "1..215\n";
BEGIN {
chdir 't' if -d 't';
@@ -1012,3 +1012,12 @@ EOE
$a and $a =~ /^Object\sS/ or print "# '$a' \nnot ";
print "ok $test\n";
$test++;
+
+# test result of match used as match (!)
+'a1b' =~ ('xyz' =~ /y/) and $` eq 'a' or print "not ";
+print "ok $test\n";
+$test++;
+
+'a1b' =~ ('xyz' =~ /t/) and $` eq 'a' or print "not ";
+print "ok $test\n";
+$test++;
diff --git a/t/op/re_tests b/t/op/re_tests
index 189077c628..38483253d3 100644
--- a/t/op/re_tests
+++ b/t/op/re_tests
@@ -750,4 +750,28 @@ tt+$ xxxtt y - -
^([a-z]:) C:/ n - -
'^\S\s+aa$'m \nx aa y - -
(^|a)b ab y - -
+^([ab]*?)(b)?(c)$ abac y -$2- --
+(\w)?(abc)\1b abcab n - -
+^(?:.,){2}c a,b,c y - -
+^(.,){2}c a,b,c y $1 b,
+^(?:[^,]*,){2}c a,b,c y - -
+^([^,]*,){2}c a,b,c y $1 b,
+^([^,]*,){3}d aaa,b,c,d y $1 c,
+^([^,]*,){3,}d aaa,b,c,d y $1 c,
+^([^,]*,){0,3}d aaa,b,c,d y $1 c,
+^([^,]{1,3},){3}d aaa,b,c,d y $1 c,
+^([^,]{1,3},){3,}d aaa,b,c,d y $1 c,
+^([^,]{1,3},){0,3}d aaa,b,c,d y $1 c,
+^([^,]{1,},){3}d aaa,b,c,d y $1 c,
+^([^,]{1,},){3,}d aaa,b,c,d y $1 c,
+^([^,]{1,},){0,3}d aaa,b,c,d y $1 c,
+^([^,]{0,3},){3}d aaa,b,c,d y $1 c,
+^([^,]{0,3},){3,}d aaa,b,c,d y $1 c,
+^([^,]{0,3},){0,3}d aaa,b,c,d y $1 c,
(?i) y - -
+'(?!\A)x'm a\nxb\n y - -
+^(a(b)?)+$ aba y -$1-$2- -a--
+^(aa(bb)?)+$ aabbaa y -$1-$2- -aa--
+'^.{9}abc.*\n'm 123\nabcabcabcabc\n y - -
+^(a)?a$ a y -$1- --
+^(a)?(?(1)a|b)+$ a n - -
diff --git a/t/op/runlevel.t b/t/op/runlevel.t
index e988ad9362..3865e52070 100755
--- a/t/op/runlevel.t
+++ b/t/op/runlevel.t
@@ -349,3 +349,18 @@ A 1
bar
B 2
bar
+########
+sub n { 0 }
+sub f { my $x = shift; d(); }
+f(n());
+f();
+
+sub d {
+ my $i = 0; my @a;
+ while (do { { package DB; @a = caller($i++) } } ) {
+ @a = @DB::args;
+ for (@a) { print "$_\n"; $_ = '' }
+ }
+}
+EXPECT
+0
diff --git a/t/op/split.t b/t/op/split.t
index 8b9f4ad2f9..78f51f5954 100755
--- a/t/op/split.t
+++ b/t/op/split.t
@@ -2,7 +2,7 @@
# $RCSfile: split.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:26 $
-print "1..25\n";
+print "1..27\n";
$FS = ':';
@@ -109,3 +109,12 @@ print $_ eq "aa b |\naa d |" ? "ok 24\n" : "not ok 24\n# `$_'\n";
$_ = "a : b :c: d";
@ary = split(/\s*:\s*/);
if (($res = join(".",@ary)) eq "a.b.c.d") {print "ok 25\n";} else {print "not ok 25\n# res=`$res' != `a.b.c.d'\n";}
+
+# use of match result as pattern (!)
+'p:q:r:s' eq join ':', split('abc' =~ /b/, 'p1q1r1s') or print "not ";
+print "ok 26\n";
+
+# /^/ treated as /^/m
+$_ = join ':', split /^/, "ab\ncd\nef\n";
+print "not " if $_ ne "ab\n:cd\n:ef\n";
+print "ok 27\n";
diff --git a/t/op/sprintf.t b/t/op/sprintf.t
index 4d54d2c317..c48435592d 100755
--- a/t/op/sprintf.t
+++ b/t/op/sprintf.t
@@ -1,6 +1,10 @@
#!./perl
-# $RCSfile: sprintf.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:27 $
+# Tests sprintf, excluding handling of 64-bit integers or long
+# doubles (if supported), of machine-specific short and long
+# integers, machine-specific floating point exceptions (infinity,
+# not-a-number ...), of the effects of locale, and of features
+# specific to multi-byte characters (under use utf8 and such).
BEGIN {
chdir 't' if -d 't';
@@ -8,31 +12,273 @@ BEGIN {
}
use warnings;
-print "1..4\n";
+while (<DATA>) {
+ s/^\s*>//; s/<\s*$//;
+ push @tests, [split(/<\s*>/, $_, 4)];
+}
+
+print '1..', scalar @tests, "\n";
$SIG{__WARN__} = sub {
if ($_[0] =~ /^Invalid conversion/) {
- $w++;
+ $w = ' INVALID'
} else {
warn @_;
}
};
-$w = 0;
-$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f %b %x %X %#b %#x %#X","hi",123,0,456,0,ord('A'),3.0999,11,171,171,11,171,171);
-if ($x eq ' hi 123 %foo 456 0A3.1 1011 ab AB 0b1011 0xab 0XAB' && $w == 0) {
- print "ok 1\n";
-} else {
- print "not ok 1 '$x'\n";
-}
+for ($i = 1; @tests; $i++) {
+ ($template, $data, $result, $comment) = @{shift @tests};
+ $evalData = eval $data;
+ $w = undef;
+ $x = sprintf(">$template<",
+ defined @$evalData ? @$evalData : $evalData);
+ substr($x, -1, 0) = $w if $w;
+ # $x may have 3 exponent digits, not 2
+ my $y = $x;
+ if ($y =~ s/([Ee][-+])0(\d)/$1$2/) {
+ # if result is left-adjusted, append extra space
+ if ($template =~ /%\+?\-/ and $result =~ / $/) {
+ $y =~ s/<$/ </;
+ }
+ # if result is zero-filled, add extra zero
+ elsif ($template =~ /%\+?0/ and $result =~ /^0/) {
+ $y =~ s/^>0/>00/;
+ }
+ # if result is right-adjusted, prepend extra space
+ elsif ($result =~ /^ /) {
+ $y =~ s/^>/> /;
+ }
+ }
-for $i (2 .. 4) {
- $f = ('%6 .6s', '%6. 6s', '%6.6 s')[$i - 2];
- $w = 0;
- $x = sprintf($f, '');
- if ($x eq $f && $w == 1) {
- print "ok $i\n";
- } else {
- print "not ok $i '$x' '$f' '$w'\n";
+ if ($x eq ">$result<") {
+ print "ok $i\n";
+ }
+ elsif ($y eq ">$result<") # Some C libraries always give
+ { # three-digit exponent
+ print("ok $i >$result< $x # three-digit exponent accepted\n");
+ }
+ else {
+ $y = ($x eq $y ? "" : " => $y");
+ print("not ok $i >$template< >$data< >$result< $x$y",
+ $comment ? " # $comment\n" : "\n");
}
}
+
+# In each of the the following lines, there are three required fields:
+# printf template, data to be formatted (as a Perl expression), and
+# expected result of formatting. An optional fourth field can contain
+# a comment. Each field is delimited by a starting '>' and a
+# finishing '<'; any whitespace outside these start and end marks is
+# not part of the field. If formatting requires more than one data
+# item (for example, if variable field widths are used), the Perl data
+# expression should return a reference to an array having the requisite
+# number of elements. Even so, subterfuge is sometimes required: see
+# tests for %n and %p.
+#
+# template data result
+__END__
+>%6. 6s< >''< >%6. 6s INVALID< >(See use of $w in code above)<
+>%6 .6s< >''< >%6 .6s INVALID<
+>%6.6 s< >''< >%6.6 s INVALID<
+>%A< >''< >%A INVALID<
+>%B< >''< >%B INVALID<
+>%C< >''< >%C INVALID<
+>%D< >0x7fffffff< >2147483647< >Synonym for %ld<
+>%E< >123456.789< >1.234568E+05< >Like %e, but using upper-case "E"<
+>%F< >123456.789< >123456.789000< >Synonym for %f<
+>%G< >1234567.89< >1.23457E+06< >Like %g, but using upper-case "E"<
+>%G< >1234567e96< >1.23457E+102<
+>%G< >.1234567e-101< >1.23457E-102<
+>%G< >12345.6789< >12345.7<
+>%H< >''< >%H INVALID<
+>%I< >''< >%I INVALID<
+>%J< >''< >%J INVALID<
+>%K< >''< >%K INVALID<
+>%L< >''< >%L INVALID<
+>%M< >''< >%M INVALID<
+>%N< >''< >%N INVALID<
+>%O< >2**32-1< >37777777777< >Synonum for %lo<
+>%P< >''< >%P INVALID<
+>%Q< >''< >%Q INVALID<
+>%R< >''< >%R INVALID<
+>%S< >''< >%S INVALID<
+>%T< >''< >%T INVALID<
+>%U< >2**32-1< >4294967295< >Synonum for %lu<
+>%V< >''< >%V INVALID<
+>%W< >''< >%W INVALID<
+>%X< >2**32-1< >FFFFFFFF< >Like %x, but with u/c letters<
+>%#X< >2**32-1< >0XFFFFFFFF<
+>%Y< >''< >%Y INVALID<
+>%Z< >''< >%Z INVALID<
+>%a< >''< >%a INVALID<
+>%b< >2**32-1< >11111111111111111111111111111111<
+>%+b< >2**32-1< >11111111111111111111111111111111<
+>%#b< >2**32-1< >0b11111111111111111111111111111111<
+>%34b< >2**32-1< > 11111111111111111111111111111111<
+>%034b< >2**32-1< >0011111111111111111111111111111111<
+>%-34b< >2**32-1< >11111111111111111111111111111111 <
+>%-034b< >2**32-1< >11111111111111111111111111111111 <
+>%c< >ord('A')< >A<
+>%10c< >ord('A')< > A<
+>%#10c< >ord('A')< > A< ># modifier: no effect<
+>%010c< >ord('A')< >000000000A<
+>%10lc< >ord('A')< > A< >l modifier: no effect<
+>%10hc< >ord('A')< > A< >h modifier: no effect<
+>%10.5c< >ord('A')< > A< >precision: no effect<
+>%-10c< >ord('A')< >A <
+>%d< >123456.789< >123456<
+>%d< >-123456.789< >-123456<
+>%d< >0< >0<
+>%+d< >0< >+0<
+>%0d< >0< >0<
+>%.0d< >0< ><
+>%+.0d< >0< >+<
+>%.0d< >1< >1<
+>%d< >1< >1<
+>%+d< >1< >+1<
+>%#3.2d< >1< > 01< ># modifier: no effect<
+>%3.2d< >1< > 01<
+>%03.2d< >1< >001<
+>%-3.2d< >1< >01 <
+>%-03.2d< >1< >01 < >zero pad + left just.: no effect<
+>%d< >-1< >-1<
+>%+d< >-1< >-1<
+>%hd< >1< >1< >More extensive testing of<
+>%ld< >1< >1< >length modifiers would be<
+>%Vd< >1< >1< >platform-specific<
+>%vd< >chr(1)< >1<
+>%+vd< >chr(1)< >+1<
+>%#vd< >chr(1)< >1<
+>%vd< >"\01\02\03"< >1.2.3<
+>%v.3d< >"\01\02\03"< >001.002.003<
+>%v03d< >"\01\02\03"< >001.002.003<
+>%v-3d< >"\01\02\03"< >1 .2 .3 <
+>%v+-3d< >"\01\02\03"< >+1 .2 .3 <
+>%v4.3d< >"\01\02\03"< > 001. 002. 003<
+>%v04.3d< >"\01\02\03"< >0001.0002.0003<
+>%*v02d< >['-', "\0\7\14"]< >00-07-12<
+>%v.*d< >[3, "\01\02\03"]< >001.002.003<
+>%v0*d< >[3, "\01\02\03"]< >001.002.003<
+>%v-*d< >[3, "\01\02\03"]< >1 .2 .3 <
+>%v+-*d< >[3, "\01\02\03"]< >+1 .2 .3 <
+>%v*.*d< >[4, 3, "\01\02\03"]< > 001. 002. 003<
+>%v0*.*d< >[4, 3, "\01\02\03"]< >0001.0002.0003<
+>%*v0*d< >['-', 2, "\0\7\13"]< >00-07-11<
+>%e< >1234.875< >1.234875e+03<
+>%e< >0.000012345< >1.234500e-05<
+>%e< >1234567E96< >1.234567e+102<
+>%e< >0< >0.000000e+00<
+>%e< >.1234567E-101< >1.234567e-102<
+>%+e< >1234.875< >+1.234875e+03<
+>%#e< >1234.875< >1.234875e+03<
+>%e< >-1234.875< >-1.234875e+03<
+>%+e< >-1234.875< >-1.234875e+03<
+>%#e< >-1234.875< >-1.234875e+03<
+>%.0e< >1234.875< >1e+03<
+>%.*e< >[0, 1234.875]< >1e+03<
+>%.1e< >1234.875< >1.2e+03<
+>%-12.4e< >1234.875< >1.2349e+03 <
+>%12.4e< >1234.875< > 1.2349e+03<
+>%+-12.4e< >1234.875< >+1.2349e+03 <
+>%+12.4e< >1234.875< > +1.2349e+03<
+>%+-12.4e< >-1234.875< >-1.2349e+03 <
+>%+12.4e< >-1234.875< > -1.2349e+03<
+>%f< >1234.875< >1234.875000<
+>%+f< >1234.875< >+1234.875000<
+>%#f< >1234.875< >1234.875000<
+>%f< >-1234.875< >-1234.875000<
+>%+f< >-1234.875< >-1234.875000<
+>%#f< >-1234.875< >-1234.875000<
+>%6f< >1234.875< >1234.875000<
+>%*f< >[6, 1234.875]< >1234.875000<
+>%.0f< >1234.875< >1235<
+>%.1f< >1234.875< >1234.9<
+>%-8.1f< >1234.875< >1234.9 <
+>%8.1f< >1234.875< > 1234.9<
+>%+-8.1f< >1234.875< >+1234.9 <
+>%+8.1f< >1234.875< > +1234.9<
+>%+-8.1f< >-1234.875< >-1234.9 <
+>%+8.1f< >-1234.875< > -1234.9<
+>%*.*f< >[5, 2, 12.3456]< >12.35<
+>%f< >0< >0.000000<
+>%.0f< >0< >0<
+>%.0f< >2**38< >274877906944< >Should have exact int'l rep'n<
+>%.0f< >0.1< >0<
+>%.0f< >-0.1< >-0<
+>%.0f< >0.6< >1<
+>%.0f< >-0.6< >-1<
+>%g< >12345.6789< >12345.7<
+>%+g< >12345.6789< >+12345.7<
+>%#g< >12345.6789< >12345.7<
+>%.0g< >12345.6789< >1e+04<
+>%.2g< >12345.6789< >1.2e+04<
+>%.*g< >[2, 12345.6789]< >1.2e+04<
+>%.9g< >12345.6789< >12345.6789<
+>%12.9g< >12345.6789< > 12345.6789<
+>%012.9g< >12345.6789< >0012345.6789<
+>%-12.9g< >12345.6789< >12345.6789 <
+>%*.*g< >[-12, 9, 12345.6789]< >12345.6789 <
+>%-012.9g< >12345.6789< >12345.6789 <
+>%g< >-12345.6789< >-12345.7<
+>%+g< >-12345.6789< >-12345.7<
+>%g< >1234567.89< >1.23457e+06<
+>%+g< >1234567.89< >+1.23457e+06<
+>%#g< >1234567.89< >1.23457e+06<
+>%g< >-1234567.89< >-1.23457e+06<
+>%+g< >-1234567.89< >-1.23457e+06<
+>%#g< >-1234567.89< >-1.23457e+06<
+>%g< >0.00012345< >0.00012345<
+>%g< >0.000012345< >1.2345e-05<
+>%g< >1234567E96< >1.23457e+102<
+>%g< >.1234567E-101< >1.23457e-102<
+>%g< >0< >0<
+>%13g< >1234567.89< > 1.23457e+06<
+>%+13g< >1234567.89< > +1.23457e+06<
+>%013g< >1234567.89< >001.23457e+06<
+>%-13g< >1234567.89< >1.23457e+06 <
+>%h< >''< >%h INVALID<
+>%i< >123456.789< >123456< >Synonym for %d<
+>%j< >''< >%j INVALID<
+>%k< >''< >%k INVALID<
+>%l< >''< >%l INVALID<
+>%m< >''< >%m INVALID<
+>%s< >sprintf('%%n%n %d', $n, $n)< >%n 2< >Slight sneakiness to test %n<
+>%o< >2**32-1< >37777777777<
+>%+o< >2**32-1< >37777777777<
+>%#o< >2**32-1< >037777777777<
+>%d< >$p=sprintf('%p',$p);$p=~/^[0-9a-f]+$/< >1< >Coarse hack: hex from %p?<
+>%#p< >''< >%#p INVALID<
+>%q< >''< >%q INVALID<
+>%r< >''< >%r INVALID<
+>%s< >'string'< >string<
+>%10s< >'string'< > string<
+>%+10s< >'string'< > string<
+>%#10s< >'string'< > string<
+>%010s< >'string'< >0000string<
+>%0*s< >[10, 'string']< >0000string<
+>%-10s< >'string'< >string <
+>%3s< >'string'< >string<
+>%.3s< >'string'< >str<
+>%.*s< >[3, 'string']< >str<
+>%t< >''< >%t INVALID<
+>%u< >2**32-1< >4294967295<
+>%+u< >2**32-1< >4294967295<
+>%#u< >2**32-1< >4294967295<
+>%12u< >2**32-1< > 4294967295<
+>%012u< >2**32-1< >004294967295<
+>%-12u< >2**32-1< >4294967295 <
+>%-012u< >2**32-1< >4294967295 <
+>%v< >''< >%v INVALID<
+>%w< >''< >%w INVALID<
+>%x< >2**32-1< >ffffffff<
+>%+x< >2**32-1< >ffffffff<
+>%#x< >2**32-1< >0xffffffff<
+>%10x< >2**32-1< > ffffffff<
+>%010x< >2**32-1< >00ffffffff<
+>%-10x< >2**32-1< >ffffffff <
+>%-010x< >2**32-1< >ffffffff <
+>%0-10x< >2**32-1< >ffffffff <
+>%0*x< >[-10, ,2**32-1]< >ffffffff <
+>%y< >''< >%y INVALID<
+>%z< >''< >%z INVALID<
diff --git a/t/op/stat.t b/t/op/stat.t
index af4920cd43..353b3b3b2f 100755
--- a/t/op/stat.t
+++ b/t/op/stat.t
@@ -80,6 +80,7 @@ else {
print "not ok 4\n";
print "#4 If test op/stat.t fails test 4, check if you are on a tmpfs\n";
print "#4 of some sort. Building in /tmp sometimes has this problem.\n";
+ print "#4 Also building on the ClearCase VOBS filesystem may cause this failure.\n";
}
print "#4 :$mtime: should != :$ctime:\n";
diff --git a/t/op/taint.t b/t/op/taint.t
index 6548b46f59..44f50aea18 100755
--- a/t/op/taint.t
+++ b/t/op/taint.t
@@ -24,7 +24,8 @@ BEGIN {
$ENV{PATH} = $ENV{PATH};
$ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy';
}
- if ($Config{d_shm} || $Config{d_msg}) {
+ if ($Config{'extensions'} =~ /\bIPC\/SysV\b/
+ && ($Config{d_shm} || $Config{d_msg})) {
require IPC::SysV;
IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU));
}
@@ -612,13 +613,13 @@ else {
# test shmread
{
- if ($Config{d_shm}) {
+ if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $Config{d_shm}) {
no strict 'subs';
my $sent = "foobar";
my $rcvd;
my $size = 2000;
- my $id = shmget(IPC_PRIVATE, $size, S_IRWXU) ||
- warn "# shmget failed: $!\n";
+ my $id = shmget(IPC_PRIVATE, $size, S_IRWXU);
+
if (defined $id) {
if (shmwrite($id, $sent, 0, 60)) {
if (shmread($id, $rcvd, 0, 60)) {
@@ -629,7 +630,7 @@ else {
} else {
warn "# shmwrite failed: $!\n";
}
- shmctl($id, IPC_RMID, 0) || warn "# shmctl failed: $!\n";
+ shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n";
} else {
warn "# shmget failed: $!\n";
}
@@ -646,7 +647,7 @@ else {
# test msgrcv
{
- if ($Config{d_msg}) {
+ if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $Config{d_msg}) {
no strict 'subs';
my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU);
@@ -665,7 +666,7 @@ else {
} else {
warn "# msgsnd failed\n";
}
- msgctl($id, IPC_RMID, 0) || warn "# msgctl failed: $!\n";
+ msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n";
} else {
warn "# msgget failed\n";
}
diff --git a/t/op/tr.t b/t/op/tr.t
index 4e6667cd7f..ea665c7c8a 100755
--- a/t/op/tr.t
+++ b/t/op/tr.t
@@ -5,7 +5,7 @@ BEGIN {
unshift @INC, "../lib";
}
-print "1..4\n";
+print "1..27\n";
$_ = "abcdefghijklmnopqrstuvwxyz";
@@ -37,3 +37,129 @@ print "ok 3\n";
print "ok 4\n";
}
#
+
+# make sure that tr cancels IOK and NOK
+($x = 12) =~ tr/1/3/;
+(my $y = 12) =~ tr/1/3/;
+($f = 1.5) =~ tr/1/3/;
+(my $g = 1.5) =~ tr/1/3/;
+print "not " unless $x + $y + $f + $g == 71;
+print "ok 5\n";
+
+# make sure tr is harmless if not updating - see [ID 20000511.005]
+$_ = 'fred';
+/([a-z]{2})/;
+$1 =~ tr/A-Z//;
+s/^(\s*)f/$1F/;
+print "not " if $_ ne 'Fred';
+print "ok 6\n";
+
+# check tr handles UTF8 correctly
+($x = 256.65.258) =~ tr/a/b/;
+print "not " if $x ne 256.65.258 or length $x != 3;
+print "ok 7\n";
+$x =~ tr/A/B/;
+print "not " if $x ne 256.66.258 or length $x != 3;
+print "ok 8\n";
+
+{
+use utf8;
+
+# 9 - changing UTF8 characters in a UTF8 string, same length.
+$l = chr(300); $r = chr(400);
+$x = 200.300.400;
+$x =~ tr/\x{12c}/\x{190}/;
+printf "not (%vd) ", $x if $x ne 200.400.400 or length $x != 3;
+print "ok 9\n";
+
+# 10 - changing UTF8 characters in UTF8 string, more bytes.
+$x = 200.300.400;
+$x =~ tr/\x{12c}/\x{be8}/;
+printf "not (%vd) ", $x if $x ne 200.3048.400 or length $x != 3;
+print "ok 10\n";
+
+# 11 - introducing UTF8 characters to non-UTF8 string.
+$x = 100.125.60;
+$x =~ tr/\x{64}/\x{190}/;
+printf "not (%vd) ", $x if $x ne 400.125.60 or length $x != 3;
+print "ok 11\n";
+
+# 12 - removing UTF8 characters from UTF8 string
+$x = 400.125.60;
+$x =~ tr/\x{190}/\x{64}/;
+printf "not (%vd) ", $x if $x ne 100.125.60 or length $x != 3;
+print "ok 12\n";
+
+# 13 - counting UTF8 chars in UTF8 string
+$x = 400.125.60.400;
+$y = $x =~ tr/\x{190}/\x{190}/;
+print "not " if $y != 2;
+print "ok 13\n";
+
+# 14 - counting non-UTF8 chars in UTF8 string
+$x = 60.400.125.60.400;
+$y = $x =~ tr/\x{3c}/\x{3c}/;
+print "not " if $y != 2;
+print "ok 14\n";
+
+# 15 - counting UTF8 chars in non-UTF8 string
+$x = 200.125.60;
+$y = $x =~ tr/\x{190}/\x{190}/;
+print "not " if $y != 0;
+print "ok 15\n";
+}
+
+# 16: test brokenness with tr/a-z-9//;
+$_ = "abcdefghijklmnopqrstuvwxyz";
+eval "tr/a-z-9/ /";
+print (($@ =~ /^Ambiguous range in transliteration operator/)
+ ? '' : 'not ', "ok 16\n");
+
+# 17-19: Make sure leading and trailing hyphens still work
+$_ = "car-rot9";
+tr/-a-m/./;
+print (($_ eq '..r.rot9') ? '' : 'not ', "ok 17\n");
+
+$_ = "car-rot9";
+tr/a-m-/./;
+print (($_ eq '..r.rot9') ? '' : 'not ', "ok 18\n");
+
+$_ = "car-rot9";
+tr/-a-m-/./;
+print (($_ eq '..r.rot9') ? '' : 'not ', "ok 19\n");
+
+$_ = "abcdefghijklmnop";
+tr/ae-hn/./;
+print (($_ eq '.bcd....ijklm.op') ? '' : 'not ', "ok 20\n");
+
+$_ = "abcdefghijklmnop";
+tr/a-cf-kn-p/./;
+print (($_ eq '...de......lm...') ? '' : 'not ', "ok 21\n");
+
+$_ = "abcdefghijklmnop";
+tr/a-ceg-ikm-o/./;
+print (($_ eq '...d.f...j.l...p') ? '' : 'not ', "ok 22\n");
+
+# 23: Test reversed range check
+# 20000705 MJD
+eval "tr/m-d/ /";
+print (($@ =~ /^Invalid \[\] range "m-d" in transliteration operator/)
+ ? '' : 'not ', "ok 23\n");
+
+# 24: test cannot update if read-only
+eval '$1 =~ tr/x/y/';
+print (($@ =~ /^Modification of a read-only value attempted/) ? '' : 'not ',
+ "ok 24\n");
+
+# 25: test can count read-only
+'abcdef' =~ /(bcd)/;
+print (( eval '$1 =~ tr/abcd//' == 3) ? '' : 'not ', "ok 25\n");
+
+# 26: test lhs OK if not updating
+print ((eval '"123" =~ tr/12//' == 2) ? '' : 'not ', "ok 26\n");
+
+# 27: test lhs bad if updating
+eval '"123" =~ tr/1/1/';
+print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|)
+ ? '' : 'not ', "ok 27\n");
+
diff --git a/t/op/vec.t b/t/op/vec.t
index bf60fc4a08..b8efb8011d 100755
--- a/t/op/vec.t
+++ b/t/op/vec.t
@@ -1,8 +1,6 @@
#!./perl
-# $RCSfile: vec.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:36 $
-
-print "1..15\n";
+print "1..18\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";
@@ -25,3 +23,11 @@ vec($Vec, 0, 32) = 0xbaddacab;
print $Vec eq "\xba\xdd\xac\xab" ? "ok 14\n" : "not ok 14\n";
print vec($Vec, 0, 32) == 3135089835 ? "ok 15\n" : "not ok 15\n";
+# ensure vec() handles numericalness correctly
+$foo = $bar = $baz = 0;
+vec($foo = 0,0,1) = 1;
+vec($bar = 0,1,1) = 1;
+$baz = $foo | $bar;
+print $foo eq "1" && $foo == 1 ? "ok 16\n" : "not ok 16\n";
+print $bar eq "2" && $bar == 2 ? "ok 17\n" : "not ok 17\n";
+print "$foo $bar $baz" eq "1 2 3" ? "ok 18\n" : "not ok 18\n";
diff --git a/t/op/wantarray.t b/t/op/wantarray.t
index 0a47b6d3ba..4b6f37cf0f 100755
--- a/t/op/wantarray.t
+++ b/t/op/wantarray.t
@@ -1,6 +1,6 @@
#!./perl
-print "1..3\n";
+print "1..7\n";
sub context {
my ( $cona, $testnum ) = @_;
my $conb = (defined wantarray) ? ( wantarray ? 'A' : 'S' ) : 'V';
@@ -13,4 +13,8 @@ sub context {
context('V',1);
$a = context('S',2);
@a = context('A',3);
+scalar context('S',4);
+$a = scalar context('S',5);
+($a) = context('A',6);
+($a) = scalar context('S',7);
1;
diff --git a/t/op/write.t b/t/op/write.t
index 87d50429f4..5b01eb78b7 100755
--- a/t/op/write.t
+++ b/t/op/write.t
@@ -1,6 +1,6 @@
#!./perl
-print "1..8\n";
+print "1..9\n";
my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat';
@@ -200,4 +200,21 @@ $this,$that
write LEX;
$that = 8;
write LEX;
+ close LEX;
}
+# LEX_INTERPNORMAL test
+my %e = ( a => 1 );
+format OUT4 =
+@<<<<<<
+"$e{a}"
+.
+open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp";
+write (OUT4);
+close OUT4;
+if (`$CAT Op_write.tmp` eq "1\n") {
+ print "ok 9\n";
+ unlink "Op_write.tmp";
+ }
+else {
+ print "not ok 9\n";
+ }
View Lorry Controller Status