/* pp_ctl.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
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)
}
/* copy the new items down to the destination list */
dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
- while (items-- > 0)
- *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
+ if (gimme == G_ARRAY) {
+ while (items-- > 0)
+ *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
+ }
+ else {
+ /* scalar context: we don't care about which values map returns
+ * (we use undef here). And so we certainly don't want to do mortal
+ * copies of meaningless values. */
+ while (items-- > 0) {
+ (void)POPs;
+ *dst-- = &PL_sv_undef;
+ }
+ }
}
LEAVE; /* exit inner scope */
(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);
}
an exception for .."0" [#18165]). AMS 20021031. */
#define RANGE_IS_NUMERIC(left,right) ( \
- SvNIOKp(left) || !SvPOKp(left) || \
- SvNIOKp(right) || !SvPOKp(right) || \
- (looks_like_number(left) && *SvPVX(left) != '0' && \
- looks_like_number(right)))
+ SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
+ SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
+ (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
+ looks_like_number(left)) && SvPOKp(left) && *SvPVX(left) != '0')) \
+ && (!SvOK(right) || looks_like_number(right))))
PP(pp_flop)
{
if (GIMME == G_ARRAY) {
dPOPPOPssrl;
- register I32 i, j;
+ register IV i, j;
register SV *sv;
- I32 max;
+ IV max;
if (SvGMAGICAL(left))
mg_get(left);
mg_get(right);
if (RANGE_IS_NUMERIC(left,right)) {
- if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
+ if ((SvOK(left) && SvNV(left) < IV_MIN) ||
+ (SvOK(right) && SvNV(right) > IV_MAX))
DIE(aTHX_ "Range iterator outside integer range");
i = SvIV(left);
max = SvIV(right);
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;
- 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");
- cx->blk_loop.iterix = SvIV(sv);
- cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
+ SV *right = (SV*)cx->blk_loop.iterary;
+ if (RANGE_IS_NUMERIC(sv,right)) {
+ if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
+ (SvOK(right) && SvNV(right) >= IV_MAX))
+ DIE(aTHX_ "Range iterator outside integer range");
+ cx->blk_loop.iterix = SvIV(sv);
+ cx->blk_loop.itermax = SvIV(right);
}
- else
+ else {
+ STRLEN n_a;
cx->blk_loop.iterlval = newSVsv(sv);
+ (void) SvPV_force(cx->blk_loop.iterlval,n_a);
+ (void) SvPV(right,n_a);
+ }
}
}
else {
TOPBLOCK(cx);
oldsave = PL_scopestack[PL_scopestack_ix - 1];
LEAVE_SCOPE(oldsave);
+ FREETMPS;
return cx->blk_loop.redo_op;
}
char *label;
int do_dump = (PL_op->op_type == OP_DUMP);
static char must_have_label[] = "goto must have label";
+ AV *oldav = Nullav;
label = 0;
if (PL_op->op_flags & OPf_STACKED) {
GvAV(PL_defgv) = cx->blk_sub.savearray;
/* abandon @_ if it got reified */
if (AvREAL(av)) {
- (void)sv_2mortal((SV*)av); /* delay until return */
+ oldav = av; /* delay until return */
av = newAV();
av_extend(av, items-1);
AvFLAGS(av) = AVf_REIFY;
/* Now do some callish stuff. */
SAVETMPS;
+ /* For reified @_, delay freeing till return from new sub */
+ if (oldav)
+ SAVEFREESV((SV*)oldav);
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
if (CvXSUB(cv)) {
#ifdef PERL_XSUB_OLDSTYLE
#else
SAVEVPTR(PL_op);
#endif
- PL_hints &= HINT_UTF8;
/* we get here either during compilation, or via pp_regcomp at runtime */
runtime = IN_PERL_RUNTIME;
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
projects / p5sagit/p5-mst-13.2.git / blobdiff