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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (executable)
--- 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 (file)
--- 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 (file)
--- 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');
 }