From: Rafael Garcia-Suarez <rgs@consttype.org>
Date: Thu, 8 Oct 2009 09:33:06 +0000 (+0200)
Subject: Properly return a syntax error instead of segfaulting if each/keys/values is used... 
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a916b30221d5aac718ed67c9a5bc9c0905daddd0;p=p5sagit%2Fp5-mst-13.2.git

Properly return a syntax error instead of segfaulting if each/keys/values is used without an argument
---

diff --git a/op.c b/op.c
index c3736fa..4d85e23 100644
--- a/op.c
+++ b/op.c
@@ -8257,21 +8257,23 @@ OP *
 Perl_ck_each(pTHX_ OP *o)
 {
     dVAR;
-    OP *kid = cLISTOPo->op_first;
+    OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
 
     PERL_ARGS_ASSERT_CK_EACH;
 
-    if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
-	const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
-	    : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
-	o->op_type = new_type;
-	o->op_ppaddr = PL_ppaddr[new_type];
-    }
-    else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
-	       || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
-	       )) {
-	bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
-	return o;
+    if (kid) {
+	if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
+	    const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
+		: o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
+	    o->op_type = new_type;
+	    o->op_ppaddr = PL_ppaddr[new_type];
+	}
+	else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
+		    || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
+		  )) {
+	    bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
+	    return o;
+	}
     }
     return ck_fun(o);
 }
diff --git a/t/op/each.t b/t/op/each.t
index 1bd529d..b88f1ea 100644
--- a/t/op/each.t
+++ b/t/op/each.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 39;
+plan tests => 42;
 
 $h{'abc'} = 'ABC';
 $h{'def'} = 'DEF';
@@ -187,3 +187,9 @@ for (keys %u) {
     is($u{$u1}, 3, "U+0100        -> 3 ");
     is($u{$b1}, 4, "U+00C4 U+0080 -> 4");
 }
+
+# test for syntax errors
+for my $k (qw(each keys values)) {
+    eval $k;
+    like($@, qr/^Not enough arguments for $k/, "$k demands argument");
+}