/* XXXX Should store the old value to allow for tie/overload - and
restore in regcomp, where marked with XXXX. */
PL_reginterp_cnt = 0;
+ TAINT_NOT;
return NORMAL;
}
char *orig = cx->sb_orig;
register REGEXP *rx = cx->sb_rx;
SV *nsv = Nullsv;
-
- {
- REGEXP *old = PM_GETRE(pm);
- if(old != rx) {
+ REGEXP *old = PM_GETRE(pm);
+ if(old != rx) {
if(old)
- ReREFCNT_dec(old);
+ ReREFCNT_dec(old);
PM_SETRE(pm,rx);
- }
}
rxres_restore(&cx->sb_rxres, rx);
sv_pos_b2u(sv, &i);
mg->mg_len = i;
}
- ReREFCNT_inc(rx);
+ if (old != rx)
+ ReREFCNT_inc(rx);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
rxres_save(&cx->sb_rxres, rx);
RETURNOP(pm->op_pmreplstart);
bool item_is_utf8 = FALSE;
bool targ_is_utf8 = FALSE;
SV * nsv = Nullsv;
+ OP * parseres = 0;
+ char *fmt;
+ bool oneline;
if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
if (SvREADONLY(tmpForm)) {
SvREADONLY_off(tmpForm);
- doparseform(tmpForm);
+ parseres = doparseform(tmpForm);
SvREADONLY_on(tmpForm);
}
else
- doparseform(tmpForm);
+ parseres = doparseform(tmpForm);
+ if (parseres)
+ return parseres;
}
SvPV_force(PL_formtarget, len);
if (DO_UTF8(PL_formtarget))
case FF_LINEMARK: name = "LINEMARK"; break;
case FF_END: name = "END"; break;
case FF_0DECIMAL: name = "0DECIMAL"; break;
+ case FF_LINESNGL: name = "LINESNGL"; break;
}
if (arg >= 0)
PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
while (s < send) {
if (*s == '\r') {
itemsize = s - item;
+ chophere = s;
break;
}
if (*s++ & ~31)
while (s < send) {
if (*s == '\r') {
itemsize = s - item;
+ chophere = s;
break;
}
if (*s++ & ~31)
sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
for (; t < SvEND(PL_formtarget); t++) {
#ifdef EBCDIC
- int ch = *t++ = *s++;
+ int ch = *t;
if (iscntrl(ch))
#else
if (!(*t & ~31))
SvSETMAGIC(sv);
break;
+ case FF_LINESNGL:
+ chopspace = 0;
+ oneline = TRUE;
+ goto ff_line;
case FF_LINEGLOB:
+ oneline = FALSE;
+ ff_line:
item = s = SvPV(sv, len);
itemsize = len;
if ((item_is_utf8 = DO_UTF8(sv)))
bool chopped = FALSE;
gotsome = TRUE;
send = s + len;
+ chophere = s + itemsize;
while (s < send) {
if (*s++ == '\n') {
- if (s == send) {
- itemsize--;
+ if (oneline) {
chopped = TRUE;
+ chophere = s;
+ break;
+ } else {
+ if (s == send) {
+ itemsize--;
+ chopped = TRUE;
+ } else
+ lines++;
}
- else
- lines++;
}
}
SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
if (targ_is_utf8)
SvUTF8_on(PL_formtarget);
- sv_catsv(PL_formtarget, sv);
+ if (oneline) {
+ SvCUR_set(sv, chophere - item);
+ sv_catsv(PL_formtarget, sv);
+ SvCUR_set(sv, itemsize);
+ } else
+ sv_catsv(PL_formtarget, sv);
if (chopped)
SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
}
break;
+ case FF_0DECIMAL:
+ arg = *fpc++;
+#if defined(USE_LONG_DOUBLE)
+ fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
+#else
+ fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
+#endif
+ goto ff_dec;
case FF_DECIMAL:
- /* If the field is marked with ^ and the value is undefined,
- blank it out. */
arg = *fpc++;
- if ((arg & 512) && !SvOK(sv)) {
- arg = fieldsize;
- while (arg--)
- *t++ = ' ';
- break;
- }
- gotsome = TRUE;
- value = SvNV(sv);
- /* Formats aren't yet marked for locales, so assume "yes". */
- {
- STORE_NUMERIC_STANDARD_SET_LOCAL();
#if defined(USE_LONG_DOUBLE)
- if (arg & 256) {
- sprintf(t, "%#*.*" PERL_PRIfldbl,
- (int) fieldsize, (int) arg & 255, value);
- } else {
- sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
- }
+ fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
#else
- if (arg & 256) {
- sprintf(t, "%#*.*f",
- (int) fieldsize, (int) arg & 255, value);
- } else {
- sprintf(t, "%*.0f",
- (int) fieldsize, value);
- }
+ fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
#endif
- RESTORE_NUMERIC_STANDARD();
- }
- t += fieldsize;
- break;
-
- case FF_0DECIMAL:
+ ff_dec:
/* If the field is marked with ^ and the value is undefined,
blank it out. */
- arg = *fpc++;
if ((arg & 512) && !SvOK(sv)) {
arg = fieldsize;
while (arg--)
}
gotsome = TRUE;
value = SvNV(sv);
+ /* overflow evidence */
+ if (num_overflow(value, fieldsize, arg)) {
+ arg = fieldsize;
+ while (arg--)
+ *t++ = '#';
+ break;
+ }
/* Formats aren't yet marked for locales, so assume "yes". */
{
STORE_NUMERIC_STANDARD_SET_LOCAL();
-#if defined(USE_LONG_DOUBLE)
- if (arg & 256) {
- sprintf(t, "%#0*.*" PERL_PRIfldbl,
- (int) fieldsize, (int) arg & 255, value);
-/* is this legal? I don't have long doubles */
- } else {
- sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
- }
-#else
- if (arg & 256) {
- sprintf(t, "%#0*.*f",
- (int) fieldsize, (int) arg & 255, value);
- } else {
- sprintf(t, "%0*.0f",
- (int) fieldsize, value);
- }
-#endif
+ sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
RESTORE_NUMERIC_STANDARD();
}
t += fieldsize;
break;
-
+
case FF_NEWLINE:
f++;
while (t-- > linemark && *t == ' ') ;
ENTER; /* enter outer scope */
SAVETMPS;
- /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
- SAVESPTR(DEFSV);
+ if (PL_op->op_private & OPpGREP_LEX)
+ SAVESPTR(PAD_SVl(PL_op->op_targ));
+ else
+ SAVE_DEFSV;
ENTER; /* enter inner scope */
SAVEVPTR(PL_curpm);
src = PL_stack_base[*PL_markstack_ptr];
SvTEMP_off(src);
- DEFSV = src;
+ if (PL_op->op_private & OPpGREP_LEX)
+ PAD_SVl(PL_op->op_targ) = src;
+ else
+ DEFSV = src;
PUTBACK;
if (PL_op->op_type == OP_MAPSTART)
(void)POPMARK; /* pop dst */
SP = PL_stack_base + POPMARK; /* pop original mark */
if (gimme == G_SCALAR) {
- dTARGET;
- XPUSHi(items);
+ if (PL_op->op_private & OPpGREP_LEX) {
+ SV* sv = sv_newmortal();
+ sv_setiv(sv, items);
+ PUSHs(sv);
+ }
+ else {
+ dTARGET;
+ XPUSHi(items);
+ }
}
else if (gimme == G_ARRAY)
SP += items;
/* set $_ to the new source item */
src = PL_stack_base[PL_markstack_ptr[-1]];
SvTEMP_off(src);
- DEFSV = src;
+ if (PL_op->op_private & OPpGREP_LEX)
+ PAD_SVl(PL_op->op_targ) = src;
+ else
+ DEFSV = src;
RETURNOP(cLOGOP->op_other);
}
}
}
+/* This code tries to decide if "$left .. $right" should use the
+ magical string increment, or if the range is numeric (we make
+ an exception for .."0" [#18165]). AMS 20021031. */
+
+#define RANGE_IS_NUMERIC(left,right) ( \
+ SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
+ SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
+ (looks_like_number(left) && SvPOKp(left) && *SvPVX(left) != '0' && \
+ looks_like_number(right)))
+
PP(pp_flop)
{
dSP;
if (SvGMAGICAL(right))
mg_get(right);
- /* This code tries to decide if "$left .. $right" should use the
- magical string increment, or if the range is numeric (we make
- an exception for .."0" [#18165]). AMS 20021031. */
-
- if (SvNIOKp(left) || !SvPOKp(left) ||
- SvNIOKp(right) || !SvPOKp(right) ||
- (looks_like_number(left) && *SvPVX(left) != '0' &&
- looks_like_number(right)))
- {
+ if (RANGE_IS_NUMERIC(left,right)) {
if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
DIE(aTHX_ "Range iterator outside integer range");
i = SvIV(left);
if (optype == OP_REQUIRE) {
char* msg = SvPVx(ERRSV, n_a);
+ SV *nsv = cx->blk_eval.old_namesv;
+ (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
+ &PL_sv_undef, 0);
DIE(aTHX_ "%sCompilation failed in require",
*msg ? msg : "Unknown error\n");
}
PUSHBLOCK(cx, CXt_SUB, SP);
PUSHSUB_DB(cx);
CvDEPTH(cv)++;
- (void)SvREFCNT_inc(cv);
PAD_SET_CUR(CvPADLIST(cv),1);
RETURNOP(CvSTART(cv));
}
cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
dPOPss;
- /* See comment in pp_flop() */
- if (SvNIOKp(sv) || !SvPOKp(sv) ||
- SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
- (looks_like_number(sv) && *SvPVX(sv) != '0' &&
- looks_like_number((SV*)cx->blk_loop.iterary)))
- {
+ if (RANGE_IS_NUMERIC(sv,(SV*)cx->blk_loop.iterary)) {
if (SvNV(sv) < IV_MIN ||
SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
DIE(aTHX_ "Range iterator outside integer range");
SAVETMPS;
/* switch to eval mode */
- if (PL_curcop == &PL_compiling) {
+ if (IN_PERL_COMPILETIME) {
SAVECOPSTASH_FREE(&PL_compiling);
CopSTASH_set(&PL_compiling, PL_curstash);
}
PL_hints &= HINT_UTF8;
/* we get here either during compilation, or via pp_regcomp at runtime */
- runtime = (PL_curcop != &PL_compiling);
+ runtime = IN_PERL_RUNTIME;
if (runtime)
runcv = find_runcv(NULL);
PL_op = &dummy;
PL_op->op_type = OP_ENTEREVAL;
PL_op->op_flags = 0; /* Avoid uninit warning. */
- PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
+ PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
PUSHEVAL(cx, 0, Nullgv);
if (runtime)
/* XXX DAPM do this properly one year */
*padp = (AV*)SvREFCNT_inc(PL_comppad);
LEAVE;
- if (PL_curcop == &PL_compiling)
+ if (IN_PERL_COMPILETIME)
PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
#ifdef OP_IN_REGISTER
op = PL_opsave;
sv_setpv(ERRSV,"");
if (yyparse() || PL_error_count || !PL_eval_root) {
SV **newsp; /* Used by POPBLOCK. */
- PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx = &cxstack[cxstack_ix];
I32 optype = 0; /* Might be reset by POPEVAL. */
STRLEN n_a;
LEAVE;
if (optype == OP_REQUIRE) {
char* msg = SvPVx(ERRSV, n_a);
+ SV *nsv = cx->blk_eval.old_namesv;
+ (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
+ &PL_sv_undef, 0);
DIE(aTHX_ "%sCompilation failed in require",
*msg ? msg : "Unknown error\n");
}
DIE(aTHX_ "Null filename used");
TAINT_PROPER("require");
if (PL_op->op_type == OP_REQUIRE &&
- (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
- *svp != &PL_sv_undef)
- RETPUSHYES;
+ (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
+ if (*svp != &PL_sv_undef)
+ RETPUSHYES;
+ else
+ DIE(aTHX_ "Compilation failed in require");
+ }
/* prepare to compile file */
PERL_SCRIPT_MODE);
}
}
+ SP--;
}
PUTBACK;
RETURNOP(retop);
}
-STATIC void
+STATIC OP *
S_doparseform(pTHX_ SV *sv)
{
STRLEN len;
U32 *linepc = 0;
register I32 arg;
bool ischop;
- int maxops = 2; /* FF_LINEMARK + FF_END) */
+ bool unchopnum = FALSE;
+ int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
if (len == 0)
Perl_croak(aTHX_ "Null picture in formline");
case ' ': case '\t':
skipspaces++;
continue;
-
- case '\n': case 0:
+ case 0:
+ if (s < send) {
+ skipspaces = 0;
+ continue;
+ } /* else FALL THROUGH */
+ case '\n':
arg = s - base;
skipspaces++;
arg -= skipspaces;
*fpc++ = FF_FETCH;
if (*s == '*') {
s++;
- *fpc++ = 0;
- *fpc++ = FF_LINEGLOB;
+ *fpc++ = 2; /* skip the @* or ^* */
+ if (ischop) {
+ *fpc++ = FF_LINESNGL;
+ *fpc++ = FF_CHOP;
+ } else
+ *fpc++ = FF_LINEGLOB;
}
else if (*s == '#' || (*s == '.' && s[1] == '#')) {
arg = ischop ? 512 : 0;
*fpc++ = s - base; /* fieldsize for FETCH */
*fpc++ = FF_DECIMAL;
*fpc++ = (U16)arg;
+ unchopnum |= ! ischop;
}
else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
arg = ischop ? 512 : 0;
*fpc++ = s - base; /* fieldsize for FETCH */
*fpc++ = FF_0DECIMAL;
*fpc++ = (U16)arg;
+ unchopnum |= ! ischop;
}
else {
I32 prespace = 0;
Safefree(fops);
sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
SvCOMPILED_on(sv);
+
+ if (unchopnum && repeat)
+ DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
+ return 0;
+}
+
+
+STATIC bool
+S_num_overflow(NV value, I32 fldsize, I32 frcsize)
+{
+ /* Can value be printed in fldsize chars, using %*.*f ? */
+ NV pwr = 1;
+ NV eps = 0.5;
+ bool res = FALSE;
+ int intsize = fldsize - (value < 0 ? 1 : 0);
+
+ if (frcsize & 256)
+ intsize--;
+ frcsize &= 255;
+ intsize -= frcsize;
+
+ while (intsize--) pwr *= 10.0;
+ while (frcsize--) eps /= 10.0;
+
+ if( value >= 0 ){
+ if (value + eps >= pwr)
+ res = TRUE;
+ } else {
+ if (value - eps <= -pwr)
+ res = TRUE;
+ }
+ return res;
}
static I32