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));
}
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_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;
}
}
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() */
+ 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_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);
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) ? (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;
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;
}
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);
}
/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;
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)) {
* 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 && SvGMAGICAL(sv))
+ if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
mg_get(sv);
PUSHs(sv);
RETURN;
bool is_cow;
#endif
SV *nsv = NULL;
+ /* known replacement string? */
+ register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
PERL_ASYNC_CHECK();
- /* known replacement string? */
- register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
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;
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
r_flags | REXEC_CHECKED);
/* known replacement string? */
if (dstr) {
+
+ /* 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 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) {
+ goto setup_match;
+ }
+ }
+
/* replacement needing upgrading? */
if (DO_UTF8(TARG) && !doutf8) {
nsv = sv_newmortal();
doutf8 = FALSE;
}
+ if (!matched) {
+ ret_no:
+ SPAGAIN;
+ PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no);
+ LEAVE_SCOPE(oldsave);
+ RETURN;
+ }
+
/* can do inplace substitution? */
if (c
#ifdef PERL_OLD_COPY_ON_WRITE
#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);
}
TAINT_IF(rxtainted & 1);
SPAGAIN;
- PUSHs(&PL_sv_yes);
+ PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_yes);
}
else {
do {
}
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);
TAINT_IF(rxtainted);
LEAVE_SCOPE(oldsave);
RETURN;
}
-
- if (matched)
- {
+ else {
if (force_on_match) {
force_on_match = 0;
s = SvPV_force(TARG, len);
TAINT_IF(rxtainted & 1);
SPAGAIN;
- mPUSHi((I32)iters);
+ if (rpm->op_pmflags & PMf_NONDESTRUCT)
+ PUSHs(TARG);
+ else
+ mPUSHi((I32)iters);
(void)SvPOK_only(TARG);
if (doutf8)
LEAVE_SCOPE(oldsave);
RETURN;
}
- goto ret_no;
-
-nope:
-ret_no:
- SPAGAIN;
- PUSHs(&PL_sv_no);
- LEAVE_SCOPE(oldsave);
- RETURN;
+ /* NOTREACHED */
}
PP(pp_grepwhile)
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? */
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)
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;
/* 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 ) {
vivify_ref(*svp, PL_op->op_private & OPpDEREF);
}
sv = (svp ? *svp : &PL_sv_undef);
- if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
+ 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:
https://perl5.git.perl.org / perl5.git / blobdiff