From: josh <twists@gmail.com>
Date: Sun, 14 Oct 2007 21:37:08 +0000 (-0700)
Subject: Fix a few segfaults and a when() bug
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1e1d4b91957a9f66bbb14b2c7f1bbf88c1f89cdf;p=p5sagit%2Fp5-mst-13.2.git

Fix a few segfaults and a when() bug
From: "josh" <twists@gmail.com>
Message-ID: <20071015043708.GA10981@grenekatz.org>

p4raw-id: //depot/perl@32120
---

diff --git a/op.c b/op.c
index 32e2a54..c16c111 100644
--- a/op.c
+++ b/op.c
@@ -4937,6 +4937,11 @@ S_looks_like_bool(pTHX_ const OP *o)
 	    	looks_like_bool(cLOGOPo->op_first)
 	     && looks_like_bool(cLOGOPo->op_first->op_sibling));
 
+	case OP_NULL:
+	    return (
+		o->op_flags & OPf_KIDS
+	    && looks_like_bool(cUNOPo->op_first));
+
 	case OP_ENTERSUB:
 
 	case OP_NOT:	case OP_XOR:
diff --git a/pp_sys.c b/pp_sys.c
index 7770dc2..6aa8645 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -2012,7 +2012,12 @@ PP(pp_eof)
 		    IoLINES(io) = 0;
 		    IoFLAGS(io) &= ~IOf_START;
 		    do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
-		    sv_setpvn(GvSV(gv), "-", 1);
+		    if ( GvSV(gv) ) {
+			sv_setpvn(GvSV(gv), "-", 1);
+		    }
+		    else {
+			GvSV(gv) = newSVpvn("-", 1);
+		    }
 		    SvSETMAGIC(GvSV(gv));
 		}
 		else if (!nextargv(gv))
diff --git a/regcomp.c b/regcomp.c
index 99cb464..3ad5d8c 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -4944,9 +4944,13 @@ Perl_reg_named_buff_exists(pTHX_ REGEXP * const rx, SV * const key,
 SV*
 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const rx, const U32 flags)
 {
-    (void)hv_iterinit(rx->paren_names);
+    if ( rx && rx->paren_names ) {
+	(void)hv_iterinit(rx->paren_names);
 
-    return CALLREG_NAMED_BUFF_NEXTKEY(rx, NULL, flags & ~RXapif_FIRSTKEY);
+	return CALLREG_NAMED_BUFF_NEXTKEY(rx, NULL, flags & ~RXapif_FIRSTKEY);
+    } else {
+	return FALSE;
+    }
 }
 
 SV*
diff --git a/t/io/argv.t b/t/io/argv.t
index c24dad5..d6c895d 100755
--- a/t/io/argv.t
+++ b/t/io/argv.t
@@ -7,7 +7,7 @@ BEGIN {
 
 BEGIN { require "./test.pl"; }
 
-plan(tests => 22);
+plan(tests => 23);
 
 use File::Spec;
 
@@ -38,6 +38,13 @@ is($x, "1a line\n2a line\n", '<> from two files');
     is($x, "foo\n", '   from just STDIN');
 }
 
+{
+    # 5.10 stopped autovivifying scalars in globs leading to a
+    # segfault when $ARGV is written to.
+    runperl( prog => 'eof()', stdin => "nothing\n" );
+    is( 0+$?, 0, q(eof() doesn't segfault) );
+}
+
 @ARGV = ('Io_argv1.tmp', 'Io_argv1.tmp', $devnull, 'Io_argv1.tmp');
 while (<>) {
     $y .= $. . $_;
@@ -56,7 +63,7 @@ close TRY or die "Could not close: $!";
 @ARGV = ('Io_argv1.tmp', 'Io_argv2.tmp');
 $^I = '_bak';   # not .bak which confuses VMS
 $/ = undef;
-my $i = 6;
+my $i = 7;
 while (<>) {
     s/^/ok $i\n/;
     ++$i;
@@ -81,7 +88,7 @@ open STDIN, 'Io_argv1.tmp' or die $!;
 @ARGV = ();
 ok( !eof(),     'STDIN has something' );
 
-is( <>, "ok 6\n" );
+is( <>, "ok 7\n" );
 
 open STDIN, $devnull or die $!;
 @ARGV = ();
diff --git a/t/op/reg_nc_tie.t b/t/op/reg_nc_tie.t
index f72970e..7a79a8e 100644
--- a/t/op/reg_nc_tie.t
+++ b/t/op/reg_nc_tie.t
@@ -8,7 +8,12 @@ BEGIN {
 
 # Do a basic test on all the tied methods of Tie::Hash::NamedCapture
 
-print "1..12\n";
+print "1..13\n";
+
+# PL_curpm->paren_names can be a null pointer. See that this succeeds anyway.
+'x' =~ /(.)/;
+() = %+;
+pass( 'still alive' );
 
 "hlagh" =~ /
     (?<a>.)
diff --git a/t/op/switch.t b/t/op/switch.t
index 98e10f6..d897157 100644
--- a/t/op/switch.t
+++ b/t/op/switch.t
@@ -8,7 +8,7 @@ BEGIN {
 use strict;
 use warnings;
 
-use Test::More tests => 107;
+use Test::More tests => 108;
 
 # The behaviour of the feature pragma should be tested by lib/switch.t
 # using the tests in t/lib/switch/*. This file tests the behaviour of
@@ -457,6 +457,16 @@ sub bar {"bar"}
 # Other things that should not be smart matched
 {
     my $ok = 0;
+    given(12) {
+        when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) {
+            $ok = 1;
+        }
+    }
+    ok($ok, "bool not smartmatches");
+}
+
+{
+    my $ok = 0;
     given(0) {
 	when(eof(DATA)) {
 	    $ok = 1;
@@ -500,13 +510,13 @@ sub bar {"bar"}
 }
 
 {
-    my $ok = 1;
-    given(0) {
+    my $ok = 0;
+    given("foo") {
 	when((1 == $ok) || "foo") {
-	    $ok = 0;
+	    $ok = 1;
 	}
     }
-    ok($ok, '((1 == $ok) || "foo") not smartmatched');
+    ok($ok, '((1 == $ok) || "foo") smartmatched');
 }