if (PL_op->op_private & OPpLVAL_INTRO)
PUSHs(save_scalar(cGVOP_gv));
else
- PUSHs(GvSV(cGVOP_gv));
+ PUSHs(GvSVn(cGVOP_gv));
RETURN;
}
if (!SvTRUE(TOPs))
RETURN;
else {
- --SP;
+ if (PL_op->op_type == OP_AND)
+ --SP;
RETURNOP(cLOGOP->op_other);
}
}
dSP; dPOPTOPssrl;
if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
- SV *temp;
- temp = left; left = right; right = temp;
+ SV * const temp = left;
+ left = right; right = temp;
}
if (PL_tainting && PL_tainted && !SvTAINTED(left))
TAINT_NOT;
+ if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
+ SV *cv = SvRV(left);
+ const U32 cv_type = SvTYPE(cv);
+ const U32 gv_type = SvTYPE(right);
+ bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
+
+ if (!got_coderef) {
+ assert(SvROK(cv));
+ }
+
+ /* Can do the optimisation if right (LVAUE) 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) {
+ /* Is the target symbol table currently empty? */
+ GV *gv = gv_fetchsv(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. */
+ SV *const value = SvRV(cv);
+
+ SvUPGRADE((SV *)gv, SVt_RV);
+ SvROK_on(gv);
+ SvRV_set(gv, value);
+ SvREFCNT_inc(value);
+ SETs(right);
+ RETURN;
+ }
+ }
+
+ /* Need to fix things up. */
+ if (gv_type != SVt_PVGV) {
+ /* Need to fix GV. */
+ right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
+ }
+
+ if (!got_coderef) {
+ /* We've been returned a constant rather than a full subroutine,
+ but they expect a subroutine reference to apply. */
+ ENTER;
+ SvREFCNT_inc(SvRV(cv));
+ /* newCONSTSUB takes a reference count on the passed in SV
+ from us. We set the name to NULL, otherwise we get into
+ all sorts of fun as the reference to our new sub is
+ donated to the GV that we're about to assign to.
+ */
+ SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
+ SvRV(cv)));
+ SvREFCNT_dec(cv);
+ LEAVE;
+ }
+
+ }
SvSetMagicSV(right, left);
SETs(right);
RETURN;
dPOPTOPssrl;
bool lbyte;
STRLEN rlen;
- const char *rpv = SvPV(right, rlen); /* mg_get(right) happens here */
- const bool rbyte = !DO_UTF8(right);
+ const char *rpv;
+ bool rbyte;
bool rcopied = FALSE;
if (TARG == right && right != left) {
+ /* mg_get(right) may happen here ... */
+ rpv = SvPV_const(right, rlen);
+ rbyte = !DO_UTF8(right);
right = sv_2mortal(newSVpvn(rpv, rlen));
- rpv = SvPV(right, rlen); /* no point setting UTF-8 here */
+ rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */
rcopied = TRUE;
}
if (TARG != left) {
STRLEN llen;
- const char* const lpv = SvPV(left, llen); /* mg_get(left) may happen here */
+ const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
lbyte = !DO_UTF8(left);
sv_setpvn(TARG, lpv, llen);
if (!lbyte)
}
else { /* TARG == left */
STRLEN llen;
- if (SvGMAGICAL(left))
- mg_get(left); /* or mg_get(left) may happen here */
- if (!SvOK(TARG))
+ SvGETMAGIC(left); /* or mg_get(left) may happen here */
+ if (!SvOK(TARG)) {
+ if (left == right && ckWARN(WARN_UNINITIALIZED))
+ report_uninit(right);
sv_setpvn(left, "", 0);
- (void)SvPV_nomg(left, llen); /* Needed to set UTF8 flag */
+ }
+ (void)SvPV_nomg_const(left, llen); /* Needed to set UTF8 flag */
lbyte = !DO_UTF8(left);
if (IN_BYTES)
SvUTF8_off(TARG);
}
+ /* or mg_get(right) may happen here */
+ if (!rcopied) {
+ rpv = SvPV_const(right, rlen);
+ rbyte = !DO_UTF8(right);
+ }
if (lbyte != rbyte) {
if (lbyte)
sv_utf8_upgrade_nomg(TARG);
if (!rcopied)
right = sv_2mortal(newSVpvn(rpv, rlen));
sv_utf8_upgrade_nomg(right);
- rpv = SvPV(right, rlen);
+ rpv = SvPV_const(right, rlen);
}
}
sv_catpvn_nomg(TARG, rpv, rlen);
right argument if we know the left is integer. */
SvIV_please(TOPm1s);
if (SvIOK(TOPm1s)) {
- bool auvok = SvUOK(TOPm1s);
- bool buvok = SvUOK(TOPs);
+ 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
differ from normal zero. As I understand it. (Need to
check - is negative zero implementation defined behaviour
anyway?). NWC */
- UV buv = SvUVX(POPs);
- UV auv = SvUVX(TOPs);
+ const UV buv = SvUVX(POPs);
+ const UV auv = SvUVX(TOPs);
SETs(boolSV(auv == buv));
RETURN;
if (SvTRUE(TOPs))
RETURN;
else {
- --SP;
+ if (PL_op->op_type == OP_OR)
+ --SP;
RETURNOP(cLOGOP->op_other);
}
}
-PP(pp_dor)
+PP(pp_defined)
{
- /* Most of this is lifted straight from pp_defined */
dSP;
- register SV* const sv = TOPs;
+ register SV* sv = NULL;
+ bool defined = FALSE;
+ const int op_type = PL_op->op_type;
+
+ if(op_type == OP_DOR || op_type == OP_DORASSIGN) {
+ sv = TOPs;
+ if (!sv || !SvANY(sv)) {
+ if (op_type == OP_DOR)
+ --SP;
+ RETURNOP(cLOGOP->op_other);
+ }
+ } else if (op_type == OP_DEFINED) {
+ sv = POPs;
+ if (!sv || !SvANY(sv))
+ RETPUSHNO;
+ } else
+ DIE(aTHX_ "panic: Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
- if (!sv || !SvANY(sv)) {
- --SP;
- RETURNOP(cLOGOP->op_other);
- }
-
switch (SvTYPE(sv)) {
case SVt_PVAV:
if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
- RETURN;
+ defined = TRUE;
break;
case SVt_PVHV:
if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
- RETURN;
+ defined = TRUE;
break;
case SVt_PVCV:
if (CvROOT(sv) || CvXSUB(sv))
- RETURN;
+ defined = TRUE;
break;
default:
- if (SvGMAGICAL(sv))
- mg_get(sv);
+ SvGETMAGIC(sv);
if (SvOK(sv))
- RETURN;
+ defined = TRUE;
}
- --SP;
- RETURNOP(cLOGOP->op_other);
+ if(op_type == OP_DOR || op_type == OP_DORASSIGN) {
+ if(defined)
+ RETURN;
+ if(op_type == OP_DOR)
+ --SP;
+ RETURNOP(cLOGOP->op_other);
+ }
+ /* assuming OP_DEFINED */
+ if(defined)
+ RETPUSHYES;
+ RETPUSHNO;
}
PP(pp_add)
PP(pp_aelemfast)
{
dSP;
- AV *av = PL_op->op_flags & OPf_SPECIAL ?
+ AV * const av = PL_op->op_flags & OPf_SPECIAL ?
(AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
const U32 lval = PL_op->op_flags & OPf_MOD;
- SV** svp = av_fetch(av, PL_op->op_private, lval);
+ 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() */
* We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
* will be enough to hold an OP*.
*/
- SV* sv = sv_newmortal();
+ SV* const sv = sv_newmortal();
sv_upgrade(sv, SVt_PVLV);
LvTYPE(sv) = '/';
Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
PP(pp_print)
{
dVAR; dSP; dMARK; dORIGMARK;
- GV *gv;
IO *io;
register PerlIO *fp;
MAGIC *mg;
-
- if (PL_op->op_flags & OPf_STACKED)
- gv = (GV*)*++MARK;
- else
- gv = PL_defoutgv;
+ GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
if (gv && (io = GvIO(gv))
&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
}
}
SP = ORIGMARK;
- PUSHs(&PL_sv_yes);
+ XPUSHs(&PL_sv_yes);
RETURN;
just_say_no:
SP = ORIGMARK;
- PUSHs(&PL_sv_undef);
+ XPUSHs(&PL_sv_undef);
RETURN;
}
if ((PL_op->op_flags & OPf_SPECIAL) &&
!(PL_op->op_flags & OPf_MOD))
{
- gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVAV);
+ gv = (GV*)gv_fetchsv(sv, 0, SVt_PVAV);
if (!gv
&& (!is_gv_magical_sv(sv,0)
- || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV))))
+ || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV))))
{
RETSETUNDEF;
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
- gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV);
+ gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVAV);
}
}
else {
if (SvRMAGICAL(av)) {
U32 i;
for (i=0; i < (U32)maxarg; i++) {
- SV **svp = av_fetch(av, i, FALSE);
+ 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
if ((PL_op->op_flags & OPf_SPECIAL) &&
!(PL_op->op_flags & OPf_MOD))
{
- gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVHV);
+ gv = (GV*)gv_fetchsv(sv, 0, SVt_PVHV);
if (!gv
&& (!is_gv_magical_sv(sv,0)
- || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV))))
+ || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV))))
{
RETSETUNDEF;
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
- gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV);
+ gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PVHV);
}
}
else {
if (PL_op->op_private & (OPpASSIGN_COMMON)) {
EXTEND_MORTAL(lastrelem - firstrelem + 1);
for (relem = firstrelem; relem <= lastrelem; relem++) {
- /*SUPPRESS 560*/
if ((sv = *relem)) {
TAINT_NOT; /* Each item is independent */
*relem = sv_mortalcopy(sv);
PP(pp_qr)
{
dSP;
- register PMOP *pm = cPMOP;
- SV *rv = sv_newmortal();
- SV *sv = newSVrv(rv, "Regexp");
+ register PMOP * const pm = cPMOP;
+ SV * const rv = sv_newmortal();
+ SV * const sv = newSVrv(rv, "Regexp");
if (pm->op_pmdynflags & PMdf_TAINTED)
SvTAINTED_on(rv);
sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
dSP; dTARG;
register PMOP *pm = cPMOP;
PMOP *dynpm = pm;
- register char *t;
- register char *s;
- char *strend;
+ register const char *t;
+ register const char *s;
+ const char *strend;
I32 global;
I32 r_flags = REXEC_CHECKED;
- char *truebase; /* Start of string */
+ const char *truebase; /* Start of string */
register REGEXP *rx = PM_GETRE(pm);
bool rxtainted;
const I32 gimme = GIMME;
}
PUTBACK; /* EVAL blocks need stack_sp. */
- s = SvPV(TARG, len);
- strend = s + len;
+ s = SvPV_const(TARG, len);
if (!s)
DIE(aTHX_ "panic: pp_match");
+ strend = s + len;
rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
(PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
TAINT_NOT;
if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
rx->startp[0] = -1;
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
- MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
+ MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
if (mg && mg->mg_len >= 0) {
if (!(rx->reganch & ROPT_GPOS_SEEN))
rx->endp[0] = rx->startp[0] = mg->mg_len;
}
if (rx->reganch & RE_USE_INTUIT &&
DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
- PL_bostr = truebase;
- s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
+ /* FIXME - can PL_bostr be made const char *? */
+ PL_bostr = (char *)truebase;
+ s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
if (!s)
goto nope;
&& !SvROK(TARG)) /* Cannot trust since INTUIT cannot guess ^ */
goto yup;
}
- if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
+ if (CALLREGEXEC(aTHX_ rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, NULL, r_flags))
{
PL_curpm = pm;
if (dynpm->op_pmflags & PMf_ONCE)
EXTEND_MORTAL(nparens + i);
for (i = !i; i <= nparens; i++) {
PUSHs(sv_newmortal());
- /*SUPPRESS 560*/
if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
const I32 len = rx->endp[i] - rx->startp[i];
s = rx->startp[i] + truebase;
RX_MATCH_COPIED_off(rx);
rx->subbeg = Nullch;
if (global) {
- rx->subbeg = truebase;
+ /* FIXME - should rx->subbeg be const char *? */
+ rx->subbeg = (char *) truebase;
rx->startp[0] = s - truebase;
if (RX_MATCH_UTF8(rx)) {
- char *t = (char*)utf8_hop((U8*)s, rx->minlen);
+ char * const t = (char*)utf8_hop((U8*)s, rx->minlen);
rx->endp[0] = t - truebase;
}
else {
}
if (PL_sawampersand) {
I32 off;
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log,
(int)(t-truebase));
}
rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
- rx->subbeg = SvPVX_const(rx->saved_copy) + (t - truebase);
+ rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
assert (SvPOKp(rx->saved_copy));
} else
#endif
{
rx->subbeg = savepvn(t, strend - t);
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
rx->saved_copy = Nullsv;
#endif
}
if (av_len(GvAVn(PL_last_in_gv)) < 0) {
IoFLAGS(io) &= ~IOf_START;
do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
- sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
+ sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
SvSETMAGIC(GvSV(PL_last_in_gv));
fp = IoIFP(io);
goto have_fp;
}
}
if (!fp) {
- if (ckWARN2(WARN_GLOB, WARN_CLOSED)
- && (!io || !(IoFLAGS(io) & IOf_START))) {
+ if ((!io || !(IoFLAGS(io) & IOf_START))
+ && ckWARN2(WARN_GLOB, WARN_CLOSED))
+ {
if (type == OP_GLOB)
Perl_warner(aTHX_ packWARN(WARN_GLOB),
"glob failed (can't start child: %s)",
sv = TARG;
if (SvROK(sv))
sv_unref(sv);
- (void)SvUPGRADE(sv, SVt_PV);
+ SvUPGRADE(sv, SVt_PV);
tmplen = SvLEN(sv); /* remember if already alloced */
if (!tmplen && !SvREADONLY(sv))
Sv_Grow(sv, 80); /* try short-buffering it */
offset = 0;
if (type == OP_RCATLINE && SvOK(sv)) {
if (!SvPOK(sv)) {
- STRLEN n_a;
- (void)SvPV_force(sv, n_a);
+ SvPV_force_nolen(sv);
}
offset = SvCUR(sv);
}
XPUSHs(sv);
if (type == OP_GLOB) {
char *tmps;
+ const char *t1;
if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
tmps = SvEND(sv) - 1;
SvCUR_set(sv, SvCUR(sv) - 1);
}
}
- for (tmps = SvPVX(sv); *tmps; tmps++)
- if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
- strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
+ for (t1 = SvPVX_const(sv); *t1; t1++)
+ if (!isALPHA(*t1) && !isDIGIT(*t1) &&
+ strchr("$&*(){}[]'\";\\|?<>~`", *t1))
break;
- if (*tmps && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
+ if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
(void)POPs; /* Unmatched wildcard? Chuck it... */
continue;
}
} else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
- const U8 *s = (U8*)SvPVX(sv) + offset;
+ const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
const STRLEN len = SvCUR(sv) - offset;
const U8 *f;
if (ckWARN(WARN_UTF8) &&
- !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
+ !is_utf8_string_loc(s, len, &f))
/* Emulate :encoding(utf8) warning in the same case. */
Perl_warner(aTHX_ packWARN(WARN_UTF8),
"utf8 \"\\x%02X\" does not map to Unicode",
dSP;
HE* he;
SV **svp;
- SV *keysv = POPs;
- HV *hv = (HV*)POPs;
+ SV * const keysv = POPs;
+ HV * const hv = (HV*)POPs;
const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
SV *sv;
- const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
+ const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
I32 preeminent = 0;
if (SvTYPE(hv) == SVt_PVHV) {
else {
if (!preeminent) {
STRLEN keylen;
- const char * const key = SvPV(keysv, keylen);
+ const char * const key = SvPV_const(keysv, keylen);
SAVEDELETE(hv, savepvn(key,keylen), keylen);
} else
save_helem(hv, keysv, svp);
/* string increment */
register SV* cur = cx->blk_loop.iterlval;
STRLEN maxlen = 0;
- const char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : "";
+ const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
RETPUSHNO;
if (SvMAGICAL(av) || AvREIFY(av)) {
- SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
- if (svp)
- sv = *svp;
- else
- sv = Nullsv;
+ SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
+ sv = svp ? *svp : Nullsv;
}
else {
- sv = AvARRAY(av)[cx->blk_loop.iterix--];
+ sv = AvARRAY(av)[--cx->blk_loop.iterix];
}
}
else {
RETPUSHNO;
if (SvMAGICAL(av) || AvREIFY(av)) {
- SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
- if (svp)
- sv = *svp;
- else
- sv = Nullsv;
+ SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
+ sv = svp ? *svp : Nullsv;
}
else {
sv = AvARRAY(av)[++cx->blk_loop.iterix];
}
}
- if (sv && SvREFCNT(sv) == 0) {
+ if (sv && SvIS_FREED(sv)) {
*itersvp = Nullsv;
Perl_croak(aTHX_ "Use of freed value in iteration");
}
register char *s;
char *strend;
register char *m;
- char *c;
+ const char *c;
register char *d;
STRLEN clen;
I32 iters = 0;
register REGEXP *rx = PM_GETRE(pm);
STRLEN len;
int force_on_match = 0;
- I32 oldsave = PL_savestack_ix;
+ const I32 oldsave = PL_savestack_ix;
STRLEN slen;
bool doutf8 = FALSE;
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
bool is_cow;
#endif
SV *nsv = Nullsv;
EXTEND(SP,1);
}
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
/* Awooga. Awooga. "bool" types that are actually char are dangerous,
because they make integers such as 256 "false". */
is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
sv_force_normal_flags(TARG,0);
#endif
if (
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
!is_cow &&
#endif
(SvREADONLY(TARG)
DIE(aTHX_ PL_no_modify);
PUTBACK;
- s = SvPV(TARG, len);
+ s = SvPV_mutable(TARG, len);
if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
force_on_match = 1;
rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
sv_recode_to_utf8(nsv, PL_encoding);
else
sv_utf8_upgrade(nsv);
- c = SvPV(nsv, clen);
+ c = SvPV_const(nsv, clen);
doutf8 = TRUE;
}
else {
- c = SvPV(dstr, clen);
+ c = SvPV_const(dstr, clen);
doutf8 = DO_UTF8(dstr);
}
}
/* can do inplace substitution? */
if (c
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
&& !is_cow
#endif
&& (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
LEAVE_SCOPE(oldsave);
RETURN;
}
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(TARG)) {
assert (!force_on_match);
goto have_a_cow;
*m = '\0';
SvCUR_set(TARG, m - s);
}
- /*SUPPRESS 560*/
else if ((i = m - s)) { /* faster from front */
d -= clen;
m = d;
DIE(aTHX_ "Substitution loop");
rxtainted |= RX_MATCH_TAINTED(rx);
m = rx->startp[0] + orig;
- /*SUPPRESS 560*/
if ((i = m - s)) {
if (s != d)
Move(s, d, i, char);
s = SvPV_force(TARG, len);
goto force_it;
}
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
have_a_cow:
#endif
rxtainted |= RX_MATCH_TAINTED(rx);
if (!c) {
register PERL_CONTEXT *cx;
SPAGAIN;
- ReREFCNT_inc(rx);
+ (void)ReREFCNT_inc(rx);
PUSHSUBST(cx);
RETURNOP(cPMOP->op_pmreplroot);
}
else
sv_catpvn(dstr, s, strend - s);
-#ifdef PERL_COPY_ON_WRITE
+#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
/* All done yet? */
if (PL_stack_base + *PL_markstack_ptr > SP) {
I32 items;
- I32 gimme = GIMME_V;
+ const I32 gimme = GIMME_V;
LEAVE; /* exit outer scope */
(void)POPMARK; /* pop src */
SP = PL_stack_base + POPMARK; /* pop original mark */
if (gimme == G_SCALAR) {
if (PL_op->op_private & OPpGREP_LEX) {
- SV* sv = sv_newmortal();
+ SV* const sv = sv_newmortal();
sv_setiv(sv, items);
PUSHs(sv);
}
register PERL_CONTEXT *cx;
SV *sv;
+ if (CxMULTICALL(&cxstack[cxstack_ix]))
+ return 0;
+
POPBLOCK(cx,newpm);
cxstack_ix++; /* temporarily protect top context */
register PERL_CONTEXT *cx;
SV *sv;
+ if (CxMULTICALL(&cxstack[cxstack_ix]))
+ return 0;
+
POPBLOCK(cx,newpm);
cxstack_ix++; /* temporarily protect top context */
MARK = newsp + 1;
EXTEND_MORTAL(1);
if (MARK == SP) {
- if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
+ /* 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);
STATIC CV *
S_get_db_sub(pTHX_ SV **svp, CV *cv)
{
- SV *dbsv = GvSV(PL_DBsub);
+ SV * const dbsv = GvSVn(PL_DBsub);
save_item(dbsv);
if (!PERLDB_SUB_NN) {
&& (gv = (GV*)*svp) ))) {
/* Use GV from the stack as a fallback. */
/* GV is potentially non-unique, or contain different CV. */
- SV *tmp = newRV((SV*)cv);
+ SV * const tmp = newRV((SV*)cv);
sv_setsv(dbsv, tmp);
SvREFCNT_dec(tmp);
}
{
dVAR; dSP; dPOPss;
GV *gv;
- HV *stash;
register CV *cv;
register PERL_CONTEXT *cx;
I32 gimme;
switch (SvTYPE(sv)) {
/* This is overwhelming the most common case: */
case SVt_PVGV:
- if (!(cv = GvCVu((GV*)sv)))
- cv = sv_2cv(sv, &stash, &gv, FALSE);
+ if (!(cv = GvCVu((GV*)sv))) {
+ HV *stash;
+ cv = sv_2cv(sv, &stash, &gv, 0);
+ }
if (!cv) {
ENTER;
SAVETMPS;
sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
}
else {
- STRLEN n_a;
- sym = SvPV(sv, n_a);
+ sym = SvPV_nolen_const(sv);
}
if (!sym)
DIE(aTHX_ PL_no_usym, "a subroutine");
}
got_rv:
{
- SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
+ SV * const * sp = &sv; /* Used in tryAMAGICunDEREF macro. */
tryAMAGICunDEREF(to_cv);
}
cv = (CV*)SvRV(sv);
retry:
if (!CvROOT(cv) && !CvXSUB(cv)) {
- goto fooey;
+ GV* autogv;
+ SV* sub_name;
+
+ /* anonymous or undef'd function leaves us no recourse */
+ if (CvANON(cv) || !(gv = CvGV(cv)))
+ DIE(aTHX_ "Undefined subroutine called");
+
+ /* autoloaded stub? */
+ if (cv != GvCV(gv)) {
+ cv = GvCV(gv);
+ }
+ /* should call AUTOLOAD now? */
+ else {
+try_autoload:
+ if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
+ FALSE)))
+ {
+ cv = GvCV(autogv);
+ }
+ /* sorry */
+ else {
+ sub_name = sv_newmortal();
+ gv_efullname3(sub_name, gv, Nullch);
+ DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
+ }
+ }
+ if (!cv)
+ DIE(aTHX_ "Not a CODE reference");
+ goto retry;
}
gimme = GIMME_V;
/* This path taken at least 75% of the time */
dMARK;
register I32 items = SP - MARK;
- AV* padlist = CvPADLIST(cv);
+ AV* const padlist = CvPADLIST(cv);
PUSHBLOCK(cx, CXt_SUB, MARK);
PUSHSUB(cx);
cx->blk_sub.retop = PL_op->op_next;
PERL_STACK_OVERFLOW_CHECK();
pad_push(padlist, CvDEPTH(cv));
}
- PAD_SET_CUR(padlist, CvDEPTH(cv));
+ SAVECOMPPAD();
+ PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
if (hasargs)
{
- AV* av;
-#if 0
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "%p entersub preparing @_\n", thr));
-#endif
- av = (AV*)PAD_SVl(0);
+ AV* const av = (AV*)PAD_SVl(0);
if (AvREAL(av)) {
/* @_ is normally not REAL--this should only ever
* happen when DB::sub() calls things that modify @_ */
LEAVE;
return NORMAL;
}
-
- assert (0); /* Cannot get here. */
- /* This is deliberately moved here as spaghetti code to keep it out of the
- hot path. */
- {
- GV* autogv;
- SV* sub_name;
-
- fooey:
- /* anonymous or undef'd function leaves us no recourse */
- if (CvANON(cv) || !(gv = CvGV(cv)))
- DIE(aTHX_ "Undefined subroutine called");
-
- /* autoloaded stub? */
- if (cv != GvCV(gv)) {
- cv = GvCV(gv);
- }
- /* should call AUTOLOAD now? */
- else {
-try_autoload:
- if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
- FALSE)))
- {
- cv = GvCV(autogv);
- }
- /* sorry */
- else {
- sub_name = sv_newmortal();
- gv_efullname3(sub_name, gv, Nullch);
- DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
- }
- }
- if (!cv)
- DIE(aTHX_ "Not a CODE reference");
- goto retry;
- }
}
void
if (CvANON(cv))
Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
else {
- SV* tmpstr = sv_newmortal();
+ SV* const tmpstr = sv_newmortal();
gv_efullname3(tmpstr, CvGV(cv), Nullch);
Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
tmpstr);
SV** svp;
SV* const elemsv = POPs;
IV elem = SvIV(elemsv);
- AV* av = (AV*)POPs;
+ AV* const av = (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));
SV *sv;
void
Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
{
- if (SvGMAGICAL(sv))
- mg_get(sv);
+ SvGETMAGIC(sv);
if (!SvOK(sv)) {
if (SvREADONLY(sv))
Perl_croak(aTHX_ PL_no_modify);
PP(pp_method)
{
dSP;
- SV* sv = TOPs;
+ SV* const sv = TOPs;
if (SvROK(sv)) {
- SV* rsv = SvRV(sv);
+ SV* const rsv = SvRV(sv);
if (SvTYPE(rsv) == SVt_PVCV) {
SETs(rsv);
RETURN;
PP(pp_method_named)
{
dSP;
- SV* sv = cSVOP_sv;
- U32 hash = SvUVX(sv);
+ SV* const sv = cSVOP_sv;
+ U32 hash = SvSHARED_HASH(sv);
XPUSHs(method_common(sv, &hash));
RETURN;
STATIC SV *
S_method_common(pTHX_ SV* meth, U32* hashp)
{
- SV* sv;
SV* ob;
GV* gv;
HV* stash;
STRLEN namelen;
- const char* packname = 0;
+ const char* packname = Nullch;
SV *packsv = Nullsv;
STRLEN packlen;
- const char *name = SvPV(meth, namelen);
-
- sv = *(PL_stack_base + TOPMARK + 1);
+ const char * const name = SvPV_const(meth, namelen);
+ SV * const sv = *(PL_stack_base + TOPMARK + 1);
if (!sv)
Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
- if (SvGMAGICAL(sv))
- mg_get(sv);
+ SvGETMAGIC(sv);
if (SvROK(sv))
ob = (SV*)SvRV(sv);
else {
GV* iogv;
/* this isn't a reference */
- packname = Nullch;
-
- if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
+ if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
if (he) {
stash = INT2PTR(HV*,SvIV(HeVAL(he)));
if (!SvOK(sv) ||
!(packname) ||
- !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
+ !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
!(ob=(SV*)GvIO(iogv)))
{
/* this isn't the name of a filehandle either */
packname = CopSTASHPV(PL_curcop);
}
else if (stash) {
- HEK *packhek = HvNAME_HEK(stash);
+ HEK * const packhek = HvNAME_HEK(stash);
if (packhek) {
packname = HEK_KEY(packhek);
packlen = HEK_LEN(packhek);