&CORE::caller()
authorFather Chrysostomos <sprout@cpan.org>
Sun, 21 Aug 2011 18:59:44 +0000 (11:59 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Thu, 25 Aug 2011 21:24:36 +0000 (14:24 -0700)
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
op.c
pp.c
pp_ctl.c
t/op/coresubs.t

diff --git a/gv.c b/gv.c
index 0bbf09e..2b469ec 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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;
index a239f10..997f492 100644 (file)
--- 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);
index 9a615fc..799d357 100644 (file)
@@ -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';