(PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
TAINT_NOT;
- PL_reg_match_utf8 = DO_UTF8(TARG);
+ RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
/* PMdf_USED is set after a ?? matches once */
if (pm->op_pmdynflags & PMdf_USED) {
if (global) {
rx->subbeg = truebase;
rx->startp[0] = s - truebase;
- if (PL_reg_match_utf8) {
+ if (RX_MATCH_UTF8(rx)) {
char *t = (char*)utf8_hop((U8*)s, rx->minlen);
rx->endp[0] = t - truebase;
}
}
if (PL_sawampersand) {
I32 off;
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
+ if (DEBUG_C_TEST) {
+ PerlIO_printf(Perl_debug_log,
+ "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
+ (int) SvTYPE(TARG), truebase, t,
+ (int)(t-truebase));
+ }
+ rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
+ rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
+ assert (SvPOKp(rx->saved_copy));
+ } else
+#endif
+ {
- rx->subbeg = savepvn(t, strend - t);
+ rx->subbeg = savepvn(t, strend - t);
+#ifdef PERL_COPY_ON_WRITE
+ rx->saved_copy = Nullsv;
+#endif
+ }
rx->sublen = strend - t;
RX_MATCH_COPIED_on(rx);
off = rx->startp[0] = s - t;
report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
}
if (gimme == G_SCALAR) {
+ /* undef TARG, and push that undefined value */
+ SV_CHECK_THINKFIRST_COW_DROP(TARG);
(void)SvOK_off(TARG);
PUSHTARG;
}
}
}
if (gimme == G_SCALAR) {
+ SV_CHECK_THINKFIRST_COW_DROP(TARG);
(void)SvOK_off(TARG);
SPAGAIN;
PUSHTARG;
I32 oldsave = PL_savestack_ix;
STRLEN slen;
bool doutf8 = FALSE;
+#ifdef PERL_COPY_ON_WRITE
+ bool is_cow;
+#endif
/* known replacement string? */
dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
EXTEND(SP,1);
}
+#ifdef PERL_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;
+#else
if (SvIsCOW(TARG))
sv_force_normal_flags(TARG,0);
- if (SvREADONLY(TARG)
+#endif
+ if (
+#ifdef PERL_COPY_ON_WRITE
+ !is_cow &&
+#endif
+ (SvREADONLY(TARG)
|| (SvTYPE(TARG) > SVt_PVLV
- && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
+ && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
DIE(aTHX_ PL_no_modify);
PUTBACK;
rxtainted |= 2;
TAINT_NOT;
- PL_reg_match_utf8 = DO_UTF8(TARG);
+ RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
force_it:
if (!pm || !s)
DIE(aTHX_ "panic: pp_subst");
strend = s + len;
- slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
+ slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
maxiters = 2 * slen + 10; /* We can match twice at each
position, once with zero-length,
second time with non-zero. */
rx = PM_GETRE(pm);
}
r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
- ? REXEC_COPY_STR : 0;
+ ? REXEC_COPY_STR : 0;
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
}
/* can do inplace substitution? */
- if (c && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
+ if (c
+#ifdef PERL_COPY_ON_WRITE
+ && !is_cow
+#endif
+ && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
&& !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
r_flags | REXEC_CHECKED))
LEAVE_SCOPE(oldsave);
RETURN;
}
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW(TARG)) {
+ assert (!force_on_match);
+ goto have_a_cow;
+ }
+#endif
if (force_on_match) {
force_on_match = 0;
s = SvPV_force(TARG, len);
s = SvPV_force(TARG, len);
goto force_it;
}
+#ifdef PERL_COPY_ON_WRITE
+ have_a_cow:
+#endif
rxtainted |= RX_MATCH_TAINTED(rx);
dstr = NEWSV(25, len);
sv_setpvn(dstr, m, s-m);
else
sv_catpvn(dstr, s, strend - s);
- (void)SvOOK_off(TARG);
- Safefree(SvPVX(TARG));
+#ifdef PERL_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
+#endif
+ {
+ (void)SvOOK_off(TARG);
+ if (SvLEN(TARG))
+ Safefree(SvPVX(TARG));
+ }
SvPVX(TARG) = SvPVX(dstr);
SvCUR_set(TARG, SvCUR(dstr));
SvLEN_set(TARG, SvLEN(dstr));
gimme = GIMME_V;
if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
+ if (CvASSERTION(cv) && PL_DBassertion)
+ sv_setiv(PL_DBassertion, 1);
+
cv = get_db_sub(&sv, cv);
if (!cv)
DIE(aTHX_ "No DBsub routine");
else {
sub_name = sv_newmortal();
gv_efullname3(sub_name, gv, Nullch);
- DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
+ DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
}
}
if (!cv)
else {
SV* tmpstr = sv_newmortal();
gv_efullname3(tmpstr, CvGV(cv), Nullch);
- Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%s\"",
- SvPVX(tmpstr));
+ Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
+ tmpstr);
}
}
SV *sv;
if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
if (elem > 0)
elem -= PL_curcop->cop_arybase;
if (SvTYPE(av) != SVt_PVAV)
PP(pp_method_named)
{
dSP;
- SV* sv = cSVOP->op_sv;
+ SV* sv = cSVOP_sv;
U32 hash = SvUVX(sv);
XPUSHs(method_common(sv, &hash));
projects / p5sagit/p5-mst-13.2.git / blobdiff