Integrate mainline.

p4raw-id: //depot/perlio@19352

8 files changed, 104 insertions, 26 deletions

diff --git a/t/cmd/for.t b/t/cmd/for.t
index 3275c71d2a..3a4bc9b0da 100755
--- a/t/cmd/for.t
+++ b/t/cmd/for.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..12\n";
+print "1..13\n";
 
 for ($i = 0; $i <= 10; $i++) {
     $x[$i] = $i;
@@ -71,3 +71,8 @@ for ("-3" .. "0") {
     $loop_count++;
 }
 print $loop_count == 4 ? "ok" : "not ok", " 12\n";
+
+# modifying arrays in loops is a no-no
+@a = (3,4);
+eval { @a = () for (1,2,@a) };
+print $@ =~ /Use of freed value in iteration/ ? "ok" : "not ok", " 13\n";
diff --git a/t/comp/parser.t b/t/comp/parser.t
index 54ad351eb1..b50d8af29d 100644
--- a/t/comp/parser.t
+++ b/t/comp/parser.t
@@ -9,7 +9,7 @@ BEGIN {
 }
 
 require "./test.pl";
-plan( tests => 21 );
+plan( tests => 37 );
 
 eval '%@x=0;';
 like( $@, qr/^Can't modify hash dereference in repeat \(x\)/, '%@x=0' );
@@ -97,3 +97,23 @@ print "#";
 print(
 $data{foo});
 pass();
+
+# Bug #21875
+# { q.* => ... } should be interpreted as hash, not block
+
+foreach my $line (split /\n/, <<'EOF')
+1 { foo => 'bar' }
+1 { qoo => 'bar' }
+1 { q   => 'bar' }
+1 { qq  => 'bar' }
+0 { q,'bar', }
+0 { q=bar= }
+0 { qq=bar= }
+1 { q=bar= => 'bar' }
+EOF
+{
+    my ($expect, $eval) = split / /, $line, 2;
+    my $result = eval $eval;
+    ok($@ eq  '', "eval $eval");
+    is(ref $result, $expect ? 'HASH' : '', $eval);
+}
diff --git a/t/io/layers.t b/t/io/layers.t
index 0e733ad994..8f70392434 100644
--- a/t/io/layers.t
+++ b/t/io/layers.t
@@ -25,12 +25,8 @@ plan tests => 43;
 use Config;
 
 my $DOSISH    = $^O =~ /^(?:MSWin32|cygwin|os2|dos|NetWare|mint)$/ ? 1 : 0;
-my $NONSTDIO  = exists $ENV{PERLIO} && $ENV{PERLIO} ne 'stdio' ? 1 : 0;
-my $FASTSTDIO =
-    $Config{d_stdstdio} &&
-    $Config{d_stdio_ptr_lval} &&
-    ($Config{d_stdio_cnt_lval} ||
-     $Config{d_stdio_ptr_lval_sets_cnt}) ? 1 : 0;
+my $NONSTDIO  = exists $ENV{PERLIO} && $ENV{PERLIO} ne 'stdio'     ? 1 : 0;
+my $FASTSTDIO = $Config{d_faststdio} && $Config{usefaststdio}      ? 1 : 0;
 
 print <<__EOH__;
 # PERLIO    = $PERLIO
@@ -48,15 +44,15 @@ SKIP: {
 	# An interesting dance follows where we try to make the following
 	# IO layer stack setups to compare equal:
 	#
-	# PERLIO     UNIX-like       DOS-like
+	# PERLIO     UNIX-like                   DOS-like
 	#
-	# none or "" stdio [1]       unix crlf
-	# stdio      stdio [1]       stdio
-	# perlio     unix perlio     unix perlio
-	# mmap       unix mmap       unix mmap
+	# unset / "" unix perlio / stdio [1]     unix crlf
+	# stdio      unix perlio / stdio [1]     stdio
+	# perlio     unix perlio                 unix perlio
+	# mmap       unix mmap                   unix mmap
 	#
-	# [1] If Configure found how to do "fast stdio",
-	# otherwise it will be "unix perlio".
+	# [1] "stdio" if Configure found out how to do "fast stdio" (depends
+	# on the stdio implementation) and in Perl 5.8, otherwise "unix perlio"
 	#
 	if ($NONSTDIO) {
 	    # Get rid of "unix".
@@ -67,7 +63,7 @@ SKIP: {
 	    } else {
 		$expected->[0] = $ENV{PERLIO} if $expected->[0] eq "stdio";
 	    }
-	} elsif (!$FASTSTDIO) {
+	} elsif (!$FASTSTDIO && !$DOSISH) {
 	    splice(@$result, 0, 2, "stdio")
 		if @$result >= 2 &&
 		   $result->[0] eq "unix" &&
diff --git a/t/op/pack.t b/t/op/pack.t
index d3be738b29..0c7d51d73a 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 5849;
+plan tests => 5852;
 
 use strict;
 use warnings;
@@ -1100,3 +1100,11 @@ ok(pack('u2', 'AA'), "[perl #8026]"); # used to hang and eat RAM in perl 5.7.2
 
 $_ = pack('c', 65); # 'A' would not be EBCDIC-friendly
 is(unpack('c'), 65, "one-arg unpack (change #18751)"); # defaulting to $_
+
+{
+    my $a = "X\t01234567\n" x 100;
+    my @a = unpack("(a1 c/a)*", $a);
+    is(scalar @a, 200,       "[perl #15288]");
+    is($a[-1], "01234567\n", "[perl #15288]");
+    is($a[-2], "X",          "[perl #15288]");
+}
diff --git a/t/op/pat.t b/t/op/pat.t
index 26e859435f..006e1b600f 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -6,7 +6,7 @@
 
 $| = 1;
 
-print "1..997\n";
+print "1..998\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -3166,4 +3166,10 @@ ok("bbbbac" =~ /$pattern/ && $1 eq 'a', "[perl #3547]");
        "[perl #17757] Parse::RecDescent triggers infinite loop");
 }
 
-# last test 997
+{
+    my $re = qq/^([^X]*)X/;
+    utf8::upgrade($re);
+    ok("\x{100}X" =~ /$re/, "S_cl_and ANYOF_UNICODE & ANYOF_INVERTED");
+}
+
+# last test 998
diff --git a/t/op/readline.t b/t/op/readline.t
index d127d583a5..80932c441d 100644
--- a/t/op/readline.t
+++ b/t/op/readline.t
@@ -20,21 +20,23 @@ like($@, 'Modification of a read-only value attempted', '[perl #19566]');
 }
 
 # 82 is chosen to exceed the length for sv_grow in do_readline (80)
-foreach my $k ('k', 'k'x82) {
+foreach my $k (1, 82) {
   my $result
     = runperl (switches => '-l', stdin => '', stderr => 1,
-	       prog => "%a = qw($k v); \$_ = <> foreach keys %a; print qw(end)",
+              prog => "\$x = q(k) x $k; \$a{\$x} = qw(v); \$_ = <> foreach keys %a; print qw(end)",
 	      );
-  is ($result, "end", '[perl #21614] for length ' . length $k);
+  $result =~ s/\n\z// if $^O eq 'VMS';
+  is ($result, "end", '[perl #21614] for length ' . length('k' x $k));
 }
 
 
-foreach my $k ('perl', 'perl'x21) {
+foreach my $k (1, 21) {
   my $result
     = runperl (switches => '-l', stdin => ' rules', stderr => 1,
-	       prog => "%a = qw($k v); foreach (keys %a) {\$_ .= <>; print}",
+              prog => "\$x = q(perl) x $k; \$a{\$x} = q(v); foreach (keys %a) {\$_ .= <>; print}",
 	      );
-  is ($result, "$k rules", 'rcatline to shared sv for length ' . length $k);
+  $result =~ s/\n\z// if $^O eq 'VMS';
+  is ($result, ('perl' x $k) . " rules", 'rcatline to shared sv for length ' . length('perl' x $k));
 }
 
 foreach my $l (1, 82) {
diff --git a/t/op/ref.t b/t/op/ref.t
index 9470efa69a..b29dcb77ac 100755
--- a/t/op/ref.t
+++ b/t/op/ref.t
@@ -5,7 +5,7 @@ BEGIN {
     @INC = qw(. ../lib);
 }
 
-print "1..65\n";
+print "1..67\n";
 
 require 'test.pl';
 
@@ -340,6 +340,16 @@ if ($result eq $expect) {
   print "# expected \"$expect\", got \"$result\"\n";
 }
 
+# bug #21347
+
+runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' );
+if ($? != 0) { print "not " };
+print "ok ",++$test," - UNIVERSAL::AUTOLOAD called when freeing qr//\n";
+
+runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1);
+if ($? != 0) { print "not " };
+print "ok ",++$test," - warn called inside UNIVERSAL::DESTROY\n";
+
 # test global destruction
 
 ++$test;
diff --git a/t/op/tie.t b/t/op/tie.t
index 49c189e66f..d643b78282 100755
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -295,3 +295,34 @@ tie $a, 'main';
 print $a;
 EXPECT
 Tied variable freed while still in use at - line 6.
+########
+
+#  [20020716.007] - nested FETCHES
+
+sub F1::TIEARRAY { bless [], 'F1' }
+sub F1::FETCH { 1 }
+my @f1;
+tie @f1, 'F1';
+
+sub F2::TIEARRAY { bless [2], 'F2' }
+sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self }
+my @f2;
+tie @f2, 'F2';
+
+print $f2[4][0],"\n";
+
+sub F3::TIEHASH { bless [], 'F3' }
+sub F3::FETCH { 1 }
+my %f3;
+tie %f3, 'F3';
+
+sub F4::TIEHASH { bless [3], 'F4' }
+sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self }
+my %f4;
+tie %f4, 'F4';
+
+print $f4{'foo'}[0],"\n";
+
+EXPECT
+2
+3