From ce0b554bf53c768c04939d95a2e6b23356a045b0 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Sun, 21 Aug 2011 11:59:44 -0700
Subject: [PATCH] &CORE::caller()

This commit allows &CORE::caller to be called through references and
via ampersand syntax.  pp_caller is modified to take into account
two things:
1) pp_coreargs pushes a null on to the stack, since it has no other
   way to tell caller whether it has an argument.
2) The value coming from pp_coreargs (when not null) is off by
   one.  The OPpOFFYBONE flag was added in commit 93f0bc4935 for
   this purpose.

pp_coreargs is also modified, since it assumed till now that an
optional first argument was an implicit $_.
---
 gv.c            |  2 +-
 op.c            |  5 ++++-
 pp.c            |  3 ++-
 pp_ctl.c        | 10 +++++++---
 t/op/coresubs.t | 19 +++++++++++++++++++
 5 files changed, 33 insertions(+), 6 deletions(-)

diff --git a/gv.c b/gv.c
index 0bbf09e..2b469ec 100644
--- a/gv.c
+++ b/gv.c
@@ -1351,7 +1351,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	    case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne:
 	    case KEY_or: case KEY_x: case KEY_xor:
 		return gv;
-	    case KEY_caller: case KEY_chdir:
+	    case KEY_chdir:
 	    case KEY_chmod: case KEY_chomp: case KEY_chop: case KEY_chown:
 	    case KEY_close:
 	    case KEY_dbmclose: case KEY_dbmopen: case KEY_die:
diff --git a/op.c b/op.c
index 02811c6..9736758 100644
--- a/op.c
+++ b/op.c
@@ -10364,9 +10364,12 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
 	           );
 	case OA_BASEOP_OR_UNOP:
 	    o = newUNOP(opnum,0,argop);
+	    if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
+	    else {
 	  onearg:
-	    if (is_handle_constructor(o, 1))
+	      if (is_handle_constructor(o, 1))
 		argop->op_private |= OPpCOREARGS_DEREF1;
+	    }
 	    return o;
 	default:
 	    o = convert(opnum,0,argop);
diff --git a/pp.c b/pp.c
index 04e4e4a..7cffe23 100644
--- a/pp.c
+++ b/pp.c
@@ -6010,6 +6010,7 @@ PP(pp_coreargs)
 {
     dSP;
     int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
+    int defgv = PL_opargs[opnum] & OA_DEFGV;
     AV * const at_ = GvAV(PL_defgv);
     SV **svp = AvARRAY(at_);
     I32 minargs = 0, maxargs = 0, numargs = AvFILLp(at_)+1, whicharg = 0;
@@ -6048,7 +6049,7 @@ PP(pp_coreargs)
     PUTBACK; /* The code below can die in various places. */
 
     oa = PL_opargs[opnum] >> OASHIFT;
-    if (!numargs) {
+    if (!numargs && defgv) {
 	PERL_SI * const oldsi = PL_curstackinfo;
 	I32 const oldcxix = oldsi->si_cxix;
 	CV *caller;
diff --git a/pp_ctl.c b/pp_ctl.c
index a239f10..997f492 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1871,11 +1871,15 @@ PP(pp_caller)
     I32 gimme;
     const char *stashname;
     I32 count = 0;
+    bool has_arg = MAXARG && TOPs;
 
-    if (MAXARG)
+    if (MAXARG) {
+      if (has_arg)
 	count = POPi;
+      else (void)POPs;
+    }
 
-    cx = caller_cx(count, &dbcx);
+    cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
     if (!cx) {
 	if (GIMME != G_ARRAY) {
 	    EXTEND(SP, 1);
@@ -1905,7 +1909,7 @@ PP(pp_caller)
 	mPUSHs(newSVpv(stashname, 0));
     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
     mPUSHi((I32)CopLINE(cx->blk_oldcop));
-    if (!MAXARG)
+    if (!has_arg)
 	RETURN;
     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
 	GV * const cvgv = CvGV(dbcx->blk_sub.cv);
diff --git a/t/op/coresubs.t b/t/op/coresubs.t
index 9a615fc..799d357 100644
--- a/t/op/coresubs.t
+++ b/t/op/coresubs.t
@@ -99,6 +99,12 @@ sub test_proto {
        is "CORE::$o"->(), $out, "&$o with the right lexical \$_ in an eval"
     };   
   }
+  elsif ($p =~ '^;([$*]+)\z') { # ;$ ;* ;$$ etc.
+    my $maxargs = length $1;
+    $tests += 1;    
+    eval " &CORE::$o((1)x($maxargs+1)) ";
+    like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
+  }
   elsif ($p =~ '^([$*]+);?\z') { # Fixed-length $$$ or ***
     my $args = length $1;
     $tests += 2;    
@@ -184,6 +190,19 @@ test_proto 'break';
   is $tmp, undef, '&break';
 }
 
+test_proto 'caller';
+$tests += 4;
+sub caller_test {
+    is scalar &CORE::caller, 'hadhad', '&caller';
+    is scalar &CORE::caller(1), 'main', '&caller(1)';
+    lis [&CORE::caller], [caller], '&caller in list context';
+    lis [&CORE::caller(1)], [caller(1)], '&caller(1) in list context';
+}
+sub {
+   package hadhad;
+   ::caller_test();
+}->();
+
 test_proto 'chr', 5, "\5";
 test_proto 'chroot';
 
-- 
2.7.4