/* pp_ctl.c
*
- * Copyright (c) 1991-2000, Larry Wall
+ * Copyright (c) 1991-2001, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
if (DO_UTF8(tmpstr))
- pm->op_pmdynflags |= PMdf_UTF8;
+ pm->op_pmdynflags |= PMdf_DYN_UTF8;
+ else {
+ pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
+ if (pm->op_pmdynflags & PMdf_UTF8)
+ t = (char*)bytes_to_utf8((U8*)t, &len);
+ }
pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
- PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
+ if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
+ Safefree(t);
+ PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
inside tie/overload accessors. */
}
}
register char *m = cx->sb_m;
char *orig = cx->sb_orig;
register REGEXP *rx = cx->sb_rx;
-
+
rxres_restore(&cx->sb_rxres, rx);
if (cx->sb_iters++) {
: (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
{
SV *targ = cx->sb_targ;
- sv_catpvn(dstr, s, cx->sb_strend - s);
+ sv_catpvn(dstr, s, cx->sb_strend - s);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
(void)SvOOK_off(targ);
SvPVX(targ) = SvPVX(dstr);
SvCUR_set(targ, SvCUR(dstr));
SvLEN_set(targ, SvLEN(dstr));
+ if (DO_UTF8(dstr))
+ SvUTF8_on(targ);
SvPVX(dstr) = 0;
sv_free(dstr);
TAINT_IF(cx->sb_rxtainted & 1);
PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
- (void)SvPOK_only(targ);
+ (void)SvPOK_only_UTF8(targ);
TAINT_IF(cx->sb_rxtainted);
SvSETMAGIC(targ);
SvTAINT(targ);
cx->sb_strend = s + (cx->sb_strend - m);
}
cx->sb_m = m = rx->startp[0] + orig;
- sv_catpvn(dstr, s, m-s);
+ if (m > s)
+ sv_catpvn(dstr, s, m-s);
cx->sb_s = rx->endp[0] + orig;
+ { /* Update the pos() information. */
+ SV *sv = cx->sb_targ;
+ MAGIC *mg;
+ I32 i;
+ if (SvTYPE(sv) < SVt_PVMG)
+ SvUPGRADE(sv, SVt_PVMG);
+ if (!(mg = mg_find(sv, 'g'))) {
+ sv_magic(sv, Nullsv, 'g', Nullch, 0);
+ mg = mg_find(sv, 'g');
+ }
+ i = m - orig;
+ if (DO_UTF8(sv))
+ sv_pos_b2u(sv, &i);
+ mg->mg_len = i;
+ }
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
rxres_save(&cx->sb_rxres, rx);
RETURNOP(pm->op_pmreplstart);
case FF_MORE: name = "MORE"; break;
case FF_LINEMARK: name = "LINEMARK"; break;
case FF_END: name = "END"; break;
+ case FF_0DECIMAL: name = "0DECIMAL"; break;
}
if (arg >= 0)
PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
s = item;
if (item_is_utf) {
while (arg--) {
- if (*s & 0x80) {
+ if (UTF8_IS_CONTINUED(*s)) {
switch (UTF8SKIP(s)) {
case 7: *t++ = *s++;
case 6: *t++ = *s++;
t += fieldsize;
break;
+ case FF_0DECIMAL:
+ /* 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, "%#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
+ RESTORE_NUMERIC_STANDARD();
+ }
+ t += fieldsize;
+ break;
+
case FF_NEWLINE:
f++;
while (t-- > linemark && *t == ' ') ;
I32 count;
I32 shift;
SV** src;
- SV** dst;
+ SV** dst;
/* first, move source pointer to the next item in the source list */
++PL_markstack_ptr[-1];
* irrelevant. --jhi */
if (shift < count)
shift = count; /* Avoid shifting too often --Ben Tilly */
-
+
EXTEND(SP,shift);
src = SP;
dst = (SP += shift);
*dst-- = *src--;
}
/* copy the new items down to the destination list */
- dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
+ dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
while (items--)
- *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
+ *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
}
LEAVE; /* exit inner scope */
else {
dTOPss;
SV *targ = PAD_SV(PL_op->op_targ);
-
- if ((PL_op->op_private & OPpFLIP_LINENUM)
- ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
- : SvTRUE(sv) ) {
+ int flip;
+
+ if (PL_op->op_private & OPpFLIP_LINENUM) {
+ struct io *gp_io;
+ flip = PL_last_in_gv
+ && (gp_io = GvIOp(PL_last_in_gv))
+ && SvIV(sv) == (IV)IoLINES(gp_io);
+ } else {
+ flip = SvTRUE(sv);
+ }
+ if (flip) {
sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
if (PL_op->op_flags & OPf_SPECIAL) {
sv_setiv(targ, 1);
STATIC I32
S_dopoptolabel(pTHX_ char *label)
{
- dTHR;
register I32 i;
register PERL_CONTEXT *cx;
switch (CxTYPE(cx)) {
case CXt_SUBST:
if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
+ Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
PL_op_name[PL_op->op_type]);
break;
case CXt_SUB:
if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
+ Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
PL_op_name[PL_op->op_type]);
break;
case CXt_FORMAT:
if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
+ Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
PL_op_name[PL_op->op_type]);
break;
case CXt_EVAL:
if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
+ Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
PL_op_name[PL_op->op_type]);
break;
case CXt_NULL:
if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
+ Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
PL_op_name[PL_op->op_type]);
return -1;
case CXt_LOOP:
I32
Perl_block_gimme(pTHX)
{
- dTHR;
I32 cxix;
cxix = dopoptosub(cxstack_ix);
}
}
+I32
+Perl_is_lvalue_sub(pTHX)
+{
+ I32 cxix;
+
+ cxix = dopoptosub(cxstack_ix);
+ assert(cxix >= 0); /* We should only be called from inside subs */
+
+ if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
+ return cxstack[cxix].blk_sub.lval;
+ else
+ return 0;
+}
+
STATIC I32
S_dopoptosub(pTHX_ I32 startingblock)
{
- dTHR;
return dopoptosub_at(cxstack, startingblock);
}
STATIC I32
S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
{
- dTHR;
I32 i;
register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
STATIC I32
S_dopoptoeval(pTHX_ I32 startingblock)
{
- dTHR;
I32 i;
register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
STATIC I32
S_dopoptoloop(pTHX_ I32 startingblock)
{
- dTHR;
I32 i;
register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
switch (CxTYPE(cx)) {
case CXt_SUBST:
if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
+ Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
PL_op_name[PL_op->op_type]);
break;
case CXt_SUB:
if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
+ Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
PL_op_name[PL_op->op_type]);
break;
case CXt_FORMAT:
if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
+ Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
PL_op_name[PL_op->op_type]);
break;
case CXt_EVAL:
if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
+ Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
PL_op_name[PL_op->op_type]);
break;
case CXt_NULL:
if (ckWARN(WARN_EXITING))
- Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
+ Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
PL_op_name[PL_op->op_type]);
return -1;
case CXt_LOOP:
void
Perl_dounwind(pTHX_ I32 cxix)
{
- dTHR;
register PERL_CONTEXT *cx;
I32 optype;
STATIC void
S_free_closures(pTHX)
{
- dTHR;
SV **svp = AvARRAY(PL_comppad_name);
I32 ix;
for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
}
}
}
- else
+ else {
sv_setpvn(ERRSV, message, msglen);
+ if (PL_hints & HINT_UTF8)
+ SvUTF8_on(ERRSV);
+ else
+ SvUTF8_off(ERRSV);
+ }
}
else
message = SvPVx(ERRSV, msglen);
LEAVE;
+ /* LEAVE could clobber PL_curcop (see save_re_context())
+ * XXX it might be better to find a way to avoid messing with
+ * PL_curcop in save_re_context() instead, but this is a more
+ * minimal fix --GSAR */
+ PL_curcop = cx->blk_oldcop;
+
if (optype == OP_REQUIRE) {
char* msg = SvPVx(ERRSV, n_a);
DIE(aTHX_ "%sCompilation failed in require",
SV * mask ;
SV * old_warnings = cx->blk_oldcop->cop_warnings ;
- if (old_warnings == pWARN_NONE ||
+ if (old_warnings == pWARN_NONE ||
(old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
mask = newSVpvn(WARN_NONEstring, WARNsize) ;
- else if (old_warnings == pWARN_ALL ||
+ else if (old_warnings == pWARN_ALL ||
(old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
mask = newSVpvn(WARN_ALLstring, WARNsize) ;
else
#ifdef USE_THREADS
if (PL_op->op_flags & OPf_SPECIAL) {
- dTHR;
svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
SAVEGENERICSV(*svp);
*svp = NEWSV(0,0);
else
#endif /* USE_THREADS */
if (PL_op->op_targ) {
+#ifndef USE_ITHREADS
svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
SAVESPTR(*svp);
-#ifdef USE_ITHREADS
+#else
+ SAVEPADSV(PL_op->op_targ);
iterdata = (void*)PL_op->op_targ;
cxtype |= CXp_PADVAR;
#endif
}
*ops = 0;
if (o->op_flags & OPf_KIDS) {
- dTHR;
/* First try all the kids at this level, since that's likeliest. */
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
if (cxix < cxstack_ix)
dounwind(cxix);
TOPBLOCK(cx);
- if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
+ if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
DIE(aTHX_ "Can't goto subroutine from an eval-string");
mark = PL_stack_sp;
if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
PL_stack_sp--; /* There is no cv arg. */
/* Push a mark for the start of arglist */
- PUSHMARK(mark);
+ PUSHMARK(mark);
(void)(*CvXSUB(cv))(aTHXo_ cv);
/* Pop the current context like a decent sub should */
POPBLOCK(cx, PL_curpm);
#ifdef USE_THREADS
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 ;
+ PUTBACK ;
}
}
#endif /* USE_THREADS */
*/
SV *sv = GvSV(PL_DBsub);
CV *gotocv;
-
+
if (PERLDB_SUB_NN) {
SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
} else {
STATIC OP *
S_docatch(pTHX_ OP *o)
{
- dTHR;
int ret;
OP *oldop = PL_op;
volatile PERL_SI *cursi = PL_curstackinfo;
#else
SAVEVPTR(PL_op);
#endif
- PL_hints = 0;
+ PL_hints &= HINT_UTF8;
PL_op = &dummy;
PL_op->op_type = OP_ENTEREVAL;
PL_op->op_flags = 0; /* Avoid uninit warning. */
- PUSHBLOCK(cx, CXt_EVAL, SP);
+ PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
PUSHEVAL(cx, 0, Nullgv);
rop = doeval(G_SCALAR, startop);
POPBLOCK(cx,PL_curpm);
AV* comppadlist;
I32 i;
- PL_in_eval = EVAL_INEVAL;
+ PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
+ ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
+ : EVAL_INEVAL);
PUSHMARK(SP);
CvDEPTH(PL_compcv) = 1;
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_THREADS
MUTEX_LOCK(&PL_eval_mutex);
PL_eval_owner = 0;
if (SvNIOKp(sv)) {
if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
UV rev = 0, ver = 0, sver = 0;
- I32 len;
+ STRLEN len;
U8 *s = (U8*)SvPVX(sv);
U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
if (s < end) {
- rev = utf8_to_uv(s, &len, 0);
+ rev = utf8_to_uv(s, end - s, &len, 0);
s += len;
if (s < end) {
- ver = utf8_to_uv(s, &len, 0);
+ ver = utf8_to_uv(s, end - s, &len, 0);
s += len;
if (s < end)
- sver = utf8_to_uv(s, &len, 0);
+ sver = utf8_to_uv(s, end - s, &len, 0);
}
}
if (PERL_REVISION < rev
if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
goto trylocal;
}
- else
+ else
trylocal: {
#else
}
PL_compiling.cop_warnings = pWARN_ALL ;
else if (PL_dowarn & G_WARN_ALL_OFF)
PL_compiling.cop_warnings = pWARN_NONE ;
- else
+ else
PL_compiling.cop_warnings = pWARN_STD ;
+ SAVESPTR(PL_compiling.cop_io);
+ PL_compiling.cop_io = Nullsv;
if (filter_sub || filter_child_proc) {
SV *datasv = filter_add(run_user_filter, Nullsv);
ENTER;
lex_start(sv);
SAVETMPS;
-
+
/* switch to eval mode */
if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
SAVEFREESV(PL_compiling.cop_warnings);
}
+ SAVESPTR(PL_compiling.cop_io);
+ if (specialCopIO(PL_curcop->cop_io))
+ PL_compiling.cop_io = PL_curcop->cop_io;
+ else {
+ PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
+ SAVEFREESV(PL_compiling.cop_io);
+ }
push_return(PL_op->op_next);
PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
if (len == 0)
Perl_croak(aTHX_ "Null picture in formline");
-
+
New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
fpc = fops;
case ' ': case '\t':
skipspaces++;
continue;
-
+
case '\n': case 0:
arg = s - base;
skipspaces++;
}
*fpc++ = s - base; /* fieldsize for FETCH */
*fpc++ = FF_DECIMAL;
+ *fpc++ = arg;
+ }
+ else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
+ arg = ischop ? 512 : 0;
+ base = s - 1;
+ s++; /* skip the '0' first */
+ while (*s == '#')
+ s++;
+ if (*s == '.') {
+ char *f;
+ s++;
+ f = s;
+ while (*s == '#')
+ s++;
+ arg |= 256 + (s - f);
+ }
+ *fpc++ = s - base; /* fieldsize for FETCH */
+ *fpc++ = FF_0DECIMAL;
*fpc++ = arg;
}
else {
* Research Group at University of California, Berkeley.
*
* See also: "Optimistic Merge Sort" (SODA '92)
- *
+ *
* The integration to Perl is by John P. Linderman <jpl@research.att.com>.
*
* The code can be distributed under the same terms as Perl itself.
static I32
sortcv(pTHXo_ SV *a, SV *b)
{
- dTHR;
I32 oldsaveix = PL_savestack_ix;
I32 oldscopeix = PL_scopestack_ix;
I32 result;
static I32
sortcv_stacked(pTHXo_ SV *a, SV *b)
{
- dTHR;
I32 oldsaveix = PL_savestack_ix;
I32 oldscopeix = PL_scopestack_ix;
I32 result;
projects / p5sagit/p5-mst-13.2.git / blobdiff