/* We've been returned a constant rather than a full subroutine,
but they expect a subroutine reference to apply. */
if (SvROK(cv)) {
- ENTER;
+ ENTER_with_name("sassign_coderef");
SvREFCNT_inc_void(SvRV(cv));
/* newCONSTSUB takes a reference count on the passed in SV
from us. We set the name to NULL, otherwise we get into
SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
SvRV(cv))));
SvREFCNT_dec(cv);
- LEAVE;
+ LEAVE_with_name("sassign_coderef");
} else {
/* What can happen for the corner case *{"BONK"} = \&{"BONK"};
is that
PUSHMARK(MARK - 1);
*MARK = SvTIED_obj(MUTABLE_SV(io), mg);
PUTBACK;
- ENTER;
+ ENTER_with_name("call_PRINT");
if( PL_op->op_type == OP_SAY ) {
/* local $\ = "\n" */
SAVEGENERICSV(PL_ors_sv);
PL_ors_sv = newSVpvs("\n");
}
call_method("PRINT", G_SCALAR);
- LEAVE;
+ LEAVE_with_name("call_PRINT");
SPAGAIN;
MARK = ORIGMARK + 1;
*MARK = *SP;
SV * const rv = sv_newmortal();
SvUPGRADE(rv, SVt_IV);
- /* This RV is about to own a reference to the regexp. (In addition to the
- reference already owned by the PMOP. */
- ReREFCNT_inc(rx);
- SvRV_set(rv, MUTABLE_SV(rx));
+ /* For a subroutine describing itself as "This is a hacky workaround" I'm
+ loathe to use it here, but it seems to be the right fix. Or close.
+ The key part appears to be that it's essential for pp_qr to return a new
+ object (SV), which implies that there needs to be an effective way to
+ generate a new SV from the existing SV that is pre-compiled in the
+ optree. */
+ SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
SvROK_on(rv);
if (pkg) {
}
PUTBACK; /* EVAL blocks need stack_sp. */
- s = SvPV_const(TARG, len);
+ /* Skip get-magic if this is a qr// clone, because regcomp has
+ already done it. */
+ s = ((struct regexp *)SvANY(rx))->mother_re
+ ? SvPV_nomg_const(TARG, len)
+ : SvPV_const(TARG, len);
if (!s)
DIE(aTHX_ "panic: pp_match");
strend = s + len;
PUSHMARK(SP);
XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
PUTBACK;
- ENTER;
+ ENTER_with_name("call_READLINE");
call_method("READLINE", gimme);
- LEAVE;
+ LEAVE_with_name("call_READLINE");
SPAGAIN;
if (gimme == G_SCALAR) {
SV* const result = POPs;
(void)do_close(PL_last_in_gv, FALSE);
}
else if (type == OP_GLOB) {
- if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
- Perl_warner(aTHX_ packWARN(WARN_GLOB),
- "glob failed (child exited with status %d%s)",
- (int)(STATUS_CURRENT >> 8),
- (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
+ if (!do_close(PL_last_in_gv, FALSE)) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
+ "glob failed (child exited with status %d%s)",
+ (int)(STATUS_CURRENT >> 8),
+ (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
}
}
if (gimme == G_SCALAR) {
gimme = G_SCALAR;
}
- ENTER;
+ ENTER_with_name("block");
SAVETMPS;
PUSHBLOCK(cx, CXt_BLOCK, SP);
const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
SV *sv;
const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
+ const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
bool preeminent = TRUE;
if (SvTYPE(hv) != SVt_PVHV)
RETPUSHUNDEF;
- if (PL_op->op_private & OPpLVAL_INTRO) {
+ if (localizing) {
MAGIC *mg;
HV *stash;
PUSHs(lv);
RETURN;
}
- if (PL_op->op_private & OPpLVAL_INTRO) {
+ if (localizing) {
if (HvNAME_get(hv) && isGV(*svp))
save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
- else {
- if (!preeminent) {
- STRLEN keylen;
- const char * const key = SvPV_const(keysv, keylen);
- SAVEDELETE(hv, savepvn(key,keylen),
- SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
- } else
- save_helem_flags(hv, keysv, svp,
- (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
- }
+ else if (preeminent)
+ save_helem_flags(hv, keysv, svp,
+ (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
+ else
+ SAVEHDELETE(hv, keysv);
}
else if (PL_op->op_private & OPpDEREF)
vivify_ref(*svp, PL_op->op_private & OPpDEREF);
}
PL_curpm = newpm; /* Don't pop $1 et al till now */
- LEAVE;
+ LEAVE_with_name("block");
RETURN;
}
if (SvTRUEx(POPs))
PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
++*PL_markstack_ptr;
- LEAVE; /* exit inner scope */
+ LEAVE_with_name("grep_item"); /* exit inner scope */
/* All done yet? */
if (PL_stack_base + *PL_markstack_ptr > SP) {
I32 items;
const I32 gimme = GIMME_V;
- LEAVE; /* exit outer scope */
+ LEAVE_with_name("grep"); /* exit outer scope */
(void)POPMARK; /* pop src */
items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
(void)POPMARK; /* pop dst */
else {
SV *src;
- ENTER; /* enter inner scope */
+ ENTER_with_name("grep_item"); /* enter inner scope */
SAVEVPTR(PL_curpm);
src = PL_stack_base[*PL_markstack_ptr];
if (!sym)
DIE(aTHX_ PL_no_usym, "a subroutine");
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_symref, sym, "a subroutine");
+ DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
break;
}
PL_curcopdb = PL_curcop;
if (CvLVALUE(cv)) {
/* check for lsub that handles lvalue subroutines */
- cv = GvCV(gv_HVadd(gv_fetchpv("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
+ cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
/* if lsub not found then fall back to DB::sub */
if (!cv) cv = GvCV(PL_DBsub);
} else {
PL_curcopdb = NULL;
}
/* Do we need to open block here? XXXX */
- if (CvXSUB(cv)) /* XXX this is supposed to be true */
- (void)(*CvXSUB(cv))(aTHX_ cv);
+
+ /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
+ assert(CvXSUB(cv));
+ CALL_FPTR(CvXSUB(cv))(aTHX_ cv);
/* Enforce some sanity in scalar context. */
if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
SV* ob;
GV* gv;
HV* stash;
- STRLEN namelen;
const char* packname = NULL;
SV *packsv = NULL;
STRLEN packlen;
- const char * const name = SvPV_const(meth, namelen);
SV * const sv = *(PL_stack_base + TOPMARK + 1);
PERL_ARGS_ASSERT_METHOD_COMMON;
if (!sv)
- Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
+ Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
+ SVfARG(meth));
SvGETMAGIC(sv);
if (SvROK(sv))
: !isIDFIRST(*packname)
))
{
- Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
+ Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
+ SVfARG(meth),
SvOK(sv) ? "without a package or object reference"
: "on an undefined value");
}
&& (ob = MUTABLE_SV(GvIO((const GV *)ob)))
&& SvOBJECT(ob))))
{
+ const char * const name = SvPV_nolen_const(meth);
Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
(SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
name);
}
}
- gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv), name,
+ gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
+ SvPV_nolen_const(meth),
GV_AUTOLOAD | GV_CROAK);
assert(gv);
projects / p5sagit/p5-mst-13.2.git / blobdiff