Integrate mainline

p4raw-id: //depot/perlio@11835
author: Nick Ing-Simmons <nik@tiuk.ti.com> 2001-09-03 06:20:06 +0000
committer: Nick Ing-Simmons <nik@tiuk.ti.com> 2001-09-03 06:20:06 +0000
commit: e9c5ca9205c44a223c1bf0632cde03b38166cbc2 (patch)
tree: 833b366976759e0cb591d958e4cc96da8ba3a1b2 /t
parent: 7027b5917e2cc53d3a5a5cd777a5e20a46b9034d (diff)
parent: 86876e467424d8479015024738d4b873cf8cd086 (diff)
download: perl-e9c5ca9205c44a223c1bf0632cde03b38166cbc2.tar.gz
12 files changed, 351 insertions, 109 deletions
diff --git a/t/TEST b/t/TEST
index 0a63f0e5f0..64da39ca4b 100755
--- a/t/TEST
+++ b/t/TEST
@@ -9,6 +9,7 @@ $| = 1;
 if ($#ARGV >= 0) {
     foreach my $idx (0..$#ARGV) {
 	next unless $ARGV[$idx] =~ /^-(\S+)$/;
+	$core    = 1 if $1 eq 'core';
 	$verbose = 1 if $1 eq 'v';
 	$with_utf= 1 if $1 eq 'utf8';
 	if ($1 =~ /^deparse(,.+)?$/) {
@@ -64,15 +65,20 @@ sub _find_tests {
 }
 
 unless (@ARGV) {
-    foreach my $dir (qw(base comp cmd run io op lib)) {
+    foreach my $dir (qw(base comp cmd run io op)) {
         _find_tests($dir);
     }
+    _find_tests("lib") unless $core;
     my $mani = File::Spec->catdir($updir, "MANIFEST");
     if (open(MANI, $mani)) {
         while (<MANI>) { # similar code in t/harness
 	    if (m!^(ext/\S+/([^/]+\.t|test\.pl)|lib/\S+?(\.t|test\.pl))\s!) {
-		push @ARGV, $1;
-		$OVER{$1} = File::Spec->catdir($updir, $1);
+		$t = $1;
+		if (!$core || $t =~ m!^lib/[a-z]!)
+		{
+		    push @ARGV, $t;
+		    $OVER{$t} = File::Spec->catdir($updir, $t);
+		}
 	    }
 	}
     } else {
diff --git a/t/base/term.t b/t/base/term.t
index 1d688b8f5b..000bff1b15 100755
--- a/t/base/term.t
+++ b/t/base/term.t
@@ -40,7 +40,12 @@ if (($x | 1) == 101) {print "ok 5\n";} else {print "not ok 5\n";}
 
 # check <> pseudoliteral
 
-open(try, "/dev/null") || open(try,"Dev:Null") || open(try,"nla0:") || (die "Can't open /dev/null.");
+if ($^O eq 'MacOS') {
+	open(try,"Dev:Null") || (die "Can't open /dev/null.");
+} else {
+	open(try, "/dev/null") || open(try,"nla0:") || (die "Can't open /dev/null.");
+}
+
 if (<try> eq '') {
     print "ok 6\n";
 }
diff --git a/t/io/binmode.t b/t/io/binmode.t
index 76fd5a7779..34a462d9f9 100644
--- a/t/io/binmode.t
+++ b/t/io/binmode.t
@@ -5,16 +5,24 @@ BEGIN {
     @INC = '../lib';
 }
 
-
 use Test::More tests => 8;
+use Config;
 
 ok( binmode(STDERR),            'STDERR made binary' );
-ok( binmode(STDERR, ":unix"),   '  with unix discipline' );
+if ($Config{useperlio}) {
+  ok( binmode(STDERR, ":unix"),   '  with unix discipline' );
+} else {
+  ok(1,   '  skip unix discipline for -Uuseperlio' );
+}
 ok( binmode(STDERR, ":raw"),    '  raw' );
 ok( binmode(STDERR, ":crlf"),   '  and crlf' );
 
 # If this one fails, we're in trouble.  So we just bail out.
 ok( binmode(STDOUT),            'STDOUT made binary' )      || exit(1);
-ok( binmode(STDOUT, ":unix"),   '  with unix discipline' );
-ok( binmode(STDERR, ":raw"),    '  raw' );
-ok( binmode(STDERR, ":crlf"),   '  and crlf' );
+if ($Config{useperlio}) {
+  ok( binmode(STDOUT, ":unix"),   '  with unix discipline' );
+} else {
+  ok(1,   '  skip unix discipline for -Uuseperlio' );
+}
+ok( binmode(STDOUT, ":raw"),    '  raw' );
+ok( binmode(STDOUT, ":crlf"),   '  and crlf' );
diff --git a/t/op/64bitint.t b/t/op/64bitint.t
index e5ff95bf16..5ea1f2dbdc 100644
--- a/t/op/64bitint.t
+++ b/t/op/64bitint.t
@@ -14,9 +14,25 @@ BEGIN {
 
 # so that using > 0xfffffff constants and
 # 32+ bit integers don't cause noise
+use warnings;
 no warnings qw(overflow portable);
 
-print "1..59\n";
+print "1..63\n";
+
+# as 6 * 6 = 36, the last digit of 6**n will always be six. Hence the last
+# digit of 16**n will always be six. Hence 16**n - 1 will always end in 5.
+# Assumption is that UVs will always be a multiple of 4 bits long.
+
+my $UV_max = ~0;
+die "UV_max eq '$UV_max', doesn't end in 5; your UV isn't 4n bits long :-(."
+  unless $UV_max =~ /5$/;
+my $UV_max_less3 = $UV_max - 3;
+my $maths_preserves_UVs = $UV_max_less3 =~ /^\d+2$/;   # 5 - 3 is 2.
+if ($maths_preserves_UVs) {
+  print "# This perl's maths preserves all bits of a UV.\n";
+} else {
+  print "# This perl's maths does not preserve all bits of a UV.\n";
+}
 
 my $q = 12345678901;
 my $r = 23456789012;
@@ -327,11 +343,40 @@ print "ok 58\n";
 
 # 0xFFFFFFFFFFFFFFFF ==  1 * 3 * 5 * 17 * 257 * 641 * 65537 * 6700417'
 $q = 0xFFFFFFFFFFFFFFFF / 3;
-if ($q == 0x5555555555555555 and $q != 0x5555555555555556) {
+if ($q == 0x5555555555555555 and ($q != 0x5555555555555556
+                                  or !$maths_preserves_UVs)) {
   print "ok 59\n";
 } else {
   print "not ok 59 # 0xFFFFFFFFFFFFFFFF / 3 = $q\n";
   print "# Should not be floating point\n" if $q =~ tr/e.//;
 }
 
+$q = 0xFFFFFFFFFFFFFFFF % 0x5555555555555555;
+if ($q == 0) {
+  print "ok 60\n";
+} else {
+  print "not ok 60 # 0xFFFFFFFFFFFFFFFF % 0x5555555555555555 => $q\n";
+}
+
+$q = 0xFFFFFFFFFFFFFFFF % 0xFFFFFFFFFFFFFFF0;
+if ($q == 0xF) {
+  print "ok 61\n";
+} else {
+  print "not ok 61 # 0xFFFFFFFFFFFFFFFF % 0xFFFFFFFFFFFFFFF0 => $q\n";
+}
+
+$q = 0x8000000000000000 % 9223372036854775807;
+if ($q == 1) {
+  print "ok 62\n";
+} else {
+  print "not ok 62 # 0x8000000000000000 % 9223372036854775807 => $q\n";
+}
+
+$q = 0x8000000000000000 % -9223372036854775807;
+if ($q == -9223372036854775806) {
+  print "ok 63\n";
+} else {
+  print "not ok 63 # 0x8000000000000000 % -9223372036854775807 => $q\n";
+}
+
 # eof
diff --git a/t/op/concat.t b/t/op/concat.t
index 5ae7da51b9..4813690d6b 100644
--- a/t/op/concat.t
+++ b/t/op/concat.t
@@ -5,22 +5,28 @@ BEGIN {
     @INC = '../lib';
 }
 
-print "1..11\n";
+# This ok() function is specially written to avoid any concatenation.
+my $test = 1;
+sub ok {
+    my($ok, $name) = @_;
 
-($a, $b, $c) = qw(foo bar);
+    printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name;
 
-print "not " unless "$a" eq "foo";
-print "ok 1\n";
+    printf "# Failed test at line %d\n", (caller)[2] unless $ok;
 
-print "not " unless "$a$b" eq "foobar";
-print "ok 2\n";
+    $test++;
+    return $ok;
+}
 
-print "not " unless "$c$a$c" eq "foo";
-print "ok 3\n";
+print "1..12\n";
 
-# Okay, so that wasn't very challenging.  Let's go Unicode.
+($a, $b, $c) = qw(foo bar);
+
+ok("$a"     eq "foo",    "verifying assign");
+ok("$a$b"   eq "foobar", "basic concatenation");
+ok("$c$a$c" eq "foo",    "concatenate undef, fore and aft");
 
-my $test = 4;
+# Okay, so that wasn't very challenging.  Let's go Unicode.
 
 {
     # bug id 20000819.004 
@@ -28,26 +34,20 @@ my $test = 4;
     $_ = $dx = "\x{10f2}";
     s/($dx)/$dx$1/;
     {
-	print "not " unless $_ eq "$dx$dx";
-	print "ok $test\n";
-	$test++;
+        ok($_ eq  "$dx$dx","bug id 20000819.004, back");
     }
 
     $_ = $dx = "\x{10f2}";
     s/($dx)/$1$dx/;
     {
-	print "not " unless $_ eq "$dx$dx";
-	print "ok $test\n";
-	$test++;
+        ok($_ eq  "$dx$dx","bug id 20000819.004, front");
     }
 
     $dx = "\x{10f2}";
     $_  = "\x{10f2}\x{10f2}";
     s/($dx)($dx)/$1$2/;
     {
-	print "not " unless $_ eq "$dx$dx";
-	print "ok $test\n";
-	$test++;
+        ok($_ eq  "$dx$dx","bug id 20000819.004, front and back");
     }
 }
 
@@ -57,9 +57,9 @@ my $test = 4;
 
     my $a;
     $a .= "\x{1ff}";
-    print "not " unless $a eq "\x{1ff}";
-    print "ok $test\n";
-    $test++;
+    ok($a eq  "\x{1ff}", "bug id 20000901.092, undef left");
+    $a .= undef;
+    ok($a eq  "\x{1ff}", "bug id 20000901.092, undef right");
 }
 
 {
@@ -69,29 +69,21 @@ my $test = 4;
 
     # Without the fix this 5.7.0 would croak:
     # Modification of a read-only value attempted at ...
-    "$2\x{1234}";
-
-    print "ok $test\n";
-    $test++;
+    eval {"$2\x{1234}"};
+    ok(!$@, "bug id 20001020.006, left");
 
     # For symmetry with the above.
-    "\x{1234}$2";
-
-    print "ok $test\n";
-    $test++;
+    eval {"\x{1234}$2"};
+    ok(!$@, "bug id 20001020.006, right");
 
     *pi = \undef;
     # This bug existed earlier than the $2 bug, but is fixed with the same
     # patch. Without the fix this 5.7.0 would also croak:
     # Modification of a read-only value attempted at ...
-    "$pi\x{1234}";
-
-    print "ok $test\n";
-    $test++;
+    eval{"$pi\x{1234}"};
+    ok(!$@, "bug id 20001020.006, constant left");
 
     # For symmetry with the above.
-    "\x{1234}$pi";
-
-    print "ok $test\n";
-    $test++;
+    eval{"\x{1234}$pi"};
+    ok(!$@, "bug id 20001020.006, constant right");
 }
diff --git a/t/op/inccode.t b/t/op/inccode.t
new file mode 100644
index 0000000000..85a235d6de
--- /dev/null
+++ b/t/op/inccode.t
@@ -0,0 +1,110 @@
+#!./perl -wT
+
+# Tests for the coderef-in-@INC feature
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+use Config;
+
+BEGIN {
+    require Test::More;
+
+    # This test relies on perlio, but the feature being tested does not.
+    # The dependency should eventually be purged and use something like
+    # Tie::Handle instead.
+    if( $Config{useperlio} ) {
+        Test::More->import(tests => 21);
+    }
+    else {
+        Test::More->import('skip_all');
+    }
+}
+
+sub fooinc {
+    my ($self, $filename) = @_;
+    if (substr($filename,0,3) eq 'Foo') {
+        open my $fh, '<', \("package ".substr($filename,0,-3)."; 1;");
+        return $fh;
+    }
+    else {
+        return undef;
+    }
+}
+
+push @INC, \&fooinc;
+
+ok( !eval { require Bar; 1 },      'Trying non-magic package' );
+
+ok( eval { require Foo; 1 },       'require() magic via code ref'  ); 
+ok( exists $INC{'Foo.pm'},         '  %INC sees it' );
+
+ok( eval "use Foo1; 1;",           'use()' );  
+ok( exists $INC{'Foo1.pm'},        '  %INC sees it' );
+
+ok( eval { do 'Foo2.pl'; 1 },      'do()' ); 
+ok( exists $INC{'Foo2.pl'},        '  %INC sees it' );
+
+pop @INC;
+
+
+sub fooinc2 {
+    my ($self, $filename) = @_;
+    if (substr($filename, 0, length($self->[1])) eq $self->[1]) {
+        open my $fh, '<', \("package ".substr($filename,0,-3)."; 1;");
+        return $fh;
+    }
+    else {
+        return undef;
+    }
+}
+
+push @INC, [ \&fooinc2, 'Bar' ];
+
+ok( eval { require Foo; 1; },     'Originally loaded packages preserved' );
+ok( !eval { require Foo3; 1; },   'Original magic INC purged' );
+
+ok( eval { require Bar; 1 },      'require() magic via array ref' );
+ok( exists $INC{'Bar.pm'},        '  %INC sees it' );
+
+ok( eval "use Bar1; 1;",          'use()' );
+ok( exists $INC{'Bar1.pm'},       '  %INC sees it' );
+
+ok( eval { do 'Bar2.pl'; 1 },     'do()' );
+ok( exists $INC{'Bar2.pl'},       '  %INC sees it' );
+
+pop @INC;
+
+sub FooLoader::INC {
+    my ($self, $filename) = @_;
+    if (substr($filename,0,4) eq 'Quux') {
+        open my $fh, '<', \("package ".substr($filename,0,-3)."; 1;");
+        return $fh;
+    }
+    else {
+        return undef;
+    }
+}
+
+push @INC, bless( {}, 'FooLoader' );
+
+ok( eval { require Quux; 1 },      'require() magic via hash object' );
+ok( exists $INC{'Quux.pm'},        '  %INC sees it' );
+
+pop @INC;
+
+push @INC, bless( [], 'FooLoader' );
+
+ok( eval { require Quux1; 1 },     'require() magic via array object' );
+ok( exists $INC{'Quux1.pm'},       '  %INC sees it' );
+
+pop @INC;
+
+push @INC, bless( \(my $x = 1), 'FooLoader' );
+
+ok( eval { require Quux2; 1 },     'require() magic via scalar object' );
+ok( exists $INC{'Quux2.pm'},       '  %INC sees it' );
+
+pop @INC;
diff --git a/t/op/numconvert.t b/t/op/numconvert.t
index 084092e534..fedef70d40 100755
--- a/t/op/numconvert.t
+++ b/t/op/numconvert.t
@@ -48,9 +48,11 @@ my $max_chain = $ENV{PERL_TEST_NUMCONVERTS} || 2;
 my $max_uv1 = ~0;
 my $max_uv2 = sprintf "%u", $max_uv1 ** 6; # 6 is an arbitrary number here
 my $big_iv = do {use integer; $max_uv1 * 16}; # 16 is an arbitrary number here
+my $max_uv_less3 = $max_uv1 - 3;
 
 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 "# max_uv_less3 = $max_uv_less3\n";
+if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1 or $max_uv1 == $max_uv_less3) {
   print "1..0 # skipped: unsigned perl arithmetic is not sane";
   eval { require Config; import Config };
   use vars qw(%Config);
@@ -60,6 +62,10 @@ if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1) {
   print "\n";
   exit 0;
 }
+if ($max_uv_less3 =~ tr/0-9//c) {
+  print "1..0 # skipped: this perl stringifies large unsigned integers using E notation\n";
+  exit 0;
+}
 
 my $st_t = 4*4;			# We try 4 initializers and 4 reporters
 
diff --git a/t/op/pack.t b/t/op/pack.t
index dfecc6e573..1c6222efe7 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -1,12 +1,33 @@
-#!./perl
+#!./perl -Tw
 
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
-    require Config; import Config;
 }
 
+use Config;
+
+$Is_EBCDIC = (defined $Config{ebcdic} && $Config{ebcdic} eq 'define');
+
+my $test = 1;
+sub ok {
+    my($ok) = @_;
+
+    # You have to do it this way or VMS will get confused.
+    my $out = '';
+    $out =  "not " unless $ok;
+    $out .= "ok $test\n";
+    print $out;
+
+    printf "# Failed test at line %d\n", (caller)[2] unless $ok;
+
+    $test++;
+    return $ok;
+}
+
+
 print "1..161\n";
+
 # Note: All test numbers in comments are off by 1 after the comment below..
 
 $format = "c2 x5 C C x s d i l a6";
@@ -16,33 +37,29 @@ $format = "c2 x5 C C x s d i l a6";
 $foo = pack($format,@ary);
 @ary2 = unpack($format,$foo);
 
-print ($#ary == $#ary2 ? "ok 1\n" : "not ok 1\n");
+ok($#ary == $#ary2);
 
 $out1=join(':',@ary);
 $out2=join(':',@ary2);
 # Using long double NVs may introduce greater accuracy than wanted.
 $out1 =~ s/:9\.87654321097999\d*:/:9.87654321098:/;
 $out2 =~ s/:9\.87654321097999\d*:/:9.87654321098:/;
-print ($out1 eq $out2? "ok 2\n" : "not ok 2\n");
+ok($out1 eq $out2);
 
-print ($foo =~ /def/ ? "ok 3\n" : "not ok 3\n");
+ok($foo =~ /def/);
 
 # How about counting bits?
 
-print +($x = unpack("%32B*", "\001\002\004\010\020\040\100\200\377")) == 16
-	? "ok 4\n" : "not ok 4 $x\n";
+ok( ($x = unpack("%32B*", "\001\002\004\010\020\040\100\200\377")) == 16 );
 
-print +($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")) == 12
-	? "ok 5\n" : "not ok 5 $x\n";
+ok( ($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")) == 12 );
 
-print +($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9
-	? "ok 6\n" : "not ok 6 $x\n";
+ok( ($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9 );
 
 my $sum = 129; # ASCII
-$sum = 103 if ($Config{ebcdic} eq 'define');
+$sum = 103 if $Is_EBCDIC;
 
-print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum
-	? "ok 7\n" : "not ok 7 $x\n";
+ok( ($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum );
 
 open(BIN, "./perl") || open(BIN, "./perl.exe") || open(BIN, $^X)
     || die "Can't open ../perl or ../perl.exe: $!\n";
@@ -51,13 +68,11 @@ close BIN;
 
 $sum = unpack("%32b*", $foo);
 $longway = unpack("b*", $foo);
-print $sum == $longway =~ tr/1/1/ ? "ok 8\n" : "not ok 8\n";
+ok( $sum == $longway =~ tr/1/1/ );
 
-print +($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF
-	? "ok 9\n" : "not ok 9 $x\n";
+ok( ($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF );
 
 # check 'w'
-my $test=10;
 my @x = (5,130,256,560,32000,3097152,268435455,1073741844, 2**33,
          '4503599627365785','23728385234614992549757750638446');
 my $x = pack('w*', @x);
@@ -411,7 +426,7 @@ $test++;
 
 eval { ($x) = unpack 'a/a*/b*', '212ab' };
 my $expected_x = '100001100100';
-if ($Config{ebcdic} eq 'define') { $expected_x = '100000010100'; }
+if ($Is_EBCDIC) { $expected_x = '100000010100'; }
 print $@ eq '' && $x eq $expected_x ? "ok $test\n" : "#$x,$@\nnot ok $test\n";
 $test++;
 
diff --git a/t/op/pat.t b/t/op/pat.t
index 478e2994f0..2e8922523c 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -1989,6 +1989,8 @@ print "ok 683\n" if @a == 9 && "@a" eq "f o o \n $a $b b a r";
 }
 
 {
+    # [ID 20010407.006] matching utf8 return values from functions does not work
+
     package ID_20010407_006;
 
     sub x {
@@ -2000,7 +2002,7 @@ print "ok 683\n" if @a == 9 && "@a" eq "f o o \n $a $b b a r";
 
     $x =~ /(..)/; $y = $1;
     print "not " unless length($y) == 2 && $y eq $x;
-    print "ok 685\n" if length($y) == 2;
+    print "ok 685\n";
 
     x  =~ /(..)/; $y = $1;
     print "not " unless length($y) == 2 && $y eq $x;
diff --git a/t/op/sub_lval.t b/t/op/sub_lval.t
index 350cb65e1a..4654118fa1 100755
--- a/t/op/sub_lval.t
+++ b/t/op/sub_lval.t
@@ -251,7 +251,7 @@ eval <<'EOE' or $_ = $@;
 EOE
 
 print "# '$_'.\nnot "
-  unless /Can\'t return a readonly value from lvalue subroutine/;
+  unless /Empty array returned from lvalue subroutine in scalar context/;
 print "ok 31\n";
 
 sub lv10 : lvalue {}
diff --git a/t/op/universal.t b/t/op/universal.t
index 23c616c2b1..efda2a59be 100755
--- a/t/op/universal.t
+++ b/t/op/universal.t
@@ -9,7 +9,7 @@ BEGIN {
     $| = 1;
 }
 
-print "1..84\n";
+print "1..87\n";
 
 $a = {};
 bless $a, "Bob";
@@ -24,7 +24,8 @@ package Female;
 
 package Alice;
 @ISA=qw(Bob Female);
-sub drink {}
+sub sing;
+sub drink { return "drinking " . $_[1]  }
 sub new { bless {} }
 
 $Alice::VERSION = 2.718;
@@ -44,8 +45,9 @@ $Alice::VERSION = 2.718;
 
 package main;
 
-my $i = 2;
-sub test { print "not " unless shift; print "ok $i\n"; $i++; }
+{ my $i = 2;
+  sub test { print "not " unless shift; print "ok $i\n"; $i++; }
+}
 
 $a = new Alice;
 
@@ -61,11 +63,13 @@ test ! $a->isa("Male");
 
 test ! $a->isa('Programmer');
 
-test $a->can("drink");
-
 test $a->can("eat");
-
 test ! $a->can("sleep");
+test my $ref = $a->can("drink");        # returns a coderef
+test $a->$ref("tea") eq "drinking tea"; # ... which works
+test $ref = $a->can("sing");
+eval { $a->$ref() };
+test $@;                                # ... but not if no actual subroutine
 
 test (!Cedric->isa('Programmer'));
 
diff --git a/t/op/misc.t b/t/run/kill_perl.t
index 3cfb667ec8..aa7a4a9d45 100755..100644
--- a/t/op/misc.t
+++ b/t/run/kill_perl.t
@@ -1,66 +1,110 @@
 #!./perl
 
-# NOTE: Please don't add tests to this file unless they *need* to be run in
-# separate executable and can't simply use eval.
+# This is for tests that will normally cause segfaults, and other nasty
+# errors that might kill the interpreter and for some reason you can't
+# use an eval().
+#
+# New tests are added to the bottom.  For example.
+#
+#       ######## perlbug ID 20020831.001
+#       ($a, b) = (1,2)
+#       EXPECT
+#       Can't modify constant item in list assignment - at line 1
+#
+# to test that the code "($a, b) = (1,2)" causes the appropriate syntax
+# error, rather than just segfaulting as reported in perlbug ID
+# 20020831.001
+#
+#
+# NOTE: Please don't add tests to this file unless they *need* to be
+# run in separate executable and can't simply use eval.
 
-chdir 't' if -d 't';
-@INC = '../lib';
-$ENV{PERL5LIB} = "../lib";
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+use strict;
 
 $|=1;
 
-undef $/;
-@prgs = split "\n########\n", <DATA>;
+my @prgs = ();
+while(<DATA>) { 
+    if(m/^#{8,}\s*(.*)/) { 
+        push @prgs, ['', $1];
+    }
+    else { 
+        $prgs[-1][0] .= $_;
+    }
+}
 print "1..", scalar @prgs, "\n";
 
-$tmpfile = "misctmp000";
+my $tmpfile = "misctmp000";
 1 while -f ++$tmpfile;
 END { while($tmpfile && unlink $tmpfile){} }
 
-$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : (($^O eq 'NetWare') ? 'perl -e "print <>"' : 'cat'));
+my $test = 1;
+foreach my $prog (@prgs) {
+    my($raw_prog, $name) = @$prog;
 
-for (@prgs){
     my $switch;
-    if (s/^\s*(-\w.*)//){
+    if ($raw_prog =~ s/^\s*(-\w.*)//){
 	$switch = $1;
     }
-    my($prog,$expected) = split(/\nEXPECT\n/, $_);
+
+    my($prog,$expected) = split(/\nEXPECT\n/, $raw_prog);
+
     open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
-    $prog =~ s#/dev/null#NL:# if $^O eq 'VMS';     
-    $prog =~ s#if \(-e _ and -f _ and -r _\)#if (-e _ and -f _)# if $^O eq 'VMS';  # VMS file locking 
+
+    # VMS adjustments
+    if( $^O eq 'VMS' ) {
+        $prog =~ s#/dev/null#NL:#;
+
+        # VMS file locking 
+        $prog =~ s{if \(-e _ and -f _ and -r _\)}
+                  {if (-e _ and -f _)}
+    }
 
     print TEST $prog, "\n";
     close TEST or die "Cannot close $tmpfile: $!";
 
+    my $results;
     if ($^O eq 'MSWin32') {
-      $results = `.\\perl -I../lib $switch $tmpfile 2>&1`;
+        $results = `.\\perl -I../lib $switch $tmpfile 2>&1`;
     }
-	elsif ($^O eq 'NetWare') {
-      $results = `perl -I../lib $switch $tmpfile 2>&1`;
+    elsif ($^O eq 'NetWare') {
+        $results = `perl -I../lib $switch $tmpfile 2>&1`;
     }
     else {
-      $results = `./perl $switch $tmpfile 2>&1`;
+      $results = `./perl -I../lib $switch $tmpfile 2>&1`;
     }
-    $status = $?;
+    my $status = $?;
+
+    # Clean up the results into something a bit more predictable.
     $results =~ s/\n+$//;
     $results =~ s/at\s+misctmp\d+\s+line/at - line/g;
     $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g;
-# bison says 'parse error' instead of 'syntax error',
-# various yaccs may or may not capitalize 'syntax'.
+
+    # bison says 'parse error' instead of 'syntax error',
+    # various yaccs may or may not capitalize 'syntax'.
     $results =~ s/^(syntax|parse) error/syntax error/mig;
+
     $results =~ s/\n\n/\n/ if $^O eq 'VMS'; # pipes double these sometimes
+
     $expected =~ s/\n+$//;
-    if ( $results ne $expected ) {
-	print STDERR "PROG: $switch\n$prog\n";
-	print STDERR "EXPECTED:\n$expected\n";
-	print STDERR "GOT:\n$results\n";
-	print "not ";
+    my $ok = $results eq $expected;
+
+    unless( $ok ) {
+        print STDERR "# PROG: $switch\n$prog\n";
+        print STDERR "# EXPECTED:\n$expected\n";
+        print STDERR "# GOT:\n$results\n";
     }
-    print "ok ", ++$i, "\n";
+    printf "%sok %d%s\n", ($ok ? '' : "not "), $test, 
+                          length $name ? " - $name" : $name;
+    $test++;
 }
 
 __END__
-()=()
 ########
 $a = ":="; split /($a)/o, "a:=b:=c"; print "@_"
 EXPECT
@@ -285,7 +329,7 @@ print "ok\n" if ("\0" lt "\xFF");
 EXPECT
 ok
 ########
-open(H,'op/misc.t'); # must be in the 't' directory
+open(H,'run/kill_perl.t'); # must be in the 't' directory
 stat(H);
 print "ok\n" if (-e _ and -f _ and -r _);
 EXPECT
@@ -735,7 +779,12 @@ EXPECT
 1234 1
 5678 1
 1234 5678 2
-########
-# keep this last - doesn't seem to work otherwise?
+######## found by Markov chain stress testing
 eval "a.b.c.d.e.f;sub"
 EXPECT
+
+######## perlbug ID 20010831.001
+($a, b) = (1, 2);
+EXPECT
+Can't modify constant item in list assignment at - line 1, near ");"
+Execution of - aborted due to compilation errors.
author	Nick Ing-Simmons <nik@tiuk.ti.com>	2001-09-03 06:20:06 +0000
committer	Nick Ing-Simmons <nik@tiuk.ti.com>	2001-09-03 06:20:06 +0000
commit	e9c5ca9205c44a223c1bf0632cde03b38166cbc2 (patch)
tree	833b366976759e0cb591d958e4cc96da8ba3a1b2 /t
parent	7027b5917e2cc53d3a5a5cd777a5e20a46b9034d (diff)
parent	86876e467424d8479015024738d4b873cf8cd086 (diff)
download	perl-e9c5ca9205c44a223c1bf0632cde03b38166cbc2.tar.gz