X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=48e36187f2ab4c4f51fc0dc18995c306a2b916ed;hb=35bc0dc84153b4a6ad4b24f4d9e7d25cc7a0fb97;hp=15281689fba09ac6be5ea416723a317f21714ded;hpb=22e13caa16a0052ac27896caeb4c33581f86e239;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 1528168..48e3618 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1,6 +1,7 @@ /* 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. @@ -21,7 +22,7 @@ #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)) @@ -58,6 +59,7 @@ PP(pp_regcreset) /* 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; } @@ -97,7 +99,7 @@ PP(pp_regcomp) 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) @@ -157,6 +159,12 @@ PP(pp_substcont) 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); RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ)); @@ -212,6 +220,7 @@ PP(pp_substcont) SvTAINT(targ); LEAVE_SCOPE(cx->sb_oldsave); + ReREFCNT_dec(rx); POPSUBST(cx); RETURNOP(pm->op_next); } @@ -247,6 +256,8 @@ PP(pp_substcont) 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); @@ -337,7 +348,7 @@ PP(pp_formline) { dSP; dMARK; dORIGMARK; register SV *tmpForm = *++MARK; - register U16 *fpc; + register U32 *fpc; register char *t; register char *f; register char *s; @@ -355,7 +366,9 @@ PP(pp_formline) 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; if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { if (SvREADONLY(tmpForm)) { @@ -366,15 +379,16 @@ PP(pp_formline) else doparseform(tmpForm); } - 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( { @@ -414,6 +428,21 @@ PP(pp_formline) 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; @@ -458,13 +487,13 @@ PP(pp_formline) 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; @@ -519,11 +548,11 @@ PP(pp_formline) 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) { @@ -579,7 +608,15 @@ PP(pp_formline) 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); @@ -605,6 +642,21 @@ PP(pp_formline) } 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++ = *s++; + if (iscntrl(ch)) +#else + if (!(*t & ~31)) +#endif + *t = ' '; + } + break; + } while (arg--) { #ifdef EBCDIC int ch = *t++ = *s++; @@ -623,27 +675,38 @@ PP(pp_formline) s++; } sv_chop(sv,s); + SvSETMAGIC(sv); break; case FF_LINEGLOB: 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; while (s < send) { if (*s++ == '\n') { - if (s == send) + 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); + 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; @@ -739,6 +802,8 @@ PP(pp_formline) 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); @@ -778,6 +843,8 @@ PP(pp_formline) 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; @@ -825,6 +892,7 @@ PP(pp_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; @@ -835,7 +903,7 @@ PP(pp_mapwhile) ++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 @@ -879,7 +947,6 @@ PP(pp_mapwhile) /* All done yet? */ if (PL_markstack_ptr[-1] > *PL_markstack_ptr) { - I32 gimme = GIMME_V; (void)POPMARK; /* pop top */ LEAVE; /* exit outer scope */ @@ -964,6 +1031,16 @@ PP(pp_flip) } } +/* 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; @@ -979,15 +1056,7 @@ PP(pp_flop) 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); @@ -1262,8 +1331,6 @@ OP * Perl_die_where(pTHX_ char *message, STRLEN msglen) { STRLEN n_a; - IO *io; - MAGIC *mg; if (PL_in_eval) { I32 cxix; @@ -1298,8 +1365,6 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) sv_setpvn(ERRSV, message, msglen); } } - else - message = SvPVx(ERRSV, msglen); while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) @@ -1316,6 +1381,8 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) 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); @@ -1336,6 +1403,9 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) 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"); } @@ -1345,30 +1415,7 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) 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; @@ -1580,8 +1627,18 @@ PP(pp_caller) (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)); @@ -1678,6 +1735,11 @@ PP(pp_enteriter) 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); @@ -1709,12 +1771,7 @@ PP(pp_enteriter) 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"); @@ -1825,6 +1882,7 @@ PP(pp_return) 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)) @@ -1884,15 +1942,16 @@ PP(pp_return) } 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,""); @@ -1927,6 +1986,7 @@ PP(pp_last) dounwind(cxix); POPBLOCK(cx,newpm); + cxstack_ix++; /* temporarily protect top context */ mark = newsp; switch (CxTYPE(cx)) { case CXt_LOOP: @@ -1968,6 +2028,8 @@ PP(pp_last) SP = newsp; PUTBACK; + LEAVE; + cxstack_ix--; /* Stack values are safe: */ switch (pop2) { case CXt_LOOP: @@ -1980,7 +2042,6 @@ PP(pp_last) } PL_curpm = newpm; /* ... and pop $1 et al */ - LEAVE; LEAVESUB(sv); return nextop; } @@ -2138,6 +2199,7 @@ PP(pp_goto) } /* First do some returnish stuff. */ + SvREFCNT_inc(cv); /* avoid premature free during unwind */ FREETMPS; cxix = dopoptosub(cxstack_ix); if (cxix < 0) @@ -2167,6 +2229,8 @@ PP(pp_goto) 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; @@ -2185,6 +2249,7 @@ PP(pp_goto) /* 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)) { @@ -2278,7 +2343,10 @@ PP(pp_goto) 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); @@ -2321,7 +2389,7 @@ PP(pp_goto) 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); @@ -2608,7 +2676,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) SAVETMPS; /* switch to eval mode */ - if (PL_curcop == &PL_compiling) { + if (IN_PERL_COMPILETIME) { SAVECOPSTASH_FREE(&PL_compiling); CopSTASH_set(&PL_compiling, PL_curstash); } @@ -2641,14 +2709,14 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) 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) @@ -2664,7 +2732,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) /* 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; @@ -2772,9 +2840,8 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) 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; @@ -2793,6 +2860,9 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) 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"); } @@ -2817,7 +2887,16 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) *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); @@ -2849,8 +2928,9 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) } 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; @@ -2878,6 +2958,9 @@ S_doopen_pmc(pTHX_ const char *name, const char *mode) fp = PerlIO_open(name, mode); } return fp; +#else + return PerlIO_open(name, mode); +#endif /* !PERL_DISABLE_PMC */ } PP(pp_require) @@ -2968,15 +3051,18 @@ 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) { @@ -2985,7 +3071,7 @@ PP(pp_require) 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 @@ -3086,6 +3172,7 @@ PP(pp_require) PERL_SCRIPT_MODE); } } + SP--; } PUTBACK; @@ -3140,7 +3227,7 @@ PP(pp_require) #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; @@ -3481,16 +3568,25 @@ S_doparseform(pTHX_ SV *sv) 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 == '\0' || *s == '@' || *s == '^') + maxops += 10; + } + s = base; + base = Nullch; + + New(804, fops, maxops, U32); fpc = fops; if (s < send) { @@ -3653,14 +3749,15 @@ S_doparseform(pTHX_ SV *sv) } *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);