&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\rwill 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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.