From: Father Chrysostomos <sprout@cpan.org>
Date: Thu, 18 Aug 2011 05:10:30 +0000 (-0700)
Subject: &CORE::wantarray()
X-Git-Tag: accepted/trunk/20130322.191538~3134
X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=93f0bc4935f6ab558dbbd7c94b5d4a9bdd07eb9e;p=platform%2Fupstream%2Fperl.git

&CORE::wantarray()

This commit allows &CORE::wantarray to be called via ampersand syntax
or through references.

It adds a new private flag for wantarray, OPpOFFBYONE, which caller
will use as well, telling wantarray (or caller) to look one call fur-
ther up the call stack.
---

diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 3849e17..d04fb71 100644
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -658,6 +658,7 @@ if ($] >= 5.009) {
   $priv{$_}{2} = "GREPLEX"
     for ("mapwhile", "mapstart", "grepwhile", "grepstart");
 }
+$priv{$_}{128} = '+1' for qw "caller wantarray";
 
 our %hints; # used to display each COP's op_hints values
 
diff --git a/gv.c b/gv.c
index 6c9cf93..c3d0f01 100644
--- a/gv.c
+++ b/gv.c
@@ -1359,7 +1359,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	    case KEY_getlogin: case KEY_getnetent: case KEY_getppid:
 	    case KEY_getprotoent: case KEY_getservent: case KEY_setgrent:
 	    case KEY_setpwent: case KEY_time: case KEY_times:
-	    case KEY_wait:
+	    case KEY_wait: case KEY_wantarray:
 		ampable = TRUE;
 	    }
 	    if (ampable) {
@@ -1416,7 +1416,13 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 			break;
 		    }
 		default:
-		    o = op_append_elem(OP_LINESEQ, argop, newOP(opnum,0));
+		    o = op_append_elem(OP_LINESEQ, argop,
+		                       newOP(opnum,
+		                             opnum == OP_WANTARRAY
+		                               ? OPpOFFBYONE << 8
+		                               : 0
+		                            )
+		                      );
 		}
 		newATTRSUB(oldsavestack_ix,
 		           newSVOP(
diff --git a/op.h b/op.h
index f01e0bf..6a6e3f2 100644
--- a/op.h
+++ b/op.h
@@ -296,6 +296,9 @@ Deprecated.  Use C<GIMME_V> instead.
 /* Private for OP_ENTEREVAL */
 #define OPpEVAL_HAS_HH		2	/* Does it have a copy of %^H */
     
+/* Private for OP_CALLER and OP_WANTARRAY */
+#define OPpOFFBYONE		128	/* Treat caller(1) as caller(2) */
+
 struct op {
     BASEOP
 };
diff --git a/pp_ctl.c b/pp_ctl.c
index c0a16e4..9aa50fa 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -43,13 +43,20 @@ PP(pp_wantarray)
     dVAR;
     dSP;
     I32 cxix;
+    const PERL_CONTEXT *cx;
     EXTEND(SP, 1);
 
-    cxix = dopoptosub(cxstack_ix);
-    if (cxix < 0)
+    if (PL_op->op_private & OPpOFFBYONE) {
+	if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
+    }
+    else {
+      cxix = dopoptosub(cxstack_ix);
+      if (cxix < 0)
 	RETPUSHUNDEF;
+      cx = &cxstack[cxix];
+    }
 
-    switch (cxstack[cxix].blk_gimme) {
+    switch (cx->blk_gimme) {
     case G_ARRAY:
 	RETPUSHYES;
     case G_SCALAR:
diff --git a/t/op/coresubs.t b/t/op/coresubs.t
index 71e030a..c7924aa 100644
--- a/t/op/coresubs.t
+++ b/t/op/coresubs.t
@@ -92,6 +92,20 @@ like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z',
 
 test_proto 'wait';
 
+test_proto 'wantarray';
+$tests += 4;
+my $context;
+my $cx_sub = sub {
+  $context = qw[void scalar list][&mywantarray + defined mywantarray()]
+};
+() = &$cx_sub;
+is $context, 'list', '&wantarray with caller in list context';
+scalar &$cx_sub;
+is($context, 'scalar', '&wantarray with caller in scalar context');
+&$cx_sub;
+is($context, 'void', '&wantarray with caller in void context');
+lis [&mywantarray],[wantarray], '&wantarray itself in list context';
+
 
 # Add new tests above this line.