/* pp_ctl.c
*
- * Copyright (c) 1991-2003, 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;
}
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)
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);
RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
SvTAINT(targ);
LEAVE_SCOPE(cx->sb_oldsave);
+ ReREFCNT_dec(rx);
POPSUBST(cx);
RETURNOP(pm->op_next);
}
sv_pos_b2u(sv, &i);
mg->mg_len = i;
}
+ ReREFCNT_inc(rx);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
rxres_save(&cx->sb_rxres, rx);
RETURNOP(pm->op_pmreplstart);
{
dSP; dMARK; dORIGMARK;
register SV *tmpForm = *++MARK;
- register U16 *fpc;
+ register U32 *fpc;
register char *t;
register char *f;
register char *s;
/* 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( {
s++;
}
sv_chop(sv,s);
+ SvSETMAGIC(sv);
break;
case FF_LINEGLOB:
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
/* All done yet? */
if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
- I32 gimme = GIMME_V;
(void)POPMARK; /* pop top */
LEAVE; /* exit outer scope */
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;
SAVETMPS;
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 = &PAD_SVl(PL_op->op_targ); /* "my" variable */
SAVESPTR(*svp);
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))
LEAVE;
/* Stack values are safe: */
if (popsub2) {
+ cxstack_ix--;
POPSUB(cx,sv); /* release CV and @_ ... */
}
else
dounwind(cxix);
POPBLOCK(cx,newpm);
+ cxstack_ix++; /* temporarily protect top context */
mark = newsp;
switch (CxTYPE(cx)) {
case CXt_LOOP:
PUTBACK;
LEAVE;
+ cxstack_ix--;
/* Stack values are safe: */
switch (pop2) {
case CXt_LOOP:
AvFLAGS(av) = AVf_REIFY;
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;
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);
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);
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_op && (PL_op->op_type == OP_REGCOMP);
+ 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;
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");
}
*startop = PL_eval_root;
} 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);
}
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;
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;
+ int maxops = 2; /* FF_LINEMARK + FF_END) */
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) {
}
*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);
projects / p5sagit/p5-mst-13.2.git / blobdiff