/* pp_ctl.c
*
- * Copyright (c) 1991-2002, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 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.
#include "perl.h"
#ifndef WORD_ALIGN
-#define WORD_ALIGN sizeof(U16)
+#define WORD_ALIGN sizeof(U32)
#endif
#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
/* 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;
}
tmpstr = POPs;
/* prevent recompiling under /o and ithreads. */
-#if defined(USE_ITHREADS) || defined(USE_5005THREADS)
+#if defined(USE_ITHREADS)
if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
RETURN;
#endif
memNE(PM_GETRE(pm)->precomp, t, len))
{
if (PM_GETRE(pm)) {
- ReREFCNT_dec(PM_GETRE(pm));
+ ReREFCNT_dec(PM_GETRE(pm));
PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
}
if (PL_op->op_flags & OPf_SPECIAL)
/* XXX runtime compiled output needs to move to the pad */
if (pm->op_pmflags & PMf_KEEP) {
pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
-#if !defined(USE_ITHREADS) && !defined(USE_5005THREADS)
+#if !defined(USE_ITHREADS)
/* XXX can't change the optree at runtime either */
cLOGOP->op_first->op_next = PL_op->op_next;
#endif
register char *m = cx->sb_m;
char *orig = cx->sb_orig;
register REGEXP *rx = cx->sb_rx;
+ SV *nsv = Nullsv;
+ REGEXP *old = PM_GETRE(pm);
+ if(old != rx) {
+ if(old)
+ ReREFCNT_dec(old);
+ PM_SETRE(pm,rx);
+ }
rxres_restore(&cx->sb_rxres, rx);
- PL_reg_match_utf8 = SvUTF8(cx->sb_targ) ? 1 : 0;
+ RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
if (cx->sb_iters++) {
I32 saviters = cx->sb_iters;
{
SV *targ = cx->sb_targ;
- sv_catpvn(dstr, s, cx->sb_strend - s);
+ if (DO_UTF8(dstr) && !SvUTF8(targ))
+ sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
+ else
+ sv_catpvn(dstr, s, cx->sb_strend - s);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
- (void)SvOOK_off(targ);
- Safefree(SvPVX(targ));
+#ifdef PERL_COPY_ON_WRITE
+ 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));
sv_free(dstr);
TAINT_IF(cx->sb_rxtainted & 1);
- PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
+ PUSHs(sv_2mortal(newSViv(saviters - 1)));
(void)SvPOK_only_UTF8(targ);
TAINT_IF(cx->sb_rxtainted);
SvTAINT(targ);
LEAVE_SCOPE(cx->sb_oldsave);
+ ReREFCNT_dec(rx);
POPSUBST(cx);
RETURNOP(pm->op_next);
}
cx->sb_strend = s + (cx->sb_strend - m);
}
cx->sb_m = m = rx->startp[0] + orig;
- if (m > s)
- sv_catpvn(dstr, s, m-s);
+ if (m > s) {
+ if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
+ sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
+ else
+ sv_catpvn(dstr, s, m-s);
+ }
cx->sb_s = rx->endp[0] + orig;
{ /* Update the pos() information. */
SV *sv = cx->sb_targ;
sv_pos_b2u(sv, &i);
mg->mg_len = i;
}
+ if (old != rx)
+ ReREFCNT_inc(rx);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
rxres_save(&cx->sb_rxres, rx);
RETURNOP(pm->op_pmreplstart);
U32 i;
if (!p || p[1] < rx->nparens) {
+#ifdef PERL_COPY_ON_WRITE
+ i = 7 + rx->nparens * 2;
+#else
i = 6 + rx->nparens * 2;
+#endif
if (!p)
New(501, p, i, UV);
else
*p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
RX_MATCH_COPIED_off(rx);
+#ifdef PERL_COPY_ON_WRITE
+ *p++ = PTR2UV(rx->saved_copy);
+ rx->saved_copy = Nullsv;
+#endif
+
*p++ = rx->nparens;
*p++ = PTR2UV(rx->subbeg);
UV *p = (UV*)*rsp;
U32 i;
- if (RX_MATCH_COPIED(rx))
- Safefree(rx->subbeg);
+ RX_MATCH_COPY_FREE(rx);
RX_MATCH_COPIED_set(rx, *p);
*p++ = 0;
+#ifdef PERL_COPY_ON_WRITE
+ if (rx->saved_copy)
+ SvREFCNT_dec (rx->saved_copy);
+ rx->saved_copy = INT2PTR(SV*,*p);
+ *p++ = 0;
+#endif
+
rx->nparens = *p++;
rx->subbeg = INT2PTR(char*,*p++);
if (p) {
Safefree(INT2PTR(char*,*p));
+#ifdef PERL_COPY_ON_WRITE
+ if (p[1]) {
+ SvREFCNT_dec (INT2PTR(SV*,p[1]));
+ }
+#endif
Safefree(p);
*rsp = Null(void*);
}
{
dSP; dMARK; dORIGMARK;
register SV *tmpForm = *++MARK;
- register U16 *fpc;
+ register U32 *fpc;
register char *t;
register char *f;
register char *s;
bool gotsome = FALSE;
STRLEN len;
STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
- bool item_is_utf = FALSE;
+ 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))
+ targ_is_utf8 = TRUE;
t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
t += len;
f = SvPV(tmpForm, len);
/* need to jump to the next word */
s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
- fpc = (U16*)s;
+ fpc = (U32*)s;
for (;;) {
DEBUG_f( {
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);
case FF_LITERAL:
arg = *fpc++;
+ if (targ_is_utf8 && !SvUTF8(tmpForm)) {
+ SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ *t = '\0';
+ sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
+ t = SvEND(PL_formtarget);
+ break;
+ }
+ if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
+ SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ *t = '\0';
+ sv_utf8_upgrade(PL_formtarget);
+ SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
+ t = SvEND(PL_formtarget);
+ targ_is_utf8 = TRUE;
+ }
while (arg--)
*t++ = *f++;
break;
break;
s++;
}
- item_is_utf = TRUE;
+ item_is_utf8 = TRUE;
itemsize = s - item;
sv_pos_b2u(sv, &itemsize);
break;
}
}
- item_is_utf = FALSE;
+ item_is_utf8 = FALSE;
if (itemsize > fieldsize)
itemsize = fieldsize;
send = chophere = s + itemsize;
while (s < send) {
if (*s == '\r') {
itemsize = s - item;
+ chophere = s;
break;
}
if (*s++ & ~31)
itemsize = chophere - item;
sv_pos_b2u(sv, &itemsize);
}
- item_is_utf = TRUE;
+ item_is_utf8 = TRUE;
break;
}
}
- item_is_utf = FALSE;
+ item_is_utf8 = FALSE;
if (itemsize <= fieldsize) {
send = chophere = s + itemsize;
while (s < send) {
if (*s == '\r') {
itemsize = s - item;
+ chophere = s;
break;
}
if (*s++ & ~31)
case FF_ITEM:
arg = itemsize;
s = item;
- if (item_is_utf) {
+ if (item_is_utf8) {
+ if (!targ_is_utf8) {
+ SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ *t = '\0';
+ sv_utf8_upgrade(PL_formtarget);
+ SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
+ t = SvEND(PL_formtarget);
+ targ_is_utf8 = TRUE;
+ }
while (arg--) {
if (UTF8_IS_CONTINUED(*s)) {
STRLEN skip = UTF8SKIP(s);
}
break;
}
+ if (targ_is_utf8 && !item_is_utf8) {
+ SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ *t = '\0';
+ sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
+ for (; t < SvEND(PL_formtarget); t++) {
+#ifdef EBCDIC
+ int ch = *t;
+ if (iscntrl(ch))
+#else
+ if (!(*t & ~31))
+#endif
+ *t = ' ';
+ }
+ break;
+ }
while (arg--) {
#ifdef EBCDIC
int ch = *t++ = *s++;
s++;
}
sv_chop(sv,s);
+ 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;
- item_is_utf = FALSE; /* XXX is this correct? */
+ if ((item_is_utf8 = DO_UTF8(sv)))
+ itemsize = sv_len_utf8(sv);
if (itemsize) {
+ bool chopped = FALSE;
gotsome = TRUE;
- send = s + itemsize;
+ send = s + len;
+ chophere = s + itemsize;
while (s < send) {
if (*s++ == '\n') {
- if (s == send)
- itemsize--;
- else
- lines++;
+ if (oneline) {
+ chopped = TRUE;
+ chophere = s;
+ break;
+ } else {
+ if (s == send) {
+ itemsize--;
+ chopped = TRUE;
+ } else
+ lines++;
+ }
}
}
SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
- sv_catpvn(PL_formtarget, item, itemsize);
+ if (targ_is_utf8)
+ SvUTF8_on(PL_formtarget);
+ 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);
t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
+ if (item_is_utf8)
+ targ_is_utf8 = TRUE;
}
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 == ' ') ;
if (strnEQ(linemark, linemark - arg, arg))
DIE(aTHX_ "Runaway format");
}
+ if (targ_is_utf8)
+ SvUTF8_on(PL_formtarget);
FmLINES(PL_formtarget) = lines;
SP = ORIGMARK;
RETURNOP(cLISTOP->op_first);
case FF_END:
*t = '\0';
SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ if (targ_is_utf8)
+ SvUTF8_on(PL_formtarget);
FmLINES(PL_formtarget) += lines;
SP = ORIGMARK;
RETPUSHYES;
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)
PP(pp_mapwhile)
{
dSP;
+ I32 gimme = GIMME_V;
I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
I32 count;
I32 shift;
++PL_markstack_ptr[-1];
/* if there are new items, push them into the destination list */
- if (items) {
+ if (items && gimme != G_VOID) {
/* might need to make room back there first */
if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
/* XXX this implementation is very pessimal because the stack
}
/* copy the new items down to the destination list */
dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
- while (items--)
+ while (items-- > 0)
*dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
}
LEAVE; /* exit inner scope */
/* All done yet? */
if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
- I32 gimme = GIMME_V;
(void)POPMARK; /* pop top */
LEAVE; /* exit outer scope */
/* 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);
- if (SvNIOKp(left) || !SvPOKp(left) ||
- SvNIOKp(right) || !SvPOKp(right) ||
- (looks_like_number(left) && *SvPVX(left) != '0' &&
- looks_like_number(right) && *SvPVX(right) != '0'))
- {
+ 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);
/* Control. */
+static char *context_name[] = {
+ "pseudo-block",
+ "subroutine",
+ "eval",
+ "loop",
+ "substitution",
+ "block",
+ "format"
+};
+
STATIC I32
S_dopoptolabel(pTHX_ char *label)
{
cx = &cxstack[i];
switch (CxTYPE(cx)) {
case CXt_SUBST:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
- OP_NAME(PL_op));
- break;
case CXt_SUB:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
- OP_NAME(PL_op));
- break;
case CXt_FORMAT:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
- OP_NAME(PL_op));
- break;
case CXt_EVAL:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
- OP_NAME(PL_op));
- break;
case CXt_NULL:
if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
- OP_NAME(PL_op));
- return -1;
+ Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
+ context_name[CxTYPE(cx)], OP_NAME(PL_op));
+ if (CxTYPE(cx) == CXt_NULL)
+ return -1;
+ break;
case CXt_LOOP:
if (!cx->blk_loop.label ||
strNE(label, cx->blk_loop.label) ) {
cx = &cxstack[i];
switch (CxTYPE(cx)) {
case CXt_SUBST:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
- OP_NAME(PL_op));
- break;
case CXt_SUB:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
- OP_NAME(PL_op));
- break;
case CXt_FORMAT:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
- OP_NAME(PL_op));
- break;
case CXt_EVAL:
- if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
- OP_NAME(PL_op));
- break;
case CXt_NULL:
if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
- OP_NAME(PL_op));
- return -1;
+ Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
+ context_name[CxTYPE(cx)], OP_NAME(PL_op));
+ if ((CxTYPE(cx)) == CXt_NULL)
+ return -1;
+ break;
case CXt_LOOP:
DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
return i;
Perl_die_where(pTHX_ char *message, STRLEN msglen)
{
STRLEN n_a;
- IO *io;
- MAGIC *mg;
if (PL_in_eval) {
I32 cxix;
sv_setpvn(ERRSV, message, msglen);
}
}
- else
- message = SvPVx(ERRSV, msglen);
while ((cxix = dopoptoeval(cxstack_ix)) < 0
&& PL_curstackinfo->si_prev)
POPBLOCK(cx,PL_curpm);
if (CxTYPE(cx) != CXt_EVAL) {
+ if (!message)
+ message = SvPVx(ERRSV, msglen);
PerlIO_write(Perl_error_log, "panic: die ", 11);
PerlIO_write(Perl_error_log, message, msglen);
my_exit(1);
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");
}
if (!message)
message = SvPVx(ERRSV, msglen);
- /* if STDERR is tied, print to it instead */
- if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
- && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
- dSP; ENTER;
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)io, mg));
- XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
- PUTBACK;
- call_method("PRINT", G_SCALAR);
- LEAVE;
- }
- else {
-#ifdef USE_SFIO
- /* SFIO can really mess with your errno */
- int e = errno;
-#endif
- PerlIO *serr = Perl_error_log;
-
- PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
- (void)PerlIO_flush(serr);
-#ifdef USE_SFIO
- errno = e;
-#endif
- }
+ write_to_stderr(message, msglen);
my_failure_exit();
/* NOTREACHED */
return 0;
(old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
mask = newSVpvn(WARN_NONEstring, WARNsize) ;
else if (old_warnings == pWARN_ALL ||
- (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
- mask = newSVpvn(WARN_ALLstring, WARNsize) ;
+ (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
+ /* Get the bit mask for $warnings::Bits{all}, because
+ * it could have been extended by warnings::register */
+ SV **bits_all;
+ HV *bits = get_hv("warnings::Bits", FALSE);
+ if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
+ mask = newSVsv(*bits_all);
+ }
+ else {
+ mask = newSVpvn(WARN_ALLstring, WARNsize) ;
+ }
+ }
else
mask = newSVsv(old_warnings);
PUSHs(sv_2mortal(mask));
return NORMAL;
}
+/* like pp_nextstate, but used instead when the debugger is active */
+
PP(pp_dbstate)
{
PL_curcop = (COP*)PL_op;
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
- if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
+ if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
+ || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
{
dSP;
register CV *cv;
push_return(PL_op->op_next);
PUSHBLOCK(cx, CXt_SUB, SP);
- PUSHSUB(cx);
+ PUSHSUB_DB(cx);
CvDEPTH(cv)++;
- (void)SvREFCNT_inc(cv);
- SAVEVPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
+ PAD_SET_CUR(CvPADLIST(cv),1);
RETURNOP(CvSTART(cv));
}
else
ENTER;
SAVETMPS;
-#ifdef USE_5005THREADS
- if (PL_op->op_flags & OPf_SPECIAL) {
- svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
- SAVEGENERICSV(*svp);
- *svp = NEWSV(0,0);
- }
- else
-#endif /* USE_5005THREADS */
if (PL_op->op_targ) {
+ if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
+ SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
+ SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
+ SVs_PADSTALE, SVs_PADSTALE);
+ }
#ifndef USE_ITHREADS
- svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
+ svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
SAVESPTR(*svp);
#else
SAVEPADSV(PL_op->op_targ);
cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
dPOPss;
- 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) &&
- *SvPVX(cx->blk_loop.iterary) != '0'))
- {
+ 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");
switch (CxTYPE(cx)) {
case CXt_SUB:
popsub2 = TRUE;
+ cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
break;
case CXt_EVAL:
if (!(PL_in_eval & EVAL_KEEPERR))
/* Unassume the success we assumed earlier. */
SV *nsv = cx->blk_eval.old_namesv;
(void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
- DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
+ DIE(aTHX_ "%"SVf" did not return a true value", nsv);
}
break;
case CXt_FORMAT:
}
PL_stack_sp = newsp;
+ LEAVE;
/* Stack values are safe: */
if (popsub2) {
+ cxstack_ix--;
POPSUB(cx,sv); /* release CV and @_ ... */
}
else
sv = Nullsv;
PL_curpm = newpm; /* ... and pop $1 et al */
- LEAVE;
LEAVESUB(sv);
if (clear_errsv)
sv_setpv(ERRSV,"");
dounwind(cxix);
POPBLOCK(cx,newpm);
+ cxstack_ix++; /* temporarily protect top context */
mark = newsp;
switch (CxTYPE(cx)) {
case CXt_LOOP:
SP = newsp;
PUTBACK;
+ LEAVE;
+ cxstack_ix--;
/* Stack values are safe: */
switch (pop2) {
case CXt_LOOP:
}
PL_curpm = newpm; /* ... and pop $1 et al */
- LEAVE;
LEAVESUB(sv);
return nextop;
}
if (o->op_type == OP_LEAVE ||
o->op_type == OP_SCOPE ||
o->op_type == OP_LEAVELOOP ||
+ o->op_type == OP_LEAVESUB ||
o->op_type == OP_LEAVETRY)
{
*ops++ = cUNOPo->op_first;
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if (kid == PL_lastgotoprobe)
continue;
- if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
- (ops == opstack ||
- (ops[-1]->op_type != OP_NEXTSTATE &&
- ops[-1]->op_type != OP_DBSTATE)))
- *ops++ = kid;
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
+ if (ops == opstack)
+ *ops++ = kid;
+ else if (ops[-1]->op_type == OP_NEXTSTATE ||
+ ops[-1]->op_type == OP_DBSTATE)
+ ops[-1] = kid;
+ else
+ *ops++ = kid;
+ }
if ((o = dofindlabel(kid, label, ops, oplimit)))
return o;
}
goto retry;
tmpstr = sv_newmortal();
gv_efullname3(tmpstr, gv, Nullch);
- DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
+ DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
}
DIE(aTHX_ "Goto undefined subroutine");
}
/* First do some returnish stuff. */
+ SvREFCNT_inc(cv); /* avoid premature free during unwind */
+ FREETMPS;
cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
DIE(aTHX_ "Can't goto subroutine outside a subroutine");
EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
Copy(AvARRAY(av), PL_stack_sp, items, SV*);
PL_stack_sp += items;
-#ifndef USE_5005THREADS
SvREFCNT_dec(GvAV(PL_defgv));
GvAV(PL_defgv) = cx->blk_sub.savearray;
-#endif /* USE_5005THREADS */
/* abandon @_ if it got reified */
if (AvREAL(av)) {
(void)sv_2mortal((SV*)av); /* delay until return */
av = newAV();
av_extend(av, items-1);
AvFLAGS(av) = AVf_REIFY;
- PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
+ PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
}
+ else
+ CLEAR_ARGARRAY(av);
}
else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
AV* av;
-#ifdef USE_5005THREADS
- av = (AV*)PL_curpad[0];
-#else
av = GvAV(PL_defgv);
-#endif
items = AvFILLp(av) + 1;
PL_stack_sp++;
EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
/* Now do some callish stuff. */
SAVETMPS;
+ SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
if (CvXSUB(cv)) {
#ifdef PERL_XSUB_OLDSTYLE
if (CvOLDSTYLE(cv)) {
}
else {
AV* padlist = CvPADLIST(cv);
- SV** svp = AvARRAY(padlist);
if (CxTYPE(cx) == CXt_EVAL) {
PL_in_eval = cx->blk_eval.old_in_eval;
PL_eval_root = cx->blk_eval.old_eval_root;
}
cx->blk_sub.cv = cv;
cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
+
CvDEPTH(cv)++;
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
- else { /* save temporaries on recursion? */
+ else {
if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
sub_crush_depth(cv);
- if (CvDEPTH(cv) > AvFILLp(padlist)) {
- AV *newpad = newAV();
- SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
- I32 ix = AvFILLp((AV*)svp[1]);
- I32 names_fill = AvFILLp((AV*)svp[0]);
- svp = AvARRAY(svp[0]);
- for ( ;ix > 0; ix--) {
- if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
- char *name = SvPVX(svp[ix]);
- if ((SvFLAGS(svp[ix]) & SVf_FAKE)
- || *name == '&')
- {
- /* outer lexical or anon code */
- av_store(newpad, ix,
- SvREFCNT_inc(oldpad[ix]) );
- }
- else { /* our own lexical */
- if (*name == '@')
- av_store(newpad, ix, sv = (SV*)newAV());
- else if (*name == '%')
- av_store(newpad, ix, sv = (SV*)newHV());
- else
- av_store(newpad, ix, sv = NEWSV(0,0));
- SvPADMY_on(sv);
- }
- }
- else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
- av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
- }
- else {
- av_store(newpad, ix, sv = NEWSV(0,0));
- SvPADTMP_on(sv);
- }
- }
- if (cx->blk_sub.hasargs) {
- AV* av = newAV();
- av_extend(av, 0);
- av_store(newpad, 0, (SV*)av);
- AvFLAGS(av) = AVf_REIFY;
- }
- av_store(padlist, CvDEPTH(cv), (SV*)newpad);
- AvFILLp(padlist) = CvDEPTH(cv);
- svp = AvARRAY(padlist);
- }
+ pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
}
-#ifdef USE_5005THREADS
- if (!cx->blk_sub.hasargs) {
- AV* av = (AV*)PL_curpad[0];
-
- items = AvFILLp(av) + 1;
- if (items) {
- /* Mark is at the end of the stack. */
- EXTEND(SP, items);
- Copy(AvARRAY(av), SP + 1, items, SV*);
- SP += items;
- PUTBACK ;
- }
- }
-#endif /* USE_5005THREADS */
- SAVEVPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
-#ifndef USE_5005THREADS
+ PAD_SET_CUR(padlist, CvDEPTH(cv));
if (cx->blk_sub.hasargs)
-#endif /* USE_5005THREADS */
{
- AV* av = (AV*)PL_curpad[0];
+ AV* av = (AV*)PAD_SVl(0);
SV** ary;
-#ifndef USE_5005THREADS
cx->blk_sub.savearray = GvAV(PL_defgv);
GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
-#endif /* USE_5005THREADS */
- cx->blk_sub.oldcurpad = PL_curpad;
+ CX_CURPAD_SAVE(cx->blk_sub);
cx->blk_sub.argarray = av;
++mark;
CV *gotocv;
if (PERLDB_SUB_NN) {
- SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
+ (void)SvUPGRADE(sv, SVt_PVIV);
+ (void)SvIOK_on(sv);
+ SAVEIV(SvIVX(sv));
+ SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
} else {
save_item(sv);
gv_efullname3(sv, CvGV(cv), Nullch);
if (label && *label) {
OP *gotoprobe = 0;
bool leaving_eval = FALSE;
+ bool in_block = FALSE;
PERL_CONTEXT *last_eval_cx = 0;
/* find label */
switch (CxTYPE(cx)) {
case CXt_EVAL:
leaving_eval = TRUE;
- if (CxREALEVAL(cx)) {
+ if (!CxTRYBLOCK(cx)) {
gotoprobe = (last_eval_cx ?
last_eval_cx->blk_eval.old_eval_root :
PL_eval_root);
case CXt_SUBST:
continue;
case CXt_BLOCK:
- if (ix)
+ if (ix) {
gotoprobe = cx->blk_oldcop->op_sibling;
- else
+ in_block = TRUE;
+ } else
gotoprobe = PL_main_root;
break;
case CXt_SUB:
if (*enterops && enterops[1]) {
OP *oldop = PL_op;
- for (ix = 1; enterops[ix]; ix++) {
+ ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
+ for (; enterops[ix]; ix++) {
PL_op = enterops[ix];
/* Eventually we may want to stack the needed arguments
* for each op. For now, we punt on the hard ones. */
}
OP *
-Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
+Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
/* sv Text to convert to OP tree. */
/* startop op_free() this to undo. */
/* code Short string id of the caller. */
char tbuf[TYPE_DIGITS(long) + 12 + 10];
char *tmpbuf = tbuf;
char *safestr;
+ int runtime;
+ CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
ENTER;
lex_start(sv);
SAVETMPS;
/* switch to eval mode */
- if (PL_curcop == &PL_compiling) {
+ if (IN_PERL_COMPILETIME) {
SAVECOPSTASH_FREE(&PL_compiling);
CopSTASH_set(&PL_compiling, PL_curstash);
}
#endif
PL_hints &= HINT_UTF8;
+ /* we get here either during compilation, or via pp_regcomp at runtime */
+ 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);
- rop = doeval(G_SCALAR, startop);
+
+ if (runtime)
+ rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
+ else
+ rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
(*startop)->op_type = OP_NULL;
(*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
lex_end();
- *avp = (AV*)SvREFCNT_inc(PL_comppad);
+ /* 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;
return rop;
}
+
+/*
+=for apidoc find_runcv
+
+Locate the CV corresponding to the currently executing sub or eval.
+If db_seqp is non_null, skip CVs that are in the DB package and populate
+*db_seqp with the cop sequence number at the point that the DB:: code was
+entered. (allows debuggers to eval in the scope of the breakpoint rather
+than in in the scope of the debuger itself).
+
+=cut
+*/
+
+CV*
+Perl_find_runcv(pTHX_ U32 *db_seqp)
+{
+ I32 ix;
+ PERL_SI *si;
+ PERL_CONTEXT *cx;
+
+ if (db_seqp)
+ *db_seqp = PL_curcop->cop_seq;
+ for (si = PL_curstackinfo; si; si = si->si_prev) {
+ for (ix = si->si_cxix; ix >= 0; ix--) {
+ cx = &(si->si_cxstack[ix]);
+ if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
+ CV *cv = cx->blk_sub.cv;
+ /* skip DB:: code */
+ if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
+ *db_seqp = cx->blk_oldcop->cop_seq;
+ continue;
+ }
+ return cv;
+ }
+ else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
+ return PL_compcv;
+ }
+ }
+ return PL_main_cv;
+}
+
+
+/* Compile a require/do, an eval '', or a /(?{...})/.
+ * In the last case, startop is non-null, and contains the address of
+ * a pointer that should be set to the just-compiled code.
+ * outside is the lexically enclosing CV (if any) that invoked us.
+ */
+
/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
STATIC OP *
-S_doeval(pTHX_ int gimme, OP** startop)
+S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
{
dSP;
OP *saveop = PL_op;
- CV *caller;
- AV* comppadlist;
- I32 i;
PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
PUSHMARK(SP);
- /* set up a scratch pad */
-
- SAVEI32(PL_padix);
- SAVEVPTR(PL_curpad);
- SAVESPTR(PL_comppad);
- SAVESPTR(PL_comppad_name);
- SAVEI32(PL_comppad_name_fill);
- SAVEI32(PL_min_intro_pending);
- SAVEI32(PL_max_intro_pending);
-
- caller = PL_compcv;
- for (i = cxstack_ix - 1; i >= 0; i--) {
- PERL_CONTEXT *cx = &cxstack[i];
- if (CxTYPE(cx) == CXt_EVAL)
- break;
- else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- caller = cx->blk_sub.cv;
- break;
- }
- }
-
SAVESPTR(PL_compcv);
PL_compcv = (CV*)NEWSV(1104,0);
sv_upgrade((SV *)PL_compcv, SVt_PVCV);
assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
-#ifdef USE_5005THREADS
- CvOWNER(PL_compcv) = 0;
- New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
- MUTEX_INIT(CvMUTEXP(PL_compcv));
-#endif /* USE_5005THREADS */
-
- PL_comppad = newAV();
- av_push(PL_comppad, Nullsv);
- PL_curpad = AvARRAY(PL_comppad);
- PL_comppad_name = newAV();
- PL_comppad_name_fill = 0;
- PL_min_intro_pending = 0;
- PL_padix = 0;
-#ifdef USE_5005THREADS
- av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
- PL_curpad[0] = (SV*)newAV();
- SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
-#endif /* USE_5005THREADS */
-
- comppadlist = newAV();
- AvREAL_off(comppadlist);
- av_store(comppadlist, 0, (SV*)PL_comppad_name);
- av_store(comppadlist, 1, (SV*)PL_comppad);
- CvPADLIST(PL_compcv) = comppadlist;
-
- if (!saveop ||
- (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
- {
- CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
- }
+ CvOUTSIDE_SEQ(PL_compcv) = seq;
+ CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
+
+ /* set up a scratch pad */
+
+ CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
+
SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
else
sv_setpv(ERRSV,"");
if (yyparse() || PL_error_count || !PL_eval_root) {
- SV **newsp;
- I32 gimme;
- PERL_CONTEXT *cx;
+ SV **newsp; /* Used by POPBLOCK. */
+ 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");
}
Perl_croak(aTHX_ "%sCompilation failed in regexp",
(*msg ? msg : "Unknown error\n"));
}
-#ifdef USE_5005THREADS
- MUTEX_LOCK(&PL_eval_mutex);
- PL_eval_owner = 0;
- COND_SIGNAL(&PL_eval_cond);
- MUTEX_UNLOCK(&PL_eval_mutex);
-#endif /* USE_5005THREADS */
+ else {
+ char* msg = SvPVx(ERRSV, n_a);
+ if (!*msg) {
+ sv_setpv(ERRSV, "Compilation error");
+ }
+ }
RETPUSHUNDEF;
}
CopLINE_set(&PL_compiling, 0);
if (startop) {
*startop = PL_eval_root;
- SvREFCNT_dec(CvOUTSIDE(PL_compcv));
- CvOUTSIDE(PL_compcv) = Nullcv;
} else
SAVEFREEOP(PL_eval_root);
- if (gimme & G_VOID)
+
+ /* Set the context for this new optree.
+ * If the last op is an OP_REQUIRE, force scalar context.
+ * Otherwise, propagate the context from the eval(). */
+ if (PL_eval_root->op_type == OP_LEAVEEVAL
+ && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
+ && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
+ == OP_REQUIRE)
+ scalar(PL_eval_root);
+ else if (gimme & G_VOID)
scalarvoid(PL_eval_root);
else if (gimme & G_ARRAY)
list(PL_eval_root);
SP = PL_stack_base + POPMARK; /* pop original mark */
PL_op = saveop; /* The caller may need it. */
PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
-#ifdef USE_5005THREADS
- MUTEX_LOCK(&PL_eval_mutex);
- PL_eval_owner = 0;
- COND_SIGNAL(&PL_eval_cond);
- MUTEX_UNLOCK(&PL_eval_mutex);
-#endif /* USE_5005THREADS */
RETURNOP(PL_eval_start);
}
STATIC PerlIO *
-S_doopen_pmc(pTHX_ const char *name, const char *mode)
+S_doopen_pm(pTHX_ const char *name, const char *mode)
{
+#ifndef PERL_DISABLE_PMC
STRLEN namelen = strlen(name);
PerlIO *fp;
fp = PerlIO_open(name, mode);
}
return fp;
+#else
+ return PerlIO_open(name, mode);
+#endif /* !PERL_DISABLE_PMC */
}
PP(pp_require)
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 */
if (path_is_absolute(name)) {
tryname = name;
- tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
+ tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
}
#ifdef MACOS_TRADITIONAL
if (!tryrsfp) {
MacPerl_CanonDir(name, newname, 1);
if (path_is_absolute(newname)) {
tryname = newname;
- tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
+ tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
}
}
#endif
PERL_SCRIPT_MODE);
}
}
+ SP--;
}
PUTBACK;
#endif
TAINT_PROPER("require");
tryname = SvPVX(namesv);
- tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
+ tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
if (tryrsfp) {
if (tryname[0] == '.' && tryname[1] == '/')
tryname += 2;
RETPUSHUNDEF;
}
else
- SETERRNO(0, SS$_NORMAL);
+ SETERRNO(0, SS_NORMAL);
/* Assume success here to prevent recursive requirement. */
len = strlen(name);
CopLINE_set(&PL_compiling, 0);
PUTBACK;
-#ifdef USE_5005THREADS
- MUTEX_LOCK(&PL_eval_mutex);
- if (PL_eval_owner && PL_eval_owner != thr)
- while (PL_eval_owner)
- COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
- PL_eval_owner = thr;
- MUTEX_UNLOCK(&PL_eval_mutex);
-#endif /* USE_5005THREADS */
/* Store and reset encoding. */
encoding = PL_encoding;
PL_encoding = Nullsv;
- op = DOCATCH(doeval(gimme, NULL));
+ op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
/* Restore encoding. */
PL_encoding = encoding;
char *safestr;
STRLEN len;
OP *ret;
+ CV* runcv;
+ U32 seq;
if (!SvPV(sv,len))
RETPUSHUNDEF;
PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
SAVEFREESV(PL_compiling.cop_io);
}
+ /* special case: an eval '' executed within the DB package gets lexically
+ * placed in the first non-DB CV rather than the current CV - this
+ * allows the debugger to execute code, find lexicals etc, in the
+ * scope of the code being debugged. Passing &seq gets find_runcv
+ * to do the dirty work for us */
+ runcv = find_runcv(&seq);
push_return(PL_op->op_next);
PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
if (PERLDB_LINE && PL_curstash != PL_debstash)
save_lines(CopFILEAV(&PL_compiling), PL_linestr);
PUTBACK;
-#ifdef USE_5005THREADS
- MUTEX_LOCK(&PL_eval_mutex);
- if (PL_eval_owner && PL_eval_owner != thr)
- while (PL_eval_owner)
- COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
- PL_eval_owner = thr;
- MUTEX_UNLOCK(&PL_eval_mutex);
-#endif /* USE_5005THREADS */
- ret = doeval(gimme, NULL);
+ ret = doeval(gimme, NULL, runcv, seq);
if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
&& ret != PL_op->op_next) { /* Successive compilation. */
strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
/* Unassume the success we assumed earlier. */
SV *nsv = cx->blk_eval.old_namesv;
(void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
- retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
+ retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
/* die_where() did LEAVE, or we won't be here */
}
else {
RETURNOP(retop);
}
-STATIC void
+STATIC OP *
S_doparseform(pTHX_ SV *sv)
{
STRLEN len;
bool noblank = FALSE;
bool repeat = FALSE;
bool postspace = FALSE;
- U16 *fops;
- register U16 *fpc;
- U16 *linepc = 0;
+ U32 *fops;
+ register U32 *fpc;
+ U32 *linepc = 0;
register I32 arg;
bool ischop;
+ 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");
- New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
+ /* estimate the buffer size needed */
+ for (base = s; s <= send; s++) {
+ if (*s == '\n' || *s == '@' || *s == '^')
+ maxops += 10;
+ }
+ s = base;
+ base = Nullch;
+
+ New(804, fops, maxops, U32);
fpc = fops;
if (s < send) {
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;
}
*fpc++ = FF_END;
+ 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(U16) + 4);
+ SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
s = SvPVX(sv) + SvCUR(sv) + z;
}
- Copy(fops, s, arg, U16);
+ Copy(fops, s, arg, U32);
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
https://perl5.git.perl.org / perl5.git / blobdiff