#define PERL_IN_PP_CTL_C
#include "perl.h"
-#ifndef WORD_ALIGN
-#define WORD_ALIGN sizeof(U32)
-#endif
-
#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
#define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
memNE(RX_PRECOMP(re), t, len))
{
const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
- U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
+ U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
if (re) {
ReREFCNT_dec(re);
#ifdef USE_ITHREADS
#ifndef INCOMPLETE_TAINTS
if (PL_tainting) {
- if (PL_tainted)
+ if (PL_tainted) {
+ SvTAINTED_on((SV*)re);
RX_EXTFLAGS(re) |= RXf_TAINTED;
- else
- RX_EXTFLAGS(re) &= ~RXf_TAINTED;
+ }
}
#endif
SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
- if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
- cx->sb_rxtainted |= 2;
+ /* See "how taint works" above pp_subst() */
+ if (SvTAINTED(TOPs))
+ cx->sb_rxtainted |= SUBST_TAINT_REPL;
sv_catsv_nomg(dstr, POPs);
/* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
s -= RX_GOFS(rx);
else
sv_catpvn(dstr, s, cx->sb_strend - s);
}
- cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
+ if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
+ cx->sb_rxtainted |= SUBST_TAINT_PAT;
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(targ)) {
SvUTF8_on(targ);
SvPV_set(dstr, NULL);
- TAINT_IF(cx->sb_rxtainted & 1);
if (pm->op_pmflags & PMf_NONDESTRUCT)
PUSHs(targ);
else
mPUSHi(saviters - 1);
(void)SvPOK_only_UTF8(targ);
- TAINT_IF(cx->sb_rxtainted);
- SvSETMAGIC(targ);
- SvTAINT(targ);
+ /* update the taint state of various various variables in
+ * preparation for final exit.
+ * See "how taint works" above pp_subst() */
+ if (PL_tainting) {
+ if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
+ ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
+ == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
+ )
+ (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
+
+ if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
+ && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
+ )
+ SvTAINTED_on(TOPs); /* taint return value */
+ /* needed for mg_set below */
+ PL_tainted = cBOOL(cx->sb_rxtainted &
+ (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
+ SvTAINT(TARG);
+ }
+ /* PL_tainted must be correctly set for this mg_set */
+ SvSETMAGIC(TARG);
+ TAINT_NOT;
LEAVE_SCOPE(cx->sb_oldsave);
POPSUBST(cx);
RETURNOP(pm->op_next);
+ /* NOTREACHED */
}
cx->sb_iters = saviters;
}
}
if (old != rx)
(void)ReREFCNT_inc(rx);
- cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
+ /* update the taint state of various various variables in preparation
+ * for calling the code block.
+ * See "how taint works" above pp_subst() */
+ if (PL_tainting) {
+ if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
+ cx->sb_rxtainted |= SUBST_TAINT_PAT;
+
+ if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
+ ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
+ == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
+ )
+ (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
+
+ if (cx->sb_iters > 1 && (cx->sb_rxtainted &
+ (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
+ SvTAINTED_on(cx->sb_targ);
+ TAINT_NOT;
+ }
rxres_save(&cx->sb_rxres, rx);
PL_curpm = pm;
RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
{
dVAR; dSP; dMARK; dORIGMARK;
register SV * const tmpForm = *++MARK;
- register U32 *fpc;
- register char *t;
- const char *f;
+ SV *formsv; /* contains text of original format */
+ register U32 *fpc; /* format ops program counter */
+ register char *t; /* current append position in target string */
+ const char *f; /* current position in format string */
register I32 arg;
- register SV *sv = NULL;
- const char *item = NULL;
- I32 itemsize = 0;
- I32 fieldsize = 0;
- I32 lines = 0;
- bool chopspace = (strchr(PL_chopset, ' ') != NULL);
- const char *chophere = NULL;
- char *linemark = NULL;
+ register SV *sv = NULL; /* current item */
+ const char *item = NULL;/* string value of current item */
+ I32 itemsize = 0; /* length of current item, possibly truncated */
+ I32 fieldsize = 0; /* width of current field */
+ I32 lines = 0; /* number of lines that have been output */
+ bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
+ const char *chophere = NULL; /* where to chop current item */
+ char *linemark = NULL; /* pos of start of line in output */
NV value;
- bool gotsome = FALSE;
+ bool gotsome = FALSE; /* seen at least one non-blank item on this line */
STRLEN len;
- const STRLEN fudge = SvPOKp(tmpForm)
- ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
+ STRLEN fudge; /* estimate of output size in bytes */
bool item_is_utf8 = FALSE;
bool targ_is_utf8 = FALSE;
SV * nsv = NULL;
- OP * parseres = NULL;
const char *fmt;
+ MAGIC *mg = NULL;
+
+ mg = doparseform(tmpForm);
+
+ fpc = (U32*)mg->mg_ptr;
+ /* the actual string the format was compiled from.
+ * with overload etc, this may not match tmpForm */
+ formsv = mg->mg_obj;
+
- if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
- if (SvREADONLY(tmpForm)) {
- SvREADONLY_off(tmpForm);
- parseres = doparseform(tmpForm);
- SvREADONLY_on(tmpForm);
- }
- else
- parseres = doparseform(tmpForm);
- if (parseres)
- return parseres;
- }
SvPV_force(PL_formtarget, len);
- if (SvTAINTED(tmpForm))
+ if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
SvTAINTED_on(PL_formtarget);
if (DO_UTF8(PL_formtarget))
targ_is_utf8 = TRUE;
+ fudge = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
t += len;
- f = SvPV_const(tmpForm, len);
- /* need to jump to the next word */
- fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
+ f = SvPV_const(formsv, len);
for (;;) {
DEBUG_f( {
case FF_LITERAL:
arg = *fpc++;
- if (targ_is_utf8 && !SvUTF8(tmpForm)) {
+ if (targ_is_utf8 && !SvUTF8(formsv)) {
+ char *s;
SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
*t = '\0';
- sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
+
+ /* this is an unrolled sv_catpvn_utf8_upgrade(),
+ * but with the addition of s/~/ /g */
+ if (!(nsv))
+ nsv = newSVpvn_flags(f, arg, SVs_TEMP);
+ else
+ sv_setpvn(nsv, f, arg);
+ SvUTF8_off(nsv);
+ for (s = SvPVX(nsv); s <= SvEND(nsv); s++)
+ if (*s == '~')
+ *s = ' ';
+ sv_utf8_upgrade(nsv);
+ sv_catsv(PL_formtarget, nsv);
+
t = SvEND(PL_formtarget);
f += arg;
break;
}
- if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
+ if (!targ_is_utf8 && DO_UTF8(formsv)) {
SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
*t = '\0';
sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
t = SvEND(PL_formtarget);
targ_is_utf8 = TRUE;
}
- while (arg--)
- *t++ = *f++;
+ while (arg--) {
+ *t++ = (*f == '~') ? ' ' : *f;
+ f++;
+ }
break;
case FF_SKIP:
const int ch = *t++ = *s++;
if (iscntrl(ch))
#else
- if ( !((*t++ = *s++) & ~31) )
+ if ( !((*t++ = *s++) & ~31) )
#endif
t[-1] = ' ';
}
arg = *fpc++;
if (gotsome) {
if (arg) { /* repeat until fields exhausted? */
- *t = '\0';
- SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
- lines += FmLINES(PL_formtarget);
- if (targ_is_utf8)
- SvUTF8_on(PL_formtarget);
- FmLINES(PL_formtarget) = lines;
- SP = ORIGMARK;
- RETURNOP(cLISTOP->op_first);
+ fpc--;
+ goto end;
}
}
else {
break;
}
case FF_END:
+ end:
*t = '\0';
SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
if (targ_is_utf8)
SvUTF8_on(PL_formtarget);
FmLINES(PL_formtarget) += lines;
SP = ORIGMARK;
- RETPUSHYES;
+ if (fpc[-1] == FF_BLANK)
+ RETURNOP(cLISTOP->op_first);
+ else
+ RETPUSHYES;
}
}
}
register PERL_CONTEXT *cx;
bool popsub2 = FALSE;
bool clear_errsv = FALSE;
+ bool lval = FALSE;
I32 gimme;
SV **newsp;
PMOP *newpm;
switch (CxTYPE(cx)) {
case CXt_SUB:
popsub2 = TRUE;
+ lval = !!CvLVALUE(cx->blk_sub.cv);
retop = cx->blk_sub.retop;
cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
break;
}
}
else
- *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
+ *++newsp =
+ (lval || SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
}
else
*++newsp = sv_mortalcopy(*SP);
}
else if (gimme == G_ARRAY) {
while (++MARK <= SP) {
- *++newsp = (popsub2 && SvTEMP(*MARK))
+ *++newsp = popsub2 && (lval || SvTEMP(*MARK))
? *MARK : sv_mortalcopy(*MARK);
TAINT_NOT; /* Each item is independent */
}
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
if (CvISXSUB(cv)) {
OP* const retop = cx->blk_sub.retop;
- SV **newsp;
- I32 gimme;
+ SV **newsp __attribute__unused__;
+ I32 gimme __attribute__unused__;
if (reified) {
I32 index;
for (index=0; index<items; index++)
PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
ENTER_with_name("eval");
- lex_start(sv, NULL, 0);
+ lex_start(sv, NULL, LEX_START_SAME_FILTER);
SAVETMPS;
/* switch to eval mode */
PERL_ARGS_ASSERT_DOOPEN_PM;
if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
- SV *const pmcsv = sv_mortalcopy(name);
+ SV *const pmcsv = sv_newmortal();
Stat_t pmcstat;
+ SvSetSV_nosteal(pmcsv,name);
sv_catpvn(pmcsv, "c", 1);
if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
TAINT_PROPER("eval");
ENTER_with_name("eval");
- lex_start(sv, NULL, 0);
+ lex_start(sv, NULL, LEX_START_SAME_FILTER);
SAVETMPS;
/* switch to eval mode */
I32 optype;
SV *namesv;
+ PERL_ASYNC_CHECK();
POPBLOCK(cx,newpm);
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
register PERL_CONTEXT *cx;
I32 optype;
+ PERL_ASYNC_CHECK();
POPBLOCK(cx,newpm);
POPEVAL(cx);
PERL_UNUSED_VAR(optype);
ENTER_with_name("given");
SAVETMPS;
- sv_setsv(PAD_SV(PL_op->op_targ), POPs);
+ sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
PUSHBLOCK(cx, CXt_GIVEN, SP);
PUSHGIVEN(cx);
{
dVAR; dSP;
register PERL_CONTEXT *cx;
- I32 gimme;
+ I32 gimme __attribute__unused__;
SV **newsp;
PMOP *newpm;
RETURNOP(cx->blk_givwhen.leave_op);
}
-STATIC OP *
+static MAGIC *
S_doparseform(pTHX_ SV *sv)
{
STRLEN len;
- register char *s = SvPV_force(sv, len);
- register char * const send = s + len;
- register char *base = NULL;
- register I32 skipspaces = 0;
- bool noblank = FALSE;
- bool repeat = FALSE;
- bool postspace = FALSE;
+ register char *s = SvPV(sv, len);
+ register char *send;
+ register char *base = NULL; /* start of current field */
+ register I32 skipspaces = 0; /* number of contiguous spaces seen */
+ bool noblank = FALSE; /* ~ or ~~ seen on this line */
+ bool repeat = FALSE; /* ~~ seen on this line */
+ bool postspace = FALSE; /* a text field may need right padding */
U32 *fops;
register U32 *fpc;
- U32 *linepc = NULL;
+ U32 *linepc = NULL; /* position of last FF_LINEMARK */
register I32 arg;
- bool ischop;
- bool unchopnum = FALSE;
+ bool ischop; /* it's a ^ rather than a @ */
+ bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
+ MAGIC *mg = NULL;
+ SV *sv_copy;
PERL_ARGS_ASSERT_DOPARSEFORM;
if (len == 0)
Perl_croak(aTHX_ "Null picture in formline");
+ if (SvTYPE(sv) >= SVt_PVMG) {
+ /* This might, of course, still return NULL. */
+ mg = mg_find(sv, PERL_MAGIC_fm);
+ } else {
+ sv_upgrade(sv, SVt_PVMG);
+ }
+
+ if (mg) {
+ /* still the same as previously-compiled string? */
+ SV *old = mg->mg_obj;
+ if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
+ && len == SvCUR(old)
+ && strnEQ(SvPVX(old), SvPVX(sv), len)
+ ) {
+ DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
+ return mg;
+ }
+
+ DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
+ Safefree(mg->mg_ptr);
+ mg->mg_ptr = NULL;
+ SvREFCNT_dec(old);
+ mg->mg_obj = NULL;
+ }
+ else {
+ DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
+ mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
+ }
+
+ sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
+ s = SvPV(sv_copy, len); /* work on the copy, not the original */
+ send = s + len;
+
+
/* estimate the buffer size needed */
for (base = s; s <= send; s++) {
if (*s == '\n' || *s == '@' || *s == '^')
case '~':
if (*s == '~') {
repeat = TRUE;
- *s = ' ';
+ skipspaces++;
+ s++;
}
noblank = TRUE;
- s[-1] = ' ';
/* FALL THROUGH */
case ' ': case '\t':
skipspaces++;
base = s - 1;
*fpc++ = FF_FETCH;
- if (*s == '*') {
+ if (*s == '*') { /* @* or ^* */
s++;
*fpc++ = 2; /* skip the @* or ^* */
if (ischop) {
} else
*fpc++ = FF_LINEGLOB;
}
- else if (*s == '#' || (*s == '.' && s[1] == '#')) {
+ else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
arg = ischop ? 512 : 0;
base = s - 1;
while (*s == '#')
*fpc++ = (U16)arg;
unchopnum |= ! ischop;
}
- else {
+ else { /* text field */
I32 prespace = 0;
bool ismore = FALSE;
*fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
if (prespace)
- *fpc++ = (U16)prespace;
+ *fpc++ = (U16)prespace; /* add SPACE or HALFSPACE */
*fpc++ = FF_ITEM;
if (ismore)
*fpc++ = FF_MORE;
assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
arg = fpc - fops;
- { /* need to jump to the next word */
- int z;
- z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
- SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
- s = SvPVX(sv) + SvCUR(sv) + z;
- }
- Copy(fops, s, arg, U32);
- Safefree(fops);
- sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
- SvCOMPILED_on(sv);
+
+ mg->mg_ptr = (char *) fops;
+ mg->mg_len = arg * sizeof(U32);
+ mg->mg_obj = sv_copy;
+ mg->mg_flags |= MGf_REFCOUNTED;
if (unchopnum && repeat)
- DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
- return 0;
+ Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
+
+ return mg;
}
https://perl5.git.perl.org / perl5.git / blobdiff