diff options
| -rw-r--r-- | gv.c | 2 | ||||
| -rw-r--r-- | op.c | 5 | ||||
| -rw-r--r-- | pp.c | 3 | ||||
| -rw-r--r-- | pp_ctl.c | 10 | ||||
| -rw-r--r-- | t/op/coresubs.t | 19 |
5 files changed, 33 insertions, 6 deletions
@@ -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: @@ -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); @@ -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; @@ -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 9a615fca2a..799d3573f4 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'; |