TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
+ PERL_ASYNC_CHECK();
return NORMAL;
}
PP(pp_and)
{
dVAR; dSP;
+ PERL_ASYNC_CHECK();
if (!SvTRUE(TOPs))
RETURN;
else {
if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
SV * const cv = SvRV(left);
const U32 cv_type = SvTYPE(cv);
- const U32 gv_type = SvTYPE(right);
+ const bool is_gv = isGV_with_GP(right);
const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
if (!got_coderef) {
/* Can do the optimisation if right (LVALUE) is not a typeglob,
left (RVALUE) is a reference to something, and we're in void
context. */
- if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
+ 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);
if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
}
/* Need to fix things up. */
- if (gv_type != SVt_PVGV) {
+ if (!is_gv) {
/* Need to fix GV. */
right = MUTABLE_SV(gv_fetchsv(right, GV_ADD, SVt_PVGV));
}
/* 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
PP(pp_cond_expr)
{
dVAR; dSP;
+ PERL_ASYNC_CHECK();
if (SvTRUEx(POPs))
RETURNOP(cLOGOP->op_other);
else
PP(pp_unstack)
{
dVAR;
- I32 oldsave;
+ PERL_ASYNC_CHECK();
TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
- oldsave = PL_scopestack[PL_scopestack_ix - 1];
- LEAVE_SCOPE(oldsave);
+ if (!(PL_op->op_flags & OPf_SPECIAL)) {
+ I32 oldsave = PL_scopestack[PL_scopestack_ix - 1];
+ LEAVE_SCOPE(oldsave);
+ }
return NORMAL;
}
PP(pp_concat)
{
- dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
{
dPOPTOPssrl;
bool lbyte;
bool rbyte = FALSE;
bool rcopied = FALSE;
- if (TARG == right && right != left) {
- /* mg_get(right) may happen here ... */
- rpv = SvPV_const(right, rlen);
+ if (TARG == right && right != left) { /* $r = $l.$r */
+ rpv = SvPV_nomg_const(right, rlen);
rbyte = !DO_UTF8(right);
right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
rcopied = TRUE;
}
- if (TARG != left) {
+ if (TARG != left) { /* not $l .= $r */
STRLEN llen;
- const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
+ const char* const lpv = SvPV_nomg_const(left, llen);
lbyte = !DO_UTF8(left);
sv_setpvn(TARG, lpv, llen);
if (!lbyte)
else
SvUTF8_off(TARG);
}
- else { /* TARG == left */
- STRLEN llen;
- SvGETMAGIC(left); /* or mg_get(left) may happen here */
+ else { /* $l .= $r */
if (!SvOK(TARG)) {
- if (left == right && ckWARN(WARN_UNINITIALIZED))
+ if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
report_uninit(right);
sv_setpvs(left, "");
}
- (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
- lbyte = !DO_UTF8(left);
+ lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
+ ? !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
if (IN_BYTES)
SvUTF8_off(TARG);
}
- /* or mg_get(right) may happen here */
if (!rcopied) {
- rpv = SvPV_const(right, rlen);
+ if (left == right)
+ /* $r.$r: do magic twice: tied might return different 2nd time */
+ SvGETMAGIC(right);
+ rpv = SvPV_nomg_const(right, rlen);
rbyte = !DO_UTF8(right);
}
if (lbyte != rbyte) {
+ /* sv_utf8_upgrade_nomg() may reallocate the stack */
+ PUTBACK;
if (lbyte)
sv_utf8_upgrade_nomg(TARG);
else {
if (!rcopied)
right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
sv_utf8_upgrade_nomg(right);
- rpv = SvPV_const(right, rlen);
+ rpv = SvPV_nomg_const(right, rlen);
}
+ SPAGAIN;
}
sv_catpvn_nomg(TARG, rpv, rlen);
PP(pp_readline)
{
dVAR;
- tryAMAGICunTARGET(iter, 0);
+ dSP; SvGETMAGIC(TOPs);
+ tryAMAGICunTARGET(iter_amg, 0, 0);
PL_last_in_gv = MUTABLE_GV(*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)))
dSP;
XPUSHs(MUTABLE_SV(PL_last_in_gv));
PUTBACK;
- pp_rv2gv();
+ Perl_pp_rv2gv(aTHX);
PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
}
}
PP(pp_eq)
{
- dVAR; dSP; tryAMAGICbinSET(eq,0);
+ dVAR; dSP;
+ tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
#ifndef NV_PRESERVES_UV
if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
SP--;
}
#endif
#ifdef PERL_PRESERVE_IVUV
- SvIV_please(TOPs);
+ SvIV_please_nomg(TOPs);
if (SvIOK(TOPs)) {
/* Unless the left argument is integer in range we are going
to have to use NV maths. Hence only attempt to coerce the
right argument if we know the left is integer. */
- SvIV_please(TOPm1s);
+ SvIV_please_nomg(TOPm1s);
if (SvIOK(TOPm1s)) {
const bool auvok = SvUOK(TOPm1s);
const bool buvok = SvUOK(TOPs);
#endif
{
#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- dPOPTOPnnrl;
+ dPOPTOPnnrl_nomg;
if (Perl_isnan(left) || Perl_isnan(right))
RETSETNO;
SETs(boolSV(left == right));
#else
- dPOPnv;
- SETs(boolSV(TOPn == value));
+ dPOPnv_nomg;
+ SETs(boolSV(SvNV_nomg(TOPs) == value));
#endif
RETURN;
}
{
dVAR; dSP;
if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
- DIE(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MAX)
{
PP(pp_or)
{
dVAR; dSP;
+ PERL_ASYNC_CHECK();
if (SvTRUE(TOPs))
RETURN;
else {
const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
if (is_dor) {
+ PERL_ASYNC_CHECK();
sv = TOPs;
if (!sv || !SvANY(sv)) {
if (op_type == OP_DOR)
PP(pp_add)
{
dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
- tryAMAGICbin(add,opASSIGN);
- svl = sv_2num(TOPm1s);
- svr = sv_2num(TOPs);
+ tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
+ svr = TOPs;
+ svl = TOPm1s;
+
useleft = USE_LEFT(svl);
#ifdef PERL_PRESERVE_IVUV
/* We must see if we can perform the addition with integers if possible,
unsigned code below is actually shorter than the old code. :-)
*/
- SvIV_please(svr);
+ SvIV_please_nomg(svr);
+
if (SvIOK(svr)) {
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
lots of code to speed up what is probably a rarish case. */
} else {
/* Left operand is defined, so is it IV? */
- SvIV_please(svl);
+ SvIV_please_nomg(svl);
if (SvIOK(svl)) {
if ((auvok = SvUOK(svl)))
auv = SvUVX(svl);
}
#endif
{
- NV value = SvNV(svr);
+ NV value = SvNV_nomg(svr);
(void)POPs;
if (!useleft) {
/* left operand is undef, treat as zero. + 0.0 is identity. */
SETn(value);
RETURN;
}
- SETn( value + SvNV(svl) );
+ SETn( value + SvNV_nomg(svl) );
RETURN;
}
}
{
dVAR; dSP;
AV * const av = PL_op->op_flags & OPf_SPECIAL
- ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAV(cGVOP_gv);
+ ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
const U32 lval = PL_op->op_flags & OPf_MOD;
SV** const svp = av_fetch(av, PL_op->op_private, lval);
SV *sv = (svp ? *svp : &PL_sv_undef);
EXTEND(SP, 1);
- if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
- sv = sv_mortalcopy(sv);
+ if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
+ mg_get(sv);
PUSHs(sv);
RETURN;
}
PP(pp_print)
{
dVAR; dSP; dMARK; dORIGMARK;
- IO *io;
register PerlIO *fp;
MAGIC *mg;
GV * const gv
= (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
+ IO *io = GvIO(gv);
- if (gv && (io = GvIO(gv))
+ if (io
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
{
had_magic:
Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
++SP;
}
- PUSHMARK(MARK - 1);
- *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
- PUTBACK;
- ENTER;
- if( PL_op->op_type == OP_SAY ) {
- /* local $\ = "\n" */
- SAVEGENERICSV(PL_ors_sv);
- PL_ors_sv = newSVpvs("\n");
- }
- call_method("PRINT", G_SCALAR);
- LEAVE;
- SPAGAIN;
- MARK = ORIGMARK + 1;
- *MARK = *SP;
- SP = MARK;
- RETURN;
+ return Perl_tied_method(aTHX_ "PRINT", mark - 1, MUTABLE_SV(io),
+ mg,
+ (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK
+ | (PL_op->op_type == OP_SAY
+ ? TIED_METHOD_SAY : 0)), sp - mark);
}
- if (!(io = GvIO(gv))) {
- if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
+ if (!io) {
+ if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv)))
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
goto had_magic;
- if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
+ report_evil_fh(gv);
SETERRNO(EBADF,RMS_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
- if (ckWARN2(WARN_CLOSED, WARN_IO)) {
- if (IoIFP(io))
- report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
- else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
- report_evil_fh(gv, io, PL_op->op_type);
- }
+ if (IoIFP(io))
+ report_wrongway_fh(gv, '<');
+ else
+ report_evil_fh(gv);
SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
goto just_say_no;
}
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);
if (SvROK(sv)) {
- wasref:
- tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
-
+ if (SvAMAGIC(sv)) {
+ sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
+ SPAGAIN;
+ }
sv = SvRV(sv);
if (SvTYPE(sv) != type)
DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
GV *gv;
if (!isGV_with_GP(sv)) {
- if (SvGMAGICAL(sv)) {
- mg_get(sv);
- if (SvROK(sv))
- goto wasref;
- }
gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
type, &sp);
if (!gv)
if (is_pp_rv2av) {
AV *const av = MUTABLE_AV(sv);
- /* The guts of pp_rv2av, with no intenting change to preserve history
+ /* The guts of pp_rv2av, with no intending change to preserve history
(until such time as we get tools that can do blame annotation across
whitespace changes. */
- if (gimme == G_ARRAY) {
- const I32 maxarg = AvFILL(av) + 1;
- (void)POPs; /* XXXX May be optimized away? */
- EXTEND(SP, maxarg);
- if (SvRMAGICAL(av)) {
- U32 i;
- for (i=0; i < (U32)maxarg; i++) {
- SV ** const svp = av_fetch(av, i, FALSE);
- /* See note in pp_helem, and bug id #27839 */
- SP[i+1] = svp
- ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
- : &PL_sv_undef;
+ if (gimme == G_ARRAY) {
+ const I32 maxarg = AvFILL(av) + 1;
+ (void)POPs; /* XXXX May be optimized away? */
+ EXTEND(SP, maxarg);
+ if (SvRMAGICAL(av)) {
+ U32 i;
+ for (i=0; i < (U32)maxarg; i++) {
+ SV ** const svp = av_fetch(av, i, FALSE);
+ /* See note in pp_helem, and bug id #27839 */
+ SP[i+1] = svp
+ ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
+ : &PL_sv_undef;
+ }
}
+ else {
+ Copy(AvARRAY(av), SP+1, maxarg, SV*);
+ }
+ SP += maxarg;
}
- else {
- Copy(AvARRAY(av), SP+1, maxarg, SV*);
+ else if (gimme == G_SCALAR) {
+ dTARGET;
+ const I32 maxarg = AvFILL(av) + 1;
+ SETi(maxarg);
}
- SP += maxarg;
- }
- else if (gimme == G_SCALAR) {
- dTARGET;
- const I32 maxarg = AvFILL(av) + 1;
- SETi(maxarg);
- }
} else {
/* The guts of pp_rv2hv */
- if (gimme == G_ARRAY) { /* array wanted */
- *PL_stack_sp = sv;
- return do_kv();
- }
- else if (gimme == G_SCALAR) {
- dTARGET;
- TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
- SPAGAIN;
- SETTARG;
- }
+ if (gimme == G_ARRAY) { /* array wanted */
+ *PL_stack_sp = sv;
+ return Perl_do_kv(aTHX);
+ }
+ else if (gimme == G_SCALAR) {
+ dTARGET;
+ TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
+ SPAGAIN;
+ SETTARG;
+ }
}
RETURN;
/* If there's a common identifier on both sides we have to take
* special care that assigning the identifier on the left doesn't
* clobber a value on the right that's used later in the list.
+ * Don't bother if LHS is just an empty hash or array.
*/
- if (PL_op->op_private & (OPpASSIGN_COMMON)) {
+
+ if ( (PL_op->op_private & OPpASSIGN_COMMON)
+ && (
+ firstlelem != lastlelem
+ || ! ((sv = *firstlelem))
+ || SvMAGICAL(sv)
+ || ! (SvTYPE(sv) == SVt_PVAV || SvTYPE(sv) == SVt_PVHV)
+ || (SvTYPE(sv) == SVt_PVAV && AvFILL((AV*)sv) != -1)
+ || (SvTYPE(sv) == SVt_PVHV && HvKEYS((HV*)sv) != 0)
+ )
+ ) {
EXTEND_MORTAL(lastrelem - firstrelem + 1);
for (relem = firstrelem; relem <= lastrelem; relem++) {
if ((sv = *relem)) {
TAINT_NOT; /* Each item is independent */
- *relem = sv_mortalcopy(sv);
+
+ /* Dear TODO test in t/op/sort.t, I love you.
+ (It's relying on a panic, not a "semi-panic" from newSVsv()
+ and then an assertion failure below.) */
+ if (SvIS_FREED(sv)) {
+ Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
+ (void*)sv);
+ }
+ /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
+ and we need a second copy of a temp here. */
+ *relem = sv_2mortal(newSVsv(sv));
}
}
}
while (relem <= lastrelem) { /* gobble up all the rest */
SV **didstore;
assert(*relem);
- sv = newSVsv(*relem);
+ sv = newSV(0);
+ sv_setsv(sv, *relem);
*(relem++) = sv;
didstore = av_store(ary,i++,sv);
if (magic) {
- if (SvSMAGICAL(sv)) {
- /* More magic can happen in the mg_set callback, so we
- * backup the delaymagic for now. */
- U16 dmbak = PL_delaymagic;
- PL_delaymagic = 0;
+ if (SvSMAGICAL(sv))
mg_set(sv);
- PL_delaymagic = dmbak;
- }
if (!didstore)
sv_2mortal(sv);
}
TAINT_NOT;
}
- if (PL_delaymagic & DM_ARRAY)
+ if (PL_delaymagic & DM_ARRAY_ISA)
SvSETMAGIC(MUTABLE_SV(ary));
break;
case SVt_PVHV: { /* normal hash */
SV *tmpstr;
+ SV** topelem = relem;
hash = MUTABLE_HV(sv);
magic = SvMAGICAL(hash) != 0;
tmpstr = newSV(0);
if (*relem)
sv_setsv(tmpstr,*relem); /* value */
- *(relem++) = tmpstr;
- if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
- /* key overwrites an existing entry */
- duplicates += 2;
+ relem++;
+ if (gimme != G_VOID) {
+ if (hv_exists_ent(hash, sv, 0))
+ /* key overwrites an existing entry */
+ duplicates += 2;
+ else
+ if (gimme == G_ARRAY) {
+ /* copy element back: possibly to an earlier
+ * stack location if we encountered dups earlier */
+ *topelem++ = sv;
+ *topelem++ = tmpstr;
+ }
+ }
didstore = hv_store_ent(hash,sv,tmpstr,0);
if (magic) {
- if (SvSMAGICAL(tmpstr)) {
- U16 dmbak = PL_delaymagic;
- PL_delaymagic = 0;
+ if (SvSMAGICAL(tmpstr))
mg_set(tmpstr);
- PL_delaymagic = dmbak;
- }
if (!didstore)
sv_2mortal(tmpstr);
}
}
else
sv_setsv(sv, &PL_sv_undef);
-
- if (SvSMAGICAL(sv)) {
- U16 dmbak = PL_delaymagic;
- PL_delaymagic = 0;
- mg_set(sv);
- PL_delaymagic = dmbak;
- }
+ SvSETMAGIC(sv);
break;
}
}
SP = lastrelem;
else if (hash) {
if (duplicates) {
- /* Removes from the stack the entries which ended up as
- * duplicated keys in the hash (fix for [perl #24380]) */
- Move(firsthashrelem + duplicates,
- firsthashrelem, duplicates, SV**);
+ /* at this point we have removed the duplicate key/value
+ * pairs from the stack, but the remaining values may be
+ * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
+ * the (a 2), but the stack now probably contains
+ * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
+ * obliterates the earlier key. So refresh all values. */
lastrelem -= duplicates;
+ relem = firsthashrelem;
+ while (relem < lastrelem) {
+ HE *he;
+ sv = *relem++;
+ he = hv_fetch_ent(hash, sv, 0, 0);
+ *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
+ }
}
SP = lastrelem;
}
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) {
- HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
+ HV *const stash = gv_stashsv(pkg, GV_ADD);
SvREFCNT_dec(pkg);
(void)sv_bless(rv, stash);
}
- if (RX_EXTFLAGS(rx) & RXf_TAINTED)
+ if (RX_EXTFLAGS(rx) & RXf_TAINTED) {
SvTAINTED_on(rv);
+ SvTAINTED_on(SvRV(rv));
+ }
XPUSHs(rv);
RETURN;
}
}
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;
/g matches against large strings. So far a solution to this problem
appears to be quite tricky.
Test for the unsafe vars are TODO for now. */
- if (( !global && RX_NPARENS(rx))
- || SvTEMP(TARG) || PL_sawampersand ||
- (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
+ if ( (!global && RX_NPARENS(rx))
+ || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
+ || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
r_flags |= REXEC_COPY_STR;
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
-play_it_again:
+ play_it_again:
if (global && RX_OFFS(rx)[0].start != -1) {
t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
if ((s + RX_MINLEN(rx)) > strend || s < truebase)
const I32 gimme = GIMME_V;
if (io) {
- MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
+ const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
if (mg) {
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
- PUTBACK;
- ENTER;
- call_method("READLINE", gimme);
- LEAVE;
- SPAGAIN;
+ Perl_tied_method(aTHX_ "READLINE", SP, MUTABLE_SV(io), mg, gimme, 0);
if (gimme == G_SCALAR) {
- SV* const result = POPs;
- SvSetSV_nosteal(TARG, result);
- PUSHTARG;
+ SPAGAIN;
+ SvSetSV_nosteal(TARG, TOPs);
+ SETTARG;
}
- RETURN;
+ return NORMAL;
}
}
fp = NULL;
}
else if (type == OP_GLOB)
SP--;
- else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
- report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
+ else if (IoTYPE(io) == IoTYPE_WRONLY) {
+ report_wrongway_fh(PL_last_in_gv, '>');
}
}
if (!fp) {
"glob failed (can't start child: %s)",
Strerror(errno));
else
- report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
+ report_evil_fh(PL_last_in_gv);
}
if (gimme == G_SCALAR) {
/* undef TARG, and push that undefined value */
}
SvUPGRADE(sv, SVt_PV);
tmplen = SvLEN(sv); /* remember if already alloced */
- if (!tmplen && !SvREADONLY(sv))
- Sv_Grow(sv, 80); /* try short-buffering it */
+ if (!tmplen && !SvREADONLY(sv)) {
+ /* try short-buffering it. Please update t/op/readline.t
+ * if you change the growth length.
+ */
+ Sv_Grow(sv, 80);
+ }
offset = 0;
if (type == OP_RCATLINE && SvOK(sv)) {
if (!SvPOK(sv)) {
(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);
}
sv = (svp ? *svp : &PL_sv_undef);
- /* This makes C<local $tied{foo} = $tied{foo}> possible.
- * Pushing the magical RHS on to the stack is useless, since
- * that magic is soon destined to be misled by the local(),
- * and thus the later pp_sassign() will fail to mg_get() the
- * old value. This should also cure problems with delayed
- * mg_get()s. GSAR 98-07-03 */
- if (!lval && SvGMAGICAL(sv))
- sv = sv_mortalcopy(sv);
+ /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
+ * was to make C<local $tied{foo} = $tied{foo}> possible.
+ * However, it seems no longer to be needed for that purpose, and
+ * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
+ * would loop endlessly since the pos magic is getting set on the
+ * mortal copy and lost. However, the copy has the effect of
+ * triggering the get magic, and losing it altogether made things like
+ * c<$tied{foo};> in void context no longer do get magic, which some
+ * code relied on. Also, delayed triggering of magic on @+ and friends
+ * meant the original regex may be out of scope by now. So as a
+ * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
+ * being called too many times). */
+ if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
+ mg_get(sv);
PUSHs(sv);
RETURN;
}
}
PL_curpm = newpm; /* Don't pop $1 et al till now */
- LEAVE;
+ LEAVE_with_name("block");
RETURN;
}
RETPUSHYES;
}
+/*
+A description of how taint works in pattern matching and substitution.
+
+While the pattern is being assembled/concatenated and them compiled,
+PL_tainted will get set if any component of the pattern is tainted, e.g.
+/.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag
+is set on the pattern if PL_tainted is set.
+
+When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
+the pattern is marked as tainted. This means that subsequent usage, such
+as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too.
+
+During execution of a pattern, locale-variant ops such as ALNUML set the
+local flag RF_tainted. At the end of execution, the engine sets the
+RXf_TAINTED_SEEN on the pattern if RF_tainted got set, or clears it
+otherwise.
+
+In addition, RXf_TAINTED_SEEN is used post-execution by the get magic code
+of $1 et al to indicate whether the returned value should be tainted.
+It is the responsibility of the caller of the pattern (i.e. pp_match,
+pp_subst etc) to set this flag for any other circumstances where $1 needs
+to be tainted.
+
+The taint behaviour of pp_subst (and pp_substcont) is quite complex.
+
+There are three possible sources of taint
+ * the source string
+ * the pattern (both compile- and run-time, RXf_TAINTED / RXf_TAINTED_SEEN)
+ * the replacement string (or expression under /e)
+
+There are four destinations of taint and they are affected by the sources
+according to the rules below:
+
+ * the return value (not including /r):
+ tainted by the source string and pattern, but only for the
+ number-of-iterations case; boolean returns aren't tainted;
+ * the modified string (or modified copy under /r):
+ tainted by the source string, pattern, and replacement strings;
+ * $1 et al:
+ tainted by the pattern, and under 'use re "taint"', by the source
+ string too;
+ * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted:
+ should always be unset before executing subsequent code.
+
+The overall action of pp_subst is:
+
+ * at the start, set bits in rxtainted indicating the taint status of
+ the various sources.
+
+ * After each pattern execution, update the SUBST_TAINT_PAT bit in
+ rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the
+ pattern has subsequently become tainted via locale ops.
+
+ * If control is being passed to pp_substcont to execute a /e block,
+ save rxtainted in the CXt_SUBST block, for future use by
+ pp_substcont.
+
+ * Whenever control is being returned to perl code (either by falling
+ off the "end" of pp_subst/pp_substcont, or by entering a /e block),
+ use the flag bits in rxtainted to make all the appropriate types of
+ destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1
+ et al will appear tainted.
+
+pp_match is just a simpler version of the above.
+
+*/
+
PP(pp_subst)
{
dVAR; dSP; dTARG;
I32 maxiters;
register I32 i;
bool once;
- U8 rxtainted;
+ U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
+ See "how taint works" above */
char *orig;
U8 r_flags;
register REGEXP *rx = PM_GETRE(pm);
const I32 oldsave = PL_savestack_ix;
STRLEN slen;
bool doutf8 = FALSE;
- I32 matched;
#ifdef PERL_OLD_COPY_ON_WRITE
bool is_cow;
#endif
SV *nsv = NULL;
-
/* known replacement string? */
register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
+
+ PERL_ASYNC_CHECK();
+
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
else if (PL_op->op_private & OPpTARGET_MY)
EXTEND(SP,1);
}
+ /* In non-destructive replacement mode, duplicate target scalar so it
+ * remains unchanged. */
+ if (rpm->op_pmflags & PMf_NONDESTRUCT)
+ TARG = sv_2mortal(newSVsv(TARG));
+
#ifdef PERL_OLD_COPY_ON_WRITE
/* Awooga. Awooga. "bool" types that are actually char are dangerous,
because they make integers such as 256 "false". */
|| ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
|| SvTYPE(TARG) > SVt_PVLV)
&& !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
- DIE(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
PUTBACK;
+ setup_match:
s = SvPV_mutable(TARG, len);
if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
force_on_match = 1;
- rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
- (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
- if (PL_tainted)
- rxtainted |= 2;
- TAINT_NOT;
+
+ /* only replace once? */
+ once = !(rpm->op_pmflags & PMf_GLOBAL);
+
+ /* See "how taint works" above */
+ if (PL_tainting) {
+ rxtainted = (
+ (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0)
+ | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0)
+ | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0)
+ | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT))
+ ? SUBST_TAINT_BOOLRET : 0));
+ TAINT_NOT;
+ }
RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
if (!s)
- goto nope;
+ goto ret_no;
/* How to do it in subst? */
/* if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
&& !PL_sawampersand
*/
}
- /* only replace once? */
- once = !(rpm->op_pmflags & PMf_GLOBAL);
- matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
- r_flags | REXEC_CHECKED);
+ if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
+ r_flags | REXEC_CHECKED))
+ {
+ ret_no:
+ SPAGAIN;
+ PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
+ LEAVE_SCOPE(oldsave);
+ RETURN;
+ }
+
/* known replacement string? */
if (dstr) {
+ if (SvTAINTED(dstr))
+ rxtainted |= SUBST_TAINT_REPL;
+
+ /* Upgrade the source if the replacement is utf8 but the source is not,
+ * but only if it matched; see
+ * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
+ */
+ if (DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
+ char * const orig_pvx = SvPVX(TARG);
+ const STRLEN new_len = sv_utf8_upgrade_nomg(TARG);
+
+ /* If the lengths are the same, the pattern contains only
+ * invariants, can keep going; otherwise, various internal markers
+ * could be off, so redo */
+ if (new_len != len || orig_pvx != SvPVX(TARG)) {
+ goto setup_match;
+ }
+ }
+
/* replacement needing upgrading? */
if (DO_UTF8(TARG) && !doutf8) {
nsv = sv_newmortal();
#endif
&& (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
&& !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
- && (!doutf8 || SvUTF8(TARG))) {
- if (!matched)
- {
- SPAGAIN;
- PUSHs(&PL_sv_no);
- LEAVE_SCOPE(oldsave);
- RETURN;
- }
+ && (!doutf8 || SvUTF8(TARG)))
+ {
+
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(TARG)) {
assert (!force_on_match);
PL_curpm = pm;
SvSCREAM_off(TARG); /* disable possible screamer */
if (once) {
- rxtainted |= RX_MATCH_TAINTED(rx);
+ if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
+ rxtainted |= SUBST_TAINT_PAT;
m = orig + RX_OFFS(rx)[0].start;
d = orig + RX_OFFS(rx)[0].end;
s = orig;
else {
sv_chop(TARG, d);
}
- TAINT_IF(rxtainted & 1);
SPAGAIN;
- PUSHs(&PL_sv_yes);
+ PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_yes);
}
else {
do {
if (iters++ > maxiters)
DIE(aTHX_ "Substitution loop");
- rxtainted |= RX_MATCH_TAINTED(rx);
+ if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
+ rxtainted |= SUBST_TAINT_PAT;
m = RX_OFFS(rx)[0].start + orig;
if ((i = m - s)) {
if (s != d)
SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
Move(s, d, i+1, char); /* include the NUL */
}
- TAINT_IF(rxtainted & 1);
- SPAGAIN;
- mPUSHi((I32)iters);
- }
- (void)SvPOK_only_UTF8(TARG);
- TAINT_IF(rxtainted);
- if (SvSMAGICAL(TARG)) {
- PUTBACK;
- mg_set(TARG);
SPAGAIN;
+ if (rpm->op_pmflags & PMf_NONDESTRUCT)
+ PUSHs(TARG);
+ else
+ mPUSHi((I32)iters);
}
- SvTAINT(TARG);
- if (doutf8)
- SvUTF8_on(TARG);
- LEAVE_SCOPE(oldsave);
- RETURN;
}
-
- if (matched)
- {
+ else {
if (force_on_match) {
force_on_match = 0;
s = SvPV_force(TARG, len);
#ifdef PERL_OLD_COPY_ON_WRITE
have_a_cow:
#endif
- rxtainted |= RX_MATCH_TAINTED(rx);
+ if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
+ rxtainted |= SUBST_TAINT_PAT;
dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
SAVEFREESV(dstr);
PL_curpm = pm;
if (!c) {
register PERL_CONTEXT *cx;
SPAGAIN;
+ /* note that a whole bunch of local vars are saved here for
+ * use by pp_substcont: here's a list of them in case you're
+ * searching for places in this sub that uses a particular var:
+ * iters maxiters r_flags oldsave rxtainted orig dstr targ
+ * s m strend rx once */
PUSHSUBST(cx);
RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
}
do {
if (iters++ > maxiters)
DIE(aTHX_ "Substitution loop");
- rxtainted |= RX_MATCH_TAINTED(rx);
+ if (RX_MATCH_TAINTED(rx))
+ rxtainted |= SUBST_TAINT_PAT;
if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
m = s;
s = orig;
doutf8 |= DO_UTF8(dstr);
SvPV_set(dstr, NULL);
- TAINT_IF(rxtainted & 1);
SPAGAIN;
- mPUSHi((I32)iters);
+ if (rpm->op_pmflags & PMf_NONDESTRUCT)
+ PUSHs(TARG);
+ else
+ mPUSHi((I32)iters);
+ }
+ (void)SvPOK_only_UTF8(TARG);
+ if (doutf8)
+ SvUTF8_on(TARG);
+
+ /* See "how taint works" above */
+ if (PL_tainting) {
+ if ((rxtainted & SUBST_TAINT_PAT) ||
+ ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) ==
+ (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
+ )
+ (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
+
+ if (!(rxtainted & SUBST_TAINT_BOOLRET)
+ && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
+ )
+ SvTAINTED_on(TOPs); /* taint return value */
+ else
+ SvTAINTED_off(TOPs); /* may have got tainted earlier */
- (void)SvPOK_only(TARG);
- if (doutf8)
- SvUTF8_on(TARG);
- TAINT_IF(rxtainted);
- SvSETMAGIC(TARG);
+ /* needed for mg_set below */
+ PL_tainted =
+ cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
SvTAINT(TARG);
- LEAVE_SCOPE(oldsave);
- RETURN;
}
- goto ret_no;
-
-nope:
-ret_no:
- SPAGAIN;
- PUSHs(&PL_sv_no);
+ SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */
+ TAINT_NOT;
LEAVE_SCOPE(oldsave);
RETURN;
}
if (SvTRUEx(POPs))
PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
++*PL_markstack_ptr;
- LEAVE; /* exit inner scope */
+ FREETMPS;
+ 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 (gimme == G_SCALAR)
goto temporise;
if (gimme == G_ARRAY) {
+ mark = newsp + 1;
+ /* We want an array here, but padav will have left us an arrayref for an lvalue,
+ * so we need to expand it */
+ if(SvTYPE(*mark) == SVt_PVAV) {
+ AV *const av = MUTABLE_AV(*mark);
+ const I32 maxarg = AvFILL(av) + 1;
+ (void)POPs; /* get rid of the array ref */
+ EXTEND(SP, maxarg);
+ if (SvRMAGICAL(av)) {
+ U32 i;
+ for (i=0; i < (U32)maxarg; i++) {
+ SV ** const svp = av_fetch(av, i, FALSE);
+ SP[i+1] = svp
+ ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
+ : &PL_sv_undef;
+ }
+ }
+ else {
+ Copy(AvARRAY(av), SP+1, maxarg, SV*);
+ }
+ SP += maxarg;
+ PUTBACK;
+ }
if (!CvLVALUE(cx->blk_sub.cv))
goto temporise_array;
EXTEND_MORTAL(SP - newsp);
MARK = newsp + 1;
EXTEND_MORTAL(1);
if (MARK == SP) {
- /* Temporaries are bad unless they happen to be elements
- * of a tied hash or array */
- if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
- !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
+ /* Temporaries are bad unless they happen to have set magic
+ * attached, such as the elements of a tied hash or array */
+ if ((SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP) ||
+ (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
+ == SVf_READONLY
+ ) &&
+ !SvSMAGICAL(TOPs)) {
LEAVE;
cxstack_ix--;
POPSUB(cx,sv);
case SVt_PVGV:
if (!isGV_with_GP(sv))
DIE(aTHX_ "Not a CODE reference");
+ we_have_a_glob:
if (!(cv = GvCVu((const GV *)sv))) {
HV *stash;
cv = sv_2cv(sv, &stash, &gv, 0);
goto try_autoload;
}
break;
+ case SVt_PVLV:
+ if(isGV_with_GP(sv)) goto we_have_a_glob;
+ /*FALLTHROUGH*/
default:
- if (!SvROK(sv)) {
+ if (sv == &PL_sv_yes) { /* unfound import, ignore */
+ if (hasargs)
+ SP = PL_stack_base + POPMARK;
+ else
+ (void)POPMARK;
+ RETURN;
+ }
+ SvGETMAGIC(sv);
+ if (SvROK(sv)) {
+ if (SvAMAGIC(sv)) {
+ sv = amagic_deref_call(sv, to_cv_amg);
+ /* Don't SPAGAIN here. */
+ }
+ }
+ else {
const char *sym;
STRLEN len;
- if (sv == &PL_sv_yes) { /* unfound import, ignore */
- if (hasargs)
- SP = PL_stack_base + POPMARK;
- RETURN;
- }
- if (SvGMAGICAL(sv)) {
- mg_get(sv);
- if (SvROK(sv))
- goto got_rv;
- if (SvPOKp(sv)) {
- sym = SvPVX_const(sv);
- len = SvCUR(sv);
- } else {
- sym = NULL;
- len = 0;
- }
- }
- else {
- sym = SvPV_const(sv, len);
- }
+ sym = SvPV_nomg_const(sv, len);
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;
}
- got_rv:
- {
- SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
- tryAMAGICunDEREF(to_cv);
- }
cv = MUTABLE_CV(SvRV(sv));
if (SvTYPE(cv) == SVt_PVCV)
break;
SAVETMPS;
retry:
+ if (CvCLONE(cv) && ! CvCLONED(cv))
+ DIE(aTHX_ "Closure prototype called");
if (!CvROOT(cv) && !CvXSUB(cv)) {
GV* autogv;
SV* sub_name;
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));
+ CvXSUB(cv)(aTHX_ cv);
/* Enforce some sanity in scalar context. */
if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
AV *const av = MUTABLE_AV(POPs);
const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
+ const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
+ bool preeminent = TRUE;
SV *sv;
if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
elem -= CopARYBASE_get(PL_curcop);
if (SvTYPE(av) != SVt_PVAV)
RETPUSHUNDEF;
+
+ if (localizing) {
+ MAGIC *mg;
+ HV *stash;
+
+ /* If we can determine whether the element exist,
+ * Try to preserve the existenceness of a tied array
+ * element by using EXISTS and DELETE if possible.
+ * Fallback to FETCH and STORE otherwise. */
+ if (SvCANEXISTDELETE(av))
+ preeminent = av_exists(av, elem);
+ }
+
svp = av_fetch(av, elem, lval && !defer);
if (lval) {
#ifdef PERL_MALLOC_WRAP
PUSHs(lv);
RETURN;
}
- if (PL_op->op_private & OPpLVAL_INTRO)
- save_aelem(av, elem, svp);
+ if (localizing) {
+ if (preeminent)
+ save_aelem(av, elem, svp);
+ else
+ SAVEADELETE(av, elem);
+ }
else if (PL_op->op_private & OPpDEREF)
vivify_ref(*svp, PL_op->op_private & OPpDEREF);
}
sv = (svp ? *svp : &PL_sv_undef);
- if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
- sv = sv_mortalcopy(sv);
+ if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
+ mg_get(sv);
PUSHs(sv);
RETURN;
}
SvGETMAGIC(sv);
if (!SvOK(sv)) {
if (SvREADONLY(sv))
- Perl_croak(aTHX_ "%s", PL_no_modify);
+ Perl_croak_no_modify(aTHX);
prepare_SV_for_RV(sv);
switch (to_what) {
case OPpDEREF_SV:
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);
https://perl5.git.perl.org / perl5.git / blobdiff