Integrate mainline

p4raw-id: //depot/perlio@8088

16 files changed, 188 insertions, 68 deletions

diff --git a/ext/B/B.pm b/ext/B/B.pm
index a9ea704d78..982395bb72 100644
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -9,12 +9,16 @@ package B;
 use XSLoader ();
 require Exporter;
 @ISA = qw(Exporter);
+
+# walkoptree comes from B.pm (you are there), walkoptree comes from B.xs
 @EXPORT_OK = qw(minus_c ppname save_BEGINs
 		class peekop cast_I32 cstring cchar hash threadsv_names
-		main_root main_start main_cv svref_2object opnumber amagic_generation
+		main_root main_start main_cv svref_2object opnumber
+		amagic_generation
 		walkoptree_slow walkoptree walkoptree_exec walksymtable
 		parents comppadlist sv_undef compile_stats timing_info
 		begin_av init_av end_av);
+
 sub OPf_KIDS ();
 use strict;
 @B::SV::ISA = 'B::OBJECT';
@@ -80,7 +84,7 @@ sub peekop {
     return sprintf("%s (0x%x) %s", class($op), $$op, $op->name);
 }
 
-sub walkoptree {
+sub walkoptree_slow {
     my($op, $method, $level) = @_;
     $op_count++; # just for statistics
     $level ||= 0;
@@ -90,14 +94,12 @@ sub walkoptree {
 	my $kid;
 	unshift(@parents, $op);
 	for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
-	    walkoptree($kid, $method, $level + 1);
+	    walkoptree_slow($kid, $method, $level + 1);
 	}
 	shift @parents;
     }
 }
 
-*walkoptree_slow = \&walkoptree; # Who is using this?
-
 sub compile_stats {
     return "Total number of OPs processed: $op_count\n";
 }
diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index 7d1675290b..37c08554c9 100644
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -1792,7 +1792,7 @@ sub pp_leaveloop {
        my $state = $kid->first;
        my $cuddle = $self->{'cuddle'};
        my($expr, @exprs);
-       for (; $$state != $$cont; $state = $state->sibling) {
+       for (; $$state != $$cont and can $state "sibling"; $state = $state->sibling) {
 	   $expr = "";
 	   if (is_state $state) {
 	       $expr = $self->deparse($state, 0);
@@ -1803,8 +1803,12 @@ sub pp_leaveloop {
 	   push @exprs, $expr if $expr;
        }
        $kid = join(";\n", @exprs);
+       if (class($cont) eq "LISTOP") {
        $cont = $cuddle . "continue {\n\t" .
 	 $self->deparse($cont, 0) . "\n\b}\cK";
+       } else {
+	   $cont = "\cK";
+       }
     } else {
 	$cont = "\cK";
 	$kid = $self->deparse($kid, 0);
diff --git a/installperl b/installperl
index 99d376fd2c..f3788cf943 100755
--- a/installperl
+++ b/installperl
@@ -162,8 +162,8 @@ if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; }
 -x 'suidperl' . $exe_ext|| die "suidperl isn't executable!\n" if $d_dosuid;
 
 -f 't/rantests'		|| $Is_W32
-			|| warn "WARNING: You've never run 'make test'!!!",
-				"  (Installing anyway.)\n";
+                        || warn "WARNING: You've never run 'make test' or",
+                                " some tests failed! (Installing anyway.)\n";
 
 if ($Is_W32 or $Is_Cygwin) {
   my $perldll;
diff --git a/lib/CGI.pm b/lib/CGI.pm
index e9c916f9b5..617c605b85 100644
--- a/lib/CGI.pm
+++ b/lib/CGI.pm
@@ -107,19 +107,17 @@ unless ($OS) {
 	$OS = $Config::Config{'osname'};
     }
 }
-if ($OS=~/Win/i) {
+if ($OS =~ /^MSWin/i) {
   $OS = 'WINDOWS';
-} elsif ($OS=~/vms/i) {
+} elsif ($OS =~ /^VMS/i) {
   $OS = 'VMS';
-} elsif ($OS=~/bsdos/i) {
-  $OS = 'UNIX';
-} elsif ($OS=~/dos/i) {
+} elsif ($OS =~ /^dos/i) {
   $OS = 'DOS';
-} elsif ($OS=~/^MacOS$/i) {
+} elsif ($OS =~ /^MacOS/i) {
     $OS = 'MACINTOSH';
-} elsif ($OS=~/os2/i) {
+} elsif ($OS =~ /^os2/i) {
     $OS = 'OS2';
-} elsif ($OS=~/epoc/) {
+} elsif ($OS =~ /^epoc/i) {
     $OS = 'EPOC';
 } else {
     $OS = 'UNIX';
diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm
index e926ca7d66..c88f8f7a79 100644
--- a/lib/ExtUtils/MM_Unix.pm
+++ b/lib/ExtUtils/MM_Unix.pm
@@ -1712,6 +1712,7 @@ from the perl source tree.
 	$self->{PERL_INC}     = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now
 	my $perl_h;
 
+	no warnings 'uninitialized' ;
 	if (not -f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h"))
 	    and not $old){
 	    # Maybe somebody tries to build an extension with an
diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm
index 7edcfede7d..78175f9aaf 100644
--- a/lib/ExtUtils/MakeMaker.pm
+++ b/lib/ExtUtils/MakeMaker.pm
@@ -1519,10 +1519,11 @@ at Configure time.
 
 =item MAN3PODS
 
-Hashref of .pm and .pod files. MakeMaker will default this to all
- .pod and any .pm files that include POD directives. The files listed
-here will be converted to man pages and installed as was requested
-at Configure time.
+Hashref that assigns to *.pm and *.pod files the files into which the
+manpages are to be written. MakeMaker parses all *.pod and *.pm files
+for POD directives. Files that contain POD will be the default keys of
+the MAN3PODS hashref. These will then be converted to man pages during
+C<make> and will be installed during C<make install>.
 
 =item MAP_TARGET
 
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 830faabf2b..9baf175833 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -59,17 +59,6 @@ L<perlfunc/accept>.
 (F) The '!' is allowed in pack() and unpack() only after certain types.
 See L<perlfunc/pack>.
 
-=item Ambiguous -%c() resolved as a file test
-
-(W ambiguous) You used a "-" right in front a call to a subroutine
-that has the same name as a Perl file test (C<r w x o R W X O e z s
-f d l p S u g k b c t T B M A C>).
-
-To disambiguate it as a subroutine call, use either an extra space after
-the "-", C<- f(...)>, or an extra set of parentheses, C<-(f(...))>.
-To disambiguate it as a file test, use an extra space after the operator
-name C<-f (...)>, or add the space and remove the parentheses, C<-f ...>.
-
 =item Ambiguous call resolved as CORE::%s(), qualify as such or use &
 
 (W ambiguous) A subroutine you have declared has the same name as a Perl
diff --git a/pod/perlop.pod b/pod/perlop.pod
index 70fef4565b..0bb506ddc7 100644
--- a/pod/perlop.pod
+++ b/pod/perlop.pod
@@ -300,8 +300,13 @@ to the right argument.
 Binary "<=>" returns -1, 0, or 1 depending on whether the left
 argument is numerically less than, equal to, or greater than the right
 argument.  If your platform supports NaNs (not-a-numbers) as numeric
-values, using them with "<=>" (or any other numeric comparison)
-returns undef.
+values, using them with "<=>" returns undef.  NaN is not "<", "==", ">",
+"<=" or ">=" anything (even NaN), so those 5 return false. NaN != NaN
+returns true, as does NaN != anything else. If your platform doesn't
+support NaNs then NaN is just a string with numeric value 0.
+
+    perl -le '$a = NaN; print "No NaN support here" if $a == $a'
+    perl -le '$a = NaN; print "NaN support here" if $a != $a'
 
 Binary "eq" returns true if the left argument is stringwise equal to
 the right argument.
diff --git a/pp.c b/pp.c
index f125d56583..eaa4d17220 100644
--- a/pp.c
+++ b/pp.c
@@ -2833,6 +2833,7 @@ PP(pp_hslice)
 	while (++MARK <= SP) {
 	    SV *keysv = *MARK;
 	    SV **svp;
+	    I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
 	    if (realhv) {
 		HE *he = hv_fetch_ent(hv, keysv, lval, 0);
 		svp = he ? &HeVAL(he) : 0;
@@ -2845,8 +2846,15 @@ PP(pp_hslice)
 		    STRLEN n_a;
 		    DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
 		}
-		if (PL_op->op_private & OPpLVAL_INTRO)
-		    save_helem(hv, keysv, svp);
+		if (PL_op->op_private & OPpLVAL_INTRO) {
+		    if (preeminent) 
+		        save_helem(hv, keysv, svp);
+		    else {
+			STRLEN keylen;
+			char *key = SvPV(keysv, keylen);
+			save_delete(hv, key, keylen);
+		    }
+                }
 	    }
 	    *MARK = svp ? *svp : &PL_sv_undef;
 	}
diff --git a/pp_hot.c b/pp_hot.c
index 979d1111a0..2dedcddf70 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1532,8 +1532,11 @@ PP(pp_helem)
     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
     SV *sv;
     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
+    I32 preeminent;
 
     if (SvTYPE(hv) == SVt_PVHV) {
+	if (PL_op->op_private & OPpLVAL_INTRO)
+	    preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
 	he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
 	svp = he ? &HeVAL(he) : 0;
     }
@@ -1566,8 +1569,14 @@ PP(pp_helem)
 	if (PL_op->op_private & OPpLVAL_INTRO) {
 	    if (HvNAME(hv) && isGV(*svp))
 		save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
-	    else
-		save_helem(hv, keysv, svp);
+	    else {
+		if (!preeminent) {
+		    STRLEN keylen;
+		    char *key = SvPV(keysv, keylen);
+		    save_delete(hv, key, keylen);
+		} else 
+		    save_helem(hv, keysv, svp);
+            }
 	}
 	else if (PL_op->op_private & OPpDEREF)
 	    vivify_ref(*svp, PL_op->op_private & OPpDEREF);
diff --git a/scope.c b/scope.c
index 3f41a4e56b..7c83a41e84 100644
--- a/scope.c
+++ b/scope.c
@@ -852,7 +852,6 @@ Perl_leave_scope(pTHX_ I32 base)
 	    ptr = SSPOPPTR;
 	    (void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD);
 	    SvREFCNT_dec(hv);
-	    Safefree(ptr);
 	    break;
 	case SAVEt_DESTRUCTOR:
 	    ptr = SSPOPPTR;
diff --git a/t/io/utf8.t b/t/io/utf8.t
index f4be69d3a0..ea19a05dba 100755
--- a/t/io/utf8.t
+++ b/t/io/utf8.t
@@ -11,7 +11,7 @@ BEGIN {
 }
 
 $| = 1;
-print "1..13\n";
+print "1..25\n";
 
 open(F,"+>:utf8",'a');
 print F chr(0x100).'£';
@@ -54,5 +54,110 @@ print "not " unless $buf eq "\x{200}\x{100}£";
 print "ok 13\n";
 close(F);
 
-# unlink('a');
+{
+$a = chr(300); # This *is* UTF-encoded
+$b = chr(130); # This is not.
+
+open F, ">:utf8", 'a' or die $!;
+print F $a,"\n";
+close F;
+
+open F, "<:utf8", 'a' or die $!;
+$x = <F>;
+chomp($x);
+print "not " unless $x eq chr(300);
+print "ok 14\n";
+
+open F, "a" or die $!; # Not UTF
+$x = <F>;
+chomp($x);
+print "not " unless $x eq chr(196).chr(172);
+print "ok 15\n";
+close F;
+
+open F, ">:utf8", 'a' or die $!;
+
+print F $a;
+my $y;
+{ my $x = tell(F); 
+    { use bytes; $y = length($a);}
+    print "not " unless $x == $y;
+    print "ok 16\n";
+}
+
+{ # Check byte length of $b
+use bytes; my $y = length($b);
+print "not " unless $y == 1;
+print "ok 17\n";
+}
+
+print F $b,"\n"; # This upgrades $b!
+
+{ # Check byte length of $b
+use bytes; my $y = length($b);
+print "not " unless $y == 2;
+print "ok 18\n";
+}
+
+{ my $x = tell(F); 
+    { use bytes; $y += 3;}
+    print "not " unless $x == $y;
+    print "ok 19\n";
+}
+
+close F;
+
+open F, "a" or die $!; # Not UTF
+$x = <F>;
+chomp($x);
+print "not " unless $x eq v196.172.194.130;
+print "ok 20\n";
+
+open F, "<:utf8", "a" or die $!;
+$x = <F>;
+chomp($x);
+close F;
+print "not " unless $x eq chr(300).chr(130);
+print "ok 21\n";
+
+# Now let's make it suffer.
+open F, ">", "a" or die $!;
+eval { print F $a; };
+print "not " unless $@ and $@ =~ /Wide character in print/i;
+print "ok 22\n";
+}
+
+# Hm. Time to get more evil.
+open F, ">:utf8", "a" or die $!;
+print F $a;
+binmode(F, ":bytes");
+print F chr(130)."\n";
+close F;
+
+open F, "<", "a" or die $!;
+$x = <F>; chomp $x;
+print "not " unless $x eq v196.172.130;
+print "ok 23\n";
+
+# Right.
+open F, ">:utf8", "a" or die $!;
+print F $a;
+close F;
+open F, ">>", "a" or die $!;
+print F chr(130)."\n";
+close F;
+
+open F, "<", "a" or die $!;
+$x = <F>; chomp $x;
+print "not " unless $x eq v196.172.130;
+print "ok 24\n";
+
+# Now we have a deformed file.
+open F, "<:utf8", "a" or die $!;
+$x = <F>; chomp $x;
+{ local $SIG{__WARN__} = sub { print "ok 25\n"; };
+eval { sprintf "%vd\n", $x; }
+}
+
+unlink('a');
 
diff --git a/t/lib/b.t b/t/lib/b.t
index ee49213621..cd5d61a1cf 100755
--- a/t/lib/b.t
+++ b/t/lib/b.t
@@ -10,7 +10,7 @@ use warnings;
 use strict;
 use Config;
 
-print "1..15\n";
+print "1..17\n";
 
 my $test = 1;
 
@@ -78,9 +78,6 @@ LINE: while (defined($_ = <ARGV>)) {
     @F = split(/\s+/, $_, 0);
     '???'
 }
-continue {
-    '???'
-}
 
 EOF
 print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b;
@@ -146,3 +143,14 @@ if ($is_thread) {
     print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s;
 }
 ok;
+
+# Bug 20001204.07
+{
+my $foo = $deparse->coderef2text(sub { { 234; }});
+# Constants don't get optimised here.
+print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm;
+ok;
+$foo = $deparse->coderef2text(sub { { 234; } continue { 123; } });
+print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm; 
+ok;
+}
diff --git a/t/op/local.t b/t/op/local.t
index b478e01993..781afa5b35 100755
--- a/t/op/local.t
+++ b/t/op/local.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..69\n";
+print "1..71\n";
 
 # XXX known to leak scalars
 $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
@@ -235,3 +235,14 @@ while (/(o.+?),/gc) {
     untie $_;
 }
 
+{
+    # BUG 20001205.22
+    my %x;
+    $x{a} = 1;
+    { local $x{b} = 1; }
+    print "not " if exists $x{b};
+    print "ok 70\n";
+    { local @x{c,d,e}; }
+    print "not " if exists $x{c};
+    print "ok 71\n"; 
+}
diff --git a/t/pragma/warn/toke b/t/pragma/warn/toke
index 1f8b14283a..2c9433bd7d 100644
--- a/t/pragma/warn/toke
+++ b/t/pragma/warn/toke
@@ -123,9 +123,6 @@ toke.c	AOK
     Ambiguous use of %c resolved as operator %c
         *foo *foo
 
-    Ambiguous -f%c call resolved as a file test		[yylex]
-	sub f { }; -f(0)
-
 __END__
 # toke.c 
 use warnings 'deprecated' ;
@@ -567,19 +564,3 @@ no warnings 'ambiguous';
 "@mjd_previously_unused_array";        
 EXPECT
 Possible unintended interpolation of @mjd_previously_unused_array in string at - line 3.
-########
-# toke.c
-use warnings 'ambiguous';
-sub f { 24 }
--f("TEST");
-print - f("TEST");
-print -(f("TEST"));
-print -f ("TEST");
-print -f "TEST";
-sub Q { 42 };
-print -Q();
-EXPECT
-Ambiguous -f() resolved as a file test at - line 4.
-Ambiguous -f() resolved as a file test at - line 7.
--24-2411-42
-
diff --git a/toke.c b/toke.c
index d8ffc1ee9d..cd6ed1d32c 100644
--- a/toke.c
+++ b/toke.c
@@ -2850,15 +2850,14 @@ Perl_yylex(pTHX)
 		DEBUG_T( { PerlIO_printf(Perl_debug_log,
                         "### Saw file test %c\n", ftst);
 		} )
-		if (*s == '(' && ckWARN(WARN_AMBIGUOUS))
-		    Perl_warner(aTHX_ WARN_AMBIGUOUS,
-				"Ambiguous -%c() resolved as a file test",
-				tmp);
 		FTST(ftst);
 	    }
 	    else {
 		/* Assume it was a minus followed by a one-letter named
 		 * subroutine call (or a -bareword), then. */
+		DEBUG_T( { PerlIO_printf(Perl_debug_log,
+                        "### %c looked like a file test but was not\n", ftst);
+		} )
 		s -= 2;
 	    }
 	}