return NORMAL;
}
+/* This is sometimes called directly by pp_coreargs. */
PP(pp_pushmark)
{
dVAR;
context. */
if (!got_coderef && !is_gv && GIMME_V == G_VOID) {
/* Is the target symbol table currently empty? */
- GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
+ GV * const gv = gv_fetchsv_nomg(right, GV_NOINIT, SVt_PVGV);
if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
/* Good. Create a new proxy constant subroutine in the target.
The gv becomes a(nother) reference to the constant. */
/* Need to fix things up. */
if (!is_gv) {
/* Need to fix GV. */
- right = MUTABLE_SV(gv_fetchsv(right, GV_ADD, SVt_PVGV));
+ right = MUTABLE_SV(gv_fetchsv_nomg(right,GV_ADD, SVt_PVGV));
}
if (!got_coderef) {
SAVECLEARSV(PAD_SVl(PL_op->op_targ));
if (PL_op->op_private & OPpDEREF) {
PUTBACK;
- vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
+ TOPs = vivify_ref(TOPs, PL_op->op_private & OPpDEREF);
SPAGAIN;
}
}
PP(pp_readline)
{
dVAR;
- dSP; SvGETMAGIC(TOPs);
- tryAMAGICunTARGET(iter_amg, 0, 0);
- PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
+ dSP;
+ if (TOPs) {
+ SvGETMAGIC(TOPs);
+ tryAMAGICunTARGET(iter_amg, 0, 0);
+ PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
+ }
+ else PL_last_in_gv = PL_argvgv, PL_stack_sp--;
if (!isGV_with_GP(PL_last_in_gv)) {
if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
- if (!(PL_op->op_private & OPpDEREFed))
- SvGETMAGIC(sv);
+ SvGETMAGIC(sv);
if (SvROK(sv)) {
if (SvAMAGIC(sv)) {
sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
}
}
-PP(pp_enter)
-{
- dVAR; dSP;
- register PERL_CONTEXT *cx;
- I32 gimme = OP_GIMME(PL_op, -1);
-
- if (gimme == -1) {
- if (cxstack_ix >= 0) {
- /* If this flag is set, we're just inside a return, so we should
- * store the caller's context */
- gimme = (PL_op->op_flags & OPf_SPECIAL)
- ? block_gimme()
- : cxstack[cxstack_ix].blk_gimme;
- } else
- gimme = G_SCALAR;
- }
-
- ENTER_with_name("block");
-
- SAVETMPS;
- PUSHBLOCK(cx, CXt_BLOCK, SP);
-
- RETURN;
-}
-
PP(pp_helem)
{
dVAR; dSP;
else
SAVEHDELETE(hv, keysv);
}
- else if (PL_op->op_private & OPpDEREF)
- vivify_ref(*svp, PL_op->op_private & OPpDEREF);
+ else if (PL_op->op_private & OPpDEREF) {
+ PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
+ RETURN;
+ }
}
sv = (svp ? *svp : &PL_sv_undef);
/* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
RETURN;
}
-PP(pp_leave)
-{
- dVAR; dSP;
- register PERL_CONTEXT *cx;
- SV **newsp;
- PMOP *newpm;
- I32 gimme;
-
- if (PL_op->op_flags & OPf_SPECIAL) {
- cx = &cxstack[cxstack_ix];
- cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
- }
-
- POPBLOCK(cx,newpm);
-
- gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
-
- TAINT_NOT;
- if (gimme == G_VOID)
- SP = newsp;
- else if (gimme == G_SCALAR) {
- register SV **mark;
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- } else {
- MEXTEND(mark,0);
- *MARK = &PL_sv_undef;
- }
- SP = MARK;
- }
- else if (gimme == G_ARRAY) {
- /* in case LEAVE wipes old return values */
- register SV **mark;
- for (mark = newsp + 1; mark <= SP; mark++) {
- if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
- *mark = sv_mortalcopy(*mark);
- TAINT_NOT; /* Each item is independent */
- }
- }
- }
- PL_curpm = newpm; /* Don't pop $1 et al till now */
-
- LEAVE_with_name("block");
-
- RETURN;
-}
-
PP(pp_iter)
{
dVAR; dSP;
else {
if (force_on_match) {
force_on_match = 0;
+ if (rpm->op_pmflags & PMf_NONDESTRUCT) {
+ /* I feel that it should be possible to avoid this mortal copy
+ given that the code below copies into a new destination.
+ However, I suspect it isn't worth the complexity of
+ unravelling the C<goto force_it> for the small number of
+ cases where it would be viable to drop into the copy code. */
+ TARG = sv_2mortal(newSVsv(TARG));
+ }
s = SvPV_force(TARG, len);
goto force_it;
}
I32 gimme;
register PERL_CONTEXT *cx;
SV *sv;
- bool gmagic;
if (CxMULTICALL(&cxstack[cxstack_ix]))
return 0;
POPBLOCK(cx,newpm);
cxstack_ix++; /* temporarily protect top context */
- gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF;
TAINT_NOT;
if (gimme == G_SCALAR) {
*MARK = SvREFCNT_inc(TOPs);
FREETMPS;
sv_2mortal(*MARK);
- if (gmagic) SvGETMAGIC(*MARK);
}
else {
sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
}
else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
*MARK = TOPs;
- if (gmagic) SvGETMAGIC(TOPs);
}
else
*MARK = sv_mortalcopy(TOPs);
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Use of reference \"%"SVf"\" as array index",
SVfARG(elemsv));
- if (elem > 0)
- elem -= CopARYBASE_get(PL_curcop);
if (SvTYPE(av) != SVt_PVAV)
RETPUSHUNDEF;
else
SAVEADELETE(av, elem);
}
- else if (PL_op->op_private & OPpDEREF)
- vivify_ref(*svp, PL_op->op_private & OPpDEREF);
+ else if (PL_op->op_private & OPpDEREF) {
+ PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF));
+ RETURN;
+ }
}
sv = (svp ? *svp : &PL_sv_undef);
if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
RETURN;
}
-void
+SV*
Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
{
PERL_ARGS_ASSERT_VIVIFY_REF;
SvROK_on(sv);
SvSETMAGIC(sv);
}
+ if (SvGMAGICAL(sv)) {
+ /* copy the sv without magic to prevent magic from being
+ executed twice */
+ SV* msv = sv_newmortal();
+ sv_setsv_nomg(msv, sv);
+ return msv;
+ }
+ return sv;
}
PP(pp_method)
ob = MUTABLE_SV(SvRV(sv));
else {
GV* iogv;
+ bool packname_is_utf8 = FALSE;
/* this isn't a reference */
- if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
- const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
+ if(SvOK(sv) && (packname = SvPV_nomg_const(sv, packlen))) {
+ const HE* const he =
+ (const HE *)hv_common_key_len(
+ PL_stashcache, packname,
+ packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
+ );
+
if (he) {
stash = INT2PTR(HV*,SvIV(HeVAL(he)));
goto fetch;
if (!SvOK(sv) ||
!(packname) ||
- !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
+ !(iogv = gv_fetchpvn_flags(
+ packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
+ )) ||
!(ob=MUTABLE_SV(GvIO(iogv))))
{
/* this isn't the name of a filehandle either */
https://perl5.git.perl.org / perl5.git / blobdiff