return NORMAL;
}
+/* This is sometimes called directly by pp_coreargs. */
PP(pp_pushmark)
{
dVAR;
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);
+ 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 (gv_type != SVt_PVGV) {
+ 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) {
}
}
+ if (
+ SvTEMP(right) && !SvSMAGICAL(right) && SvREFCNT(right) == 1 &&
+ (!isGV_with_GP(right) || SvFAKE(right)) && ckWARN(WARN_MISC)
+ )
+ Perl_warner(aTHX_
+ packWARN(WARN_MISC), "Useless assignment to a temporary"
+ );
SvSetMagicSV(right, left);
SETs(right);
RETURN;
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;
}
rcopied = TRUE;
}
- if (TARG != left) {
+ if (TARG != left) { /* not $l .= $r */
STRLEN llen;
const char* const lpv = SvPV_nomg_const(left, llen);
lbyte = !DO_UTF8(left);
else
SvUTF8_off(TARG);
}
- else { /* TARG == left */
+ 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, "");
}
if (!rcopied) {
if (left == right)
- /* $a.$a: do magic twice: tied might return different 2nd time */
+ /* $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 {
sv_utf8_upgrade_nomg(right);
rpv = SvPV_nomg_const(right, rlen);
}
+ SPAGAIN;
}
sv_catpvn_nomg(TARG, rpv, rlen);
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;
- tryAMAGICunTARGET(iter, 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));
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;
- tryAMAGICbin_MG(eq_amg, AMGf_set);
-#ifndef NV_PRESERVES_UV
- if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
- SP--;
- SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
- RETURN;
- }
-#endif
-#ifdef PERL_PRESERVE_IVUV
- 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_nomg(TOPm1s);
- if (SvIOK(TOPm1s)) {
- const bool auvok = SvUOK(TOPm1s);
- const bool buvok = SvUOK(TOPs);
-
- if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
- /* Casting IV to UV before comparison isn't going to matter
- on 2s complement. On 1s complement or sign&magnitude
- (if we have any of them) it could to make negative zero
- differ from normal zero. As I understand it. (Need to
- check - is negative zero implementation defined behaviour
- anyway?). NWC */
- const UV buv = SvUVX(POPs);
- const UV auv = SvUVX(TOPs);
-
- SETs(boolSV(auv == buv));
- RETURN;
- }
- { /* ## Mixed IV,UV ## */
- SV *ivp, *uvp;
- IV iv;
-
- /* == is commutative so doesn't matter which is left or right */
- if (auvok) {
- /* top of stack (b) is the iv */
- ivp = *SP;
- uvp = *--SP;
- } else {
- uvp = *SP;
- ivp = *--SP;
- }
- iv = SvIVX(ivp);
- if (iv < 0)
- /* As uv is a UV, it's >0, so it cannot be == */
- SETs(&PL_sv_no);
- else
- /* we know iv is >= 0 */
- SETs(boolSV((UV)iv == SvUVX(uvp)));
- RETURN;
- }
- }
- }
-#endif
- {
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
- dPOPTOPnnrl_nomg;
- if (Perl_isnan(left) || Perl_isnan(right))
- RETSETNO;
- SETs(boolSV(left == right));
-#else
- dPOPnv_nomg;
- SETs(boolSV(SvNV_nomg(TOPs) == value));
-#endif
- RETURN;
- }
+ SV *left, *right;
+
+ tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
+ right = POPs;
+ left = TOPs;
+ SETs(boolSV(
+ (SvIOK_notUV(left) && SvIOK_notUV(right))
+ ? (SvIVX(left) == SvIVX(right))
+ : ( do_ncmp(left, right) == 0)
+ ));
+ RETURN;
}
PP(pp_preinc)
{
dVAR; dSP;
- if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
+ const bool inc =
+ PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
+ if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
Perl_croak_no_modify(aTHX);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
- && SvIVX(TOPs) != IV_MAX)
+ && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
{
- SvIV_set(TOPs, SvIVX(TOPs) + 1);
+ SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
- sv_inc(TOPs);
+ if (inc) sv_inc(TOPs);
+ else sv_dec(TOPs);
SvSETMAGIC(TOPs);
return NORMAL;
}
PP(pp_aelemfast)
{
dVAR; dSP;
- AV * const av = PL_op->op_flags & OPf_SPECIAL
- ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAV(cGVOP_gv);
+ AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
+ ? 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);
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_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_with_name("call_PRINT");
- 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 ((GvEGVx(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);
+ SvGETMAGIC(sv);
if (SvROK(sv)) {
- 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);
SETs(sv);
RETURN;
}
- else if (LVRET) {
+ else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ const I32 flags = is_lvalue_sub();
+ if (flags && !(flags & OPpENTERSUB_INARGS)) {
if (gimme != G_ARRAY)
goto croak_cant_return;
SETs(sv);
RETURN;
+ }
}
else if (PL_op->op_flags & OPf_MOD
&& PL_op->op_private & OPpLVAL_INTRO)
SETs(sv);
RETURN;
}
- else if (LVRET) {
+ else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ const I32 flags = is_lvalue_sub();
+ if (flags && !(flags & OPpENTERSUB_INARGS)) {
if (gimme != G_ARRAY)
goto croak_cant_return;
SETs(sv);
RETURN;
+ }
}
}
}
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) ? (mg_get(*svp), *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 && HvUSEDKEYS((HV*)sv) != 0)
+ )
+ ) {
EXTEND_MORTAL(lastrelem - firstrelem + 1);
for (relem = firstrelem; relem <= lastrelem; relem++) {
if ((sv = *relem)) {
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))
break;
}
if (relem <= lastrelem) {
+ if (
+ SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
+ (!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
+ )
+ Perl_warner(aTHX_
+ packWARN(WARN_MISC),
+ "Useless assignment to a temporary"
+ );
sv_setsv(sv, *relem);
*(relem++) = sv;
}
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;
}
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;
}
/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)
&& !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
goto yup;
}
- if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
- minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
- {
- PL_curpm = pm;
- if (dynpm->op_pmflags & PMf_ONCE) {
+ if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
+ minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
+ goto ret_no;
+
+ PL_curpm = pm;
+ if (dynpm->op_pmflags & PMf_ONCE) {
#ifdef USE_ITHREADS
- SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
+ SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
#else
- dynpm->op_pmflags |= PMf_USED;
+ dynpm->op_pmflags |= PMf_USED;
#endif
- }
- goto gotcha;
}
- else
- goto ret_no;
- /*NOTREACHED*/
gotcha:
if (rxtainted)
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_with_name("call_READLINE");
- call_method("READLINE", gimme);
- LEAVE_with_name("call_READLINE");
- 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)) {
}
}
-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;
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
EXTEND(SP,1);
}
- /* In non-destructive replacement mode, duplicate target scalar so it
- * remains unchanged. */
- if (rpm->op_pmflags & PMf_NONDESTRUCT)
- TARG = 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". */
if (SvIsCOW(TARG))
sv_force_normal_flags(TARG,0);
#endif
- if (
+ if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
#ifdef PERL_OLD_COPY_ON_WRITE
- !is_cow &&
+ && !is_cow
#endif
- (SvREADONLY(TARG)
- || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
- || SvTYPE(TARG) > SVt_PVLV)
- && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
+ && (SvREADONLY(TARG)
+ || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
+ || SvTYPE(TARG) > SVt_PVLV)
+ && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
Perl_croak_no_modify(aTHX);
PUTBACK;
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 (matched && DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
- const STRLEN new_len = sv_utf8_upgrade(TARG);
+ 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) {
+ if (new_len != len || orig_pvx != SvPVX(TARG)) {
goto setup_match;
}
}
#endif
&& (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
&& !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
- && (!doutf8 || SvUTF8(TARG))) {
- if (!matched)
- {
- SPAGAIN;
- if (rpm->op_pmflags & PMf_NONDESTRUCT)
- PUSHs(TARG);
- else
- PUSHs(&PL_sv_no);
- LEAVE_SCOPE(oldsave);
- RETURN;
- }
+ && (!doutf8 || SvUTF8(TARG))
+ && !(rpm->op_pmflags & PMf_NONDESTRUCT))
+ {
+
#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;
- if (rpm->op_pmflags & PMf_NONDESTRUCT)
- PUSHs(TARG);
- else
- PUSHs(&PL_sv_yes);
+ PUSHs(&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;
- if (rpm->op_pmflags & PMf_NONDESTRUCT)
- PUSHs(TARG);
- else
- mPUSHi((I32)iters);
- }
- (void)SvPOK_only_UTF8(TARG);
- TAINT_IF(rxtainted);
- if (SvSMAGICAL(TARG)) {
- PUTBACK;
- mg_set(TARG);
SPAGAIN;
+ 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;
+ 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;
}
#ifdef PERL_OLD_COPY_ON_WRITE
have_a_cow:
#endif
- rxtainted |= RX_MATCH_TAINTED(rx);
- dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
- SAVEFREESV(dstr);
+ if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
+ rxtainted |= SUBST_TAINT_PAT;
+ dstr = newSVpvn_flags(m, s-m, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0));
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;
else
sv_catpvn(dstr, s, strend - s);
+ if (rpm->op_pmflags & PMf_NONDESTRUCT) {
+ /* From here on down we're using the copy, and leaving the original
+ untouched. */
+ TARG = dstr;
+ SPAGAIN;
+ PUSHs(dstr);
+ } else {
#ifdef PERL_OLD_COPY_ON_WRITE
- /* The match may make the string COW. If so, brilliant, because that's
- just saved us one malloc, copy and free - the regexp has donated
- the old buffer, and we malloc an entirely new one, rather than the
- regexp malloc()ing a buffer and copying our original, only for
- us to throw it away here during the substitution. */
- if (SvIsCOW(TARG)) {
- sv_force_normal_flags(TARG, SV_COW_DROP_PV);
- } else
+ /* The match may make the string COW. If so, brilliant, because
+ that's just saved us one malloc, copy and free - the regexp has
+ donated the old buffer, and we malloc an entirely new one, rather
+ than the regexp malloc()ing a buffer and copying our original,
+ only for us to throw it away here during the substitution. */
+ if (SvIsCOW(TARG)) {
+ sv_force_normal_flags(TARG, SV_COW_DROP_PV);
+ } else
#endif
- {
- SvPV_free(TARG);
- }
- SvPV_set(TARG, SvPVX(dstr));
- SvCUR_set(TARG, SvCUR(dstr));
- SvLEN_set(TARG, SvLEN(dstr));
- doutf8 |= DO_UTF8(dstr);
- SvPV_set(dstr, NULL);
+ {
+ SvPV_free(TARG);
+ }
+ SvPV_set(TARG, SvPVX(dstr));
+ SvCUR_set(TARG, SvCUR(dstr));
+ SvLEN_set(TARG, SvLEN(dstr));
+ doutf8 |= DO_UTF8(dstr);
+ SvPV_set(dstr, NULL);
- TAINT_IF(rxtainted & 1);
- SPAGAIN;
- if (rpm->op_pmflags & PMf_NONDESTRUCT)
- PUSHs(TARG);
- else
+ SPAGAIN;
mPUSHi((I32)iters);
+ }
+ }
- (void)SvPOK_only(TARG);
+ if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
+ (void)SvPOK_only_UTF8(TARG);
if (doutf8)
SvUTF8_on(TARG);
- TAINT_IF(rxtainted);
- SvSETMAGIC(TARG);
- SvTAINT(TARG);
- LEAVE_SCOPE(oldsave);
- RETURN;
}
- goto ret_no;
-nope:
-ret_no:
- SPAGAIN;
- if (rpm->op_pmflags & PMf_NONDESTRUCT)
- PUSHs(TARG);
- else
- PUSHs(&PL_sv_no);
+ /* 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 */
+
+ /* needed for mg_set below */
+ PL_tainted =
+ cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
+ SvTAINT(TARG);
+ }
+ 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;
+ FREETMPS;
LEAVE_with_name("grep_item"); /* exit inner scope */
/* All done yet? */
MARK = newsp + 1;
if (MARK <= SP) {
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
- if (SvTEMP(TOPs)) {
+ if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
*MARK = SvREFCNT_inc(TOPs);
FREETMPS;
sv_2mortal(*MARK);
SvREFCNT_dec(sv);
}
}
+ else if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
+ *MARK = TOPs;
+ }
else
- *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
+ *MARK = sv_mortalcopy(TOPs);
}
else {
MEXTEND(MARK, 0);
}
else if (gimme == G_ARRAY) {
for (MARK = newsp + 1; MARK <= SP; MARK++) {
- if (!SvTEMP(*MARK)) {
+ if (!SvTEMP(*MARK) || SvREFCNT(*MARK) != 1) {
*MARK = sv_mortalcopy(*MARK);
TAINT_NOT; /* Each item is independent */
}
return cx->blk_sub.retop;
}
-/* This duplicates the above code because the above code must not
- * get any slower by more conditions */
-PP(pp_leavesublv)
-{
- dVAR; dSP;
- SV **mark;
- SV **newsp;
- PMOP *newpm;
- I32 gimme;
- register PERL_CONTEXT *cx;
- SV *sv;
-
- if (CxMULTICALL(&cxstack[cxstack_ix]))
- return 0;
-
- POPBLOCK(cx,newpm);
- cxstack_ix++; /* temporarily protect top context */
-
- TAINT_NOT;
-
- if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
- /* We are an argument to a function or grep().
- * This kind of lvalueness was legal before lvalue
- * subroutines too, so be backward compatible:
- * cannot report errors. */
-
- /* Scalar context *is* possible, on the LHS of -> only,
- * as in f()->meth(). But this is not an lvalue. */
- if (gimme == G_SCALAR)
- goto temporise;
- if (gimme == G_ARRAY) {
- if (!CvLVALUE(cx->blk_sub.cv))
- goto temporise_array;
- EXTEND_MORTAL(SP - newsp);
- for (mark = newsp + 1; mark <= SP; mark++) {
- if (SvTEMP(*mark))
- NOOP;
- else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
- *mark = sv_mortalcopy(*mark);
- else {
- /* Can be a localized value subject to deletion. */
- PL_tmps_stack[++PL_tmps_ix] = *mark;
- SvREFCNT_inc_void(*mark);
- }
- }
- }
- }
- else if (CxLVAL(cx)) { /* Leave it as it is if we can. */
- /* Here we go for robustness, not for speed, so we change all
- * the refcounts so the caller gets a live guy. Cannot set
- * TEMP, so sv_2mortal is out of question. */
- if (!CvLVALUE(cx->blk_sub.cv)) {
- LEAVE;
- cxstack_ix--;
- POPSUB(cx,sv);
- PL_curpm = newpm;
- LEAVESUB(sv);
- DIE(aTHX_ "Can't modify non-lvalue subroutine call");
- }
- if (gimme == G_SCALAR) {
- 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))) {
- LEAVE;
- cxstack_ix--;
- POPSUB(cx,sv);
- PL_curpm = newpm;
- LEAVESUB(sv);
- DIE(aTHX_ "Can't return %s from lvalue subroutine",
- SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
- : "a readonly value" : "a temporary");
- }
- else { /* Can be a localized value
- * subject to deletion. */
- PL_tmps_stack[++PL_tmps_ix] = *mark;
- SvREFCNT_inc_void(*mark);
- }
- }
- else { /* Should not happen? */
- LEAVE;
- cxstack_ix--;
- POPSUB(cx,sv);
- PL_curpm = newpm;
- LEAVESUB(sv);
- DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
- (MARK > SP ? "Empty array" : "Array"));
- }
- SP = MARK;
- }
- else if (gimme == G_ARRAY) {
- EXTEND_MORTAL(SP - newsp);
- for (mark = newsp + 1; mark <= SP; mark++) {
- if (*mark != &PL_sv_undef
- && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
- /* Might be flattened array after $#array = */
- PUTBACK;
- LEAVE;
- cxstack_ix--;
- POPSUB(cx,sv);
- PL_curpm = newpm;
- LEAVESUB(sv);
- DIE(aTHX_ "Can't return a %s from lvalue subroutine",
- SvREADONLY(TOPs) ? "readonly value" : "temporary");
- }
- else {
- /* Can be a localized value subject to deletion. */
- PL_tmps_stack[++PL_tmps_ix] = *mark;
- SvREFCNT_inc_void(*mark);
- }
- }
- }
- }
- else {
- if (gimme == G_SCALAR) {
- temporise:
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
- if (SvTEMP(TOPs)) {
- *MARK = SvREFCNT_inc(TOPs);
- FREETMPS;
- sv_2mortal(*MARK);
- }
- else {
- sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
- FREETMPS;
- *MARK = sv_mortalcopy(sv);
- SvREFCNT_dec(sv);
- }
- }
- else
- *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
- }
- else {
- MEXTEND(MARK, 0);
- *MARK = &PL_sv_undef;
- }
- SP = MARK;
- }
- else if (gimme == G_ARRAY) {
- temporise_array:
- for (MARK = newsp + 1; MARK <= SP; MARK++) {
- if (!SvTEMP(*MARK)) {
- *MARK = sv_mortalcopy(*MARK);
- TAINT_NOT; /* Each item is independent */
- }
- }
- }
- }
- PUTBACK;
-
- LEAVE;
- cxstack_ix--;
- POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
- PL_curpm = newpm; /* ... and pop $1 et al */
-
- LEAVESUB(sv);
- return cx->blk_sub.retop;
-}
-
PP(pp_entersub)
{
dVAR; dSP; dPOPss;
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 (sv == &PL_sv_yes) { /* unfound import, ignore */
if (hasargs)
SP = PL_stack_base + POPMARK;
+ else
+ (void)POPMARK;
RETURN;
}
SvGETMAGIC(sv);
if (SvROK(sv)) {
- SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
- tryAMAGICunDEREF(to_cv);
+ if (SvAMAGIC(sv)) {
+ sv = amagic_deref_call(sv, to_cv_amg);
+ /* Don't SPAGAIN here. */
+ }
}
else {
const char *sym;
SAVETMPS;
retry:
+ if (CvCLONE(cv) && ! CvCLONED(cv))
+ DIE(aTHX_ "Closure prototype called");
if (!CvROOT(cv) && !CvXSUB(cv)) {
GV* autogv;
SV* sub_name;
/* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
assert(CvXSUB(cv));
- CALL_FPTR(CvXSUB(cv))(aTHX_ cv);
+ CvXSUB(cv)(aTHX_ cv);
/* Enforce some sanity in scalar context. */
if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
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