X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/10efb74f64fe893d58bec201ca5044ac1e94c795..8f6ae13c8af6db5c57cde14346d77d89a10817d3:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 28b0484..74c99cc 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1,7 +1,7 @@ /* pp_ctl.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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. @@ -38,6 +38,8 @@ #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) +#define dopoptosub(plop) dopoptosub_at(cxstack, (plop)) + PP(pp_wantarray) { dVAR; @@ -75,7 +77,7 @@ PP(pp_regcomp) dSP; register PMOP *pm = (PMOP*)cLOGOP->op_other; SV *tmpstr; - MAGIC *mg = NULL; + REGEXP *re = NULL; /* prevent recompiling under /o and ithreads. */ #if defined(USE_ITHREADS) @@ -114,25 +116,25 @@ PP(pp_regcomp) if (SvROK(tmpstr)) { SV * const sv = SvRV(tmpstr); - if(SvMAGICAL(sv)) - mg = mg_find(sv, PERL_MAGIC_qr); + if (SvTYPE(sv) == SVt_REGEXP) + re = sv; } - if (mg) { - regexp * const re = (regexp *)mg->mg_obj; + if (re) { + re = reg_temp_copy(re); ReREFCNT_dec(PM_GETRE(pm)); - PM_SETRE(pm, ReREFCNT_inc(re)); + PM_SETRE(pm, re); } else { STRLEN len; - const char *t = SvPV_const(tmpstr, len); - regexp * const re = PM_GETRE(pm); + const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : ""; + re = PM_GETRE(pm); /* Check against the last compiled regexp. */ - if (!re || !re->precomp || re->prelen != (I32)len || - memNE(re->precomp, t, len)) + if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != (I32)len || + memNE(RX_PRECOMP(re), t, len)) { - const regexp_engine *eng = re ? re->engine : NULL; - + const regexp_engine *eng = re ? RX_ENGINE(re) : NULL; + U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME; if (re) { ReREFCNT_dec(re); PM_SETRE(pm, NULL); /* crucial if regcomp aborts */ @@ -146,50 +148,51 @@ PP(pp_regcomp) if (PL_op->op_flags & OPf_SPECIAL) PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ - pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ - if (DO_UTF8(tmpstr)) - 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); + if (DO_UTF8(tmpstr)) { + assert (SvUTF8(tmpstr)); + } else if (SvUTF8(tmpstr)) { + /* Not doing UTF-8, despite what the SV says. Is this only if + we're trapped in use 'bytes'? */ + /* Make a copy of the octet sequence, but without the flag on, + as the compiler now honours the SvUTF8 flag on tmpstr. */ + STRLEN len; + const char *const p = SvPV(tmpstr, len); + tmpstr = newSVpvn_flags(p, len, SVs_TEMP); } - if (eng) - PM_SETRE(pm, CALLREGCOMP_ENG(eng,(char *)t, (char *)t + len, pm)); - else - PM_SETRE(pm, CALLREGCOMP((char *)t, (char *)t + len, pm)); - - if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8)) - Safefree(t); + + if (eng) + PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags)); + else + PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags)); + PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed inside tie/overload accessors. */ } } + + re = PM_GETRE(pm); #ifndef INCOMPLETE_TAINTS if (PL_tainting) { if (PL_tainted) - pm->op_pmdynflags |= PMdf_TAINTED; + RX_EXTFLAGS(re) |= RXf_TAINTED; else - pm->op_pmdynflags &= ~PMdf_TAINTED; + RX_EXTFLAGS(re) &= ~RXf_TAINTED; } #endif - if (!PM_GETRE(pm)->prelen && PL_curpm) + if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) pm = PL_curpm; - else if (strEQ("\\s+", PM_GETRE(pm)->precomp)) - pm->op_pmflags |= PMf_WHITE; - else - pm->op_pmflags &= ~PMf_WHITE; - /* XXX runtime compiled output needs to move to the pad */ + +#if !defined(USE_ITHREADS) + /* can't change the optree at runtime either */ + /* PMf_KEEP is handled differently under threads to avoid these problems */ if (pm->op_pmflags & PMf_KEEP) { pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ -#if !defined(USE_ITHREADS) - /* XXX can't change the optree at runtime either */ cLOGOP->op_first->op_next = PL_op->op_next; -#endif } +#endif RETURN; } @@ -259,7 +262,7 @@ PP(pp_substcont) SvPV_set(dstr, NULL); TAINT_IF(cx->sb_rxtainted & 1); - PUSHs(sv_2mortal(newSViv(saviters - 1))); + mPUSHi(saviters - 1); (void)SvPOK_only_UTF8(targ); TAINT_IF(cx->sb_rxtainted); @@ -272,27 +275,26 @@ PP(pp_substcont) } cx->sb_iters = saviters; } - if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { + if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) { m = s; s = orig; - cx->sb_orig = orig = rx->subbeg; + cx->sb_orig = orig = RX_SUBBEG(rx); s = orig + (m - s); cx->sb_strend = s + (cx->sb_strend - m); } - cx->sb_m = m = rx->startp[0] + orig; + cx->sb_m = m = RX_OFFS(rx)[0].start + orig; 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; + cx->sb_s = RX_OFFS(rx)[0].end + orig; { /* Update the pos() information. */ SV * const sv = cx->sb_targ; MAGIC *mg; I32 i; - if (SvTYPE(sv) < SVt_PVMG) - SvUPGRADE(sv, SVt_PVMG); + SvUPGRADE(sv, SVt_PVMG); if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { #ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(sv)) @@ -310,7 +312,7 @@ PP(pp_substcont) (void)ReREFCNT_inc(rx); cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); rxres_save(&cx->sb_rxres, rx); - RETURNOP(pm->op_pmreplstart); + RETURNOP(pm->op_pmstashstartu.op_pmreplstart); } void @@ -320,11 +322,11 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) U32 i; PERL_UNUSED_CONTEXT; - if (!p || p[1] < rx->nparens) { + if (!p || p[1] < RX_NPARENS(rx)) { #ifdef PERL_OLD_COPY_ON_WRITE - i = 7 + rx->nparens * 2; + i = 7 + RX_NPARENS(rx) * 2; #else - i = 6 + rx->nparens * 2; + i = 6 + RX_NPARENS(rx) * 2; #endif if (!p) Newx(p, i, UV); @@ -333,21 +335,21 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) *rsp = (void*)p; } - *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL); + *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL); RX_MATCH_COPIED_off(rx); #ifdef PERL_OLD_COPY_ON_WRITE - *p++ = PTR2UV(rx->saved_copy); - rx->saved_copy = NULL; + *p++ = PTR2UV(RX_SAVED_COPY(rx)); + RX_SAVED_COPY(rx) = NULL; #endif - *p++ = rx->nparens; + *p++ = RX_NPARENS(rx); - *p++ = PTR2UV(rx->subbeg); - *p++ = (UV)rx->sublen; - for (i = 0; i <= rx->nparens; ++i) { - *p++ = (UV)rx->startp[i]; - *p++ = (UV)rx->endp[i]; + *p++ = PTR2UV(RX_SUBBEG(rx)); + *p++ = (UV)RX_SUBLEN(rx); + for (i = 0; i <= RX_NPARENS(rx); ++i) { + *p++ = (UV)RX_OFFS(rx)[i].start; + *p++ = (UV)RX_OFFS(rx)[i].end; } } @@ -363,19 +365,19 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) *p++ = 0; #ifdef PERL_OLD_COPY_ON_WRITE - if (rx->saved_copy) - SvREFCNT_dec (rx->saved_copy); - rx->saved_copy = INT2PTR(SV*,*p); + if (RX_SAVED_COPY(rx)) + SvREFCNT_dec (RX_SAVED_COPY(rx)); + RX_SAVED_COPY(rx) = INT2PTR(SV*,*p); *p++ = 0; #endif - rx->nparens = *p++; + RX_NPARENS(rx) = *p++; - rx->subbeg = INT2PTR(char*,*p++); - rx->sublen = (I32)(*p++); - for (i = 0; i <= rx->nparens; ++i) { - rx->startp[i] = (I32)(*p++); - rx->endp[i] = (I32)(*p++); + RX_SUBBEG(rx) = INT2PTR(char*,*p++); + RX_SUBLEN(rx) = (I32)(*p++); + for (i = 0; i <= RX_NPARENS(rx); ++i) { + RX_OFFS(rx)[i].start = (I32)(*p++); + RX_OFFS(rx)[i].end = (I32)(*p++); } } @@ -932,7 +934,7 @@ PP(pp_grepstart) if (PL_stack_base + *PL_markstack_ptr == SP) { (void)POPMARK; if (GIMME_V == G_SCALAR) - XPUSHs(sv_2mortal(newSViv(0))); + mXPUSHi(0); RETURNOP(PL_op->op_next->op_next); } PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; @@ -1308,13 +1310,6 @@ Perl_is_lvalue_sub(pTHX) } STATIC I32 -S_dopoptosub(pTHX_ I32 startingblock) -{ - dVAR; - return dopoptosub_at(cxstack, startingblock); -} - -STATIC I32 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) { dVAR; @@ -1466,8 +1461,9 @@ Perl_qerror(pTHX_ SV *err) else if (PL_errors) sv_catsv(PL_errors, err); else - Perl_warn(aTHX_ "%"SVf, (void*)err); - ++PL_error_count; + Perl_warn(aTHX_ "%"SVf, SVfARG(err)); + if (PL_parser) + ++PL_parser->error_count; } OP * @@ -1641,9 +1637,9 @@ PP(pp_caller) if (!stashname) PUSHs(&PL_sv_undef); else - PUSHs(sv_2mortal(newSVpv(stashname, 0))); - PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0))); - PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop)))); + mPUSHs(newSVpv(stashname, 0)); + mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0)); + mPUSHi((I32)CopLINE(cx->blk_oldcop)); if (!MAXARG) RETURN; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { @@ -1652,23 +1648,23 @@ PP(pp_caller) if (isGV(cvgv)) { SV * const sv = newSV(0); gv_efullname3(sv, cvgv, NULL); - PUSHs(sv_2mortal(sv)); - PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); + mPUSHs(sv); + mPUSHi((I32)cx->blk_sub.hasargs); } else { - PUSHs(sv_2mortal(newSVpvs("(unknown)"))); - PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); + PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP)); + mPUSHi((I32)cx->blk_sub.hasargs); } } else { - PUSHs(sv_2mortal(newSVpvs("(eval)"))); - PUSHs(sv_2mortal(newSViv(0))); + PUSHs(newSVpvs_flags("(eval)", SVs_TEMP)); + mPUSHi(0); } gimme = (I32)cx->blk_gimme; if (gimme == G_VOID) PUSHs(&PL_sv_undef); else - PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY))); + mPUSHi(gimme & G_ARRAY); if (CxTYPE(cx) == CXt_EVAL) { /* eval STRING */ if (cx->blk_eval.old_op_type == OP_ENTEREVAL) { @@ -1677,7 +1673,7 @@ PP(pp_caller) } /* require */ else if (cx->blk_eval.old_namesv) { - PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv))); + mPUSHs(newSVsv(cx->blk_eval.old_namesv)); PUSHs(&PL_sv_yes); } /* eval BLOCK (try blocks have old_namesv == 0) */ @@ -1711,7 +1707,7 @@ PP(pp_caller) /* XXX only hints propagated via op_private are currently * visible (others are not easily accessible, since they * use the global PL_hints) */ - PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop)))); + mPUSHi(CopHINTS_get(cx->blk_oldcop)); { SV * mask ; STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ; @@ -1734,7 +1730,7 @@ PP(pp_caller) } else mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]); - PUSHs(sv_2mortal(mask)); + mPUSHs(mask); } PUSHs(cx->blk_oldcop->cop_hints_hash ? @@ -2028,7 +2024,7 @@ PP(pp_return) /* Unassume the success we assumed earlier. */ SV * const nsv = cx->blk_eval.old_namesv; (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); - DIE(aTHX_ "%"SVf" did not return a true value", (void*)nsv); + DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv)); } break; case CXt_FORMAT: @@ -2336,7 +2332,7 @@ PP(pp_goto) goto retry; tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, NULL); - DIE(aTHX_ "Goto undefined subroutine &%"SVf"",(void*)tmpstr); + DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr)); } DIE(aTHX_ "Goto undefined subroutine"); } @@ -2658,9 +2654,8 @@ S_save_lines(pTHX_ AV *array, SV *sv) while (s && s < send) { const char *t; - SV * const tmpstr = newSV(0); + SV * const tmpstr = newSV_type(SVt_PVMG); - sv_upgrade(tmpstr, SVt_PVMG); t = strchr(s, '\n'); if (t) t++; @@ -2673,14 +2668,6 @@ S_save_lines(pTHX_ AV *array, SV *sv) } } -STATIC void -S_docatch_body(pTHX) -{ - dVAR; - CALLRUNOPS(aTHX); - return; -} - STATIC OP * S_docatch(pTHX_ OP *o) { @@ -2701,7 +2688,7 @@ S_docatch(pTHX_ OP *o) assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env; redo_body: - docatch_body(); + CALLRUNOPS(aTHX); break; case 3: /* die caught by an inner eval - continue inner loop */ @@ -2745,7 +2732,6 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) I32 gimme = G_VOID; I32 optype; OP dummy; - OP *rop; char tbuf[TYPE_DIGITS(long) + 12 + 10]; char *tmpbuf = tbuf; char *safestr; @@ -2754,7 +2740,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) STRLEN len; ENTER; - lex_start(sv); + lex_start(sv, NULL, FALSE); SAVETMPS; /* switch to eval mode */ @@ -2803,9 +2789,9 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) PUSHEVAL(cx, 0, NULL); if (runtime) - rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); + (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); else - rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); + (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); POPBLOCK(cx,PL_curpm); POPEVAL(cx); @@ -2823,7 +2809,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) PERL_UNUSED_VAR(newsp); PERL_UNUSED_VAR(optype); - return rop; + return PL_eval_start; } @@ -2872,10 +2858,12 @@ Perl_find_runcv(pTHX_ U32 *db_seqp) * 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. + * Returns a bool indicating whether the compile was successful; if so, + * PL_eval_start contains the first op of the compiled ocde; otherwise, + * pushes undef (also croaks if startop != NULL). */ -/* With USE_5005THREADS, eval_owner must be held on entry to doeval */ -STATIC OP * +STATIC bool S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) { dVAR; dSP; @@ -2888,8 +2876,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) PUSHMARK(SP); SAVESPTR(PL_compcv); - PL_compcv = (CV*)newSV(0); - sv_upgrade((SV *)PL_compcv, SVt_PVCV); + PL_compcv = (CV*)newSV_type(SVt_PVCV); CvEVAL_on(PL_compcv); assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); cxstack[cxstack_ix].blk_eval.cv = PL_compcv; @@ -2919,24 +2906,22 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) SAVESPTR(PL_unitcheckav); PL_unitcheckav = newAV(); SAVEFREESV(PL_unitcheckav); - SAVEI32(PL_error_count); #ifdef PERL_MAD - SAVEI32(PL_madskills); + SAVEBOOL(PL_madskills); PL_madskills = 0; #endif /* try to compile it */ PL_eval_root = NULL; - PL_error_count = 0; PL_curcop = &PL_compiling; CopARYBASE_set(PL_curcop, 0); if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL)) PL_in_eval |= EVAL_KEEPERR; else sv_setpvn(ERRSV,"",0); - if (yyparse() || PL_error_count || !PL_eval_root) { + if (yyparse() || PL_parser->error_count || !PL_eval_root) { SV **newsp; /* Used by POPBLOCK. */ PERL_CONTEXT *cx = &cxstack[cxstack_ix]; I32 optype = 0; /* Might be reset by POPEVAL. */ @@ -2960,8 +2945,8 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) const SV * const nsv = cx->blk_eval.old_namesv; (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), &PL_sv_undef, 0); - DIE(aTHX_ "%sCompilation failed in require", - *msg ? msg : "Unknown error\n"); + Perl_croak(aTHX_ "%sCompilation failed in require", + *msg ? msg : "Unknown error\n"); } else if (startop) { POPBLOCK(cx,PL_curpm); @@ -2971,11 +2956,13 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) } else { if (!*msg) { - sv_setpv(ERRSV, "Compilation error"); + sv_setpvs(ERRSV, "Compilation error"); } } PERL_UNUSED_VAR(newsp); - RETPUSHUNDEF; + PUSHs(&PL_sv_undef); + PUTBACK; + return FALSE; } CopLINE_set(&PL_compiling, 0); if (startop) { @@ -3020,13 +3007,14 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) 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. */ + PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */ - RETURNOP(PL_eval_start); + PUTBACK; + return TRUE; } STATIC PerlIO * -S_check_type_and_open(pTHX_ const char *name, const char *mode) +S_check_type_and_open(pTHX_ const char *name) { Stat_t st; const int st_rc = PerlLIO_stat(name, &st); @@ -3035,36 +3023,40 @@ S_check_type_and_open(pTHX_ const char *name, const char *mode) return NULL; } - return PerlIO_open(name, mode); + return PerlIO_open(name, PERL_SCRIPT_MODE); } +#ifndef PERL_DISABLE_PMC STATIC PerlIO * -S_doopen_pm(pTHX_ const char *name, const char *mode) +S_doopen_pm(pTHX_ const char *name, const STRLEN namelen) { -#ifndef PERL_DISABLE_PMC - const STRLEN namelen = strlen(name); PerlIO *fp; - if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) { - SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c'); - const char * const pmc = SvPV_nolen_const(pmcsv); + if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) { + SV *const pmcsv = newSV(namelen + 2); + char *const pmc = SvPVX(pmcsv); Stat_t pmcstat; + + memcpy(pmc, name, namelen); + pmc[namelen] = 'c'; + pmc[namelen + 1] = '\0'; + if (PerlLIO_stat(pmc, &pmcstat) < 0) { - fp = check_type_and_open(name, mode); + fp = check_type_and_open(name); } else { - fp = check_type_and_open(pmc, mode); + fp = check_type_and_open(pmc); } SvREFCNT_dec(pmcsv); } else { - fp = check_type_and_open(name, mode); + fp = check_type_and_open(name); } return fp; +} #else - return check_type_and_open(name, mode); +# define doopen_pm(name, namelen) check_type_and_open(name) #endif /* !PERL_DISABLE_PMC */ -} PP(pp_require) { @@ -3073,6 +3065,11 @@ PP(pp_require) SV *sv; const char *name; STRLEN len; + char * unixname; + STRLEN unixlen; +#ifdef VMS + int vms_unixname = 0; +#endif const char *tryname = NULL; SV *namesv = NULL; const I32 gimme = GIMME_V; @@ -3087,37 +3084,124 @@ PP(pp_require) sv = POPs; if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) { - if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */ + if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) { /* require v5.6.1 */ + HV * hinthv = GvHV(PL_hintgv); + SV ** ptr = NULL; + if (hinthv) ptr = hv_fetchs(hinthv, "v_string", FALSE); + if ( !(ptr && *ptr && SvIOK(*ptr) && SvIV(*ptr)) ) Perl_warner(aTHX_ packWARN(WARN_PORTABLE), "v-string in use/require non-portable"); - + } sv = new_version(sv); if (!sv_derived_from(PL_patchlevel, "version")) - upg_version(PL_patchlevel); + upg_version(PL_patchlevel, TRUE); if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) { if ( vcmp(sv,PL_patchlevel) <= 0 ) DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped", - (void*)vnormal(sv), (void*)vnormal(PL_patchlevel)); + SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel))); } else { - if ( vcmp(sv,PL_patchlevel) > 0 ) - DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped", - (void*)vnormal(sv), (void*)vnormal(PL_patchlevel)); + if ( vcmp(sv,PL_patchlevel) > 0 ) { + I32 first = 0; + AV *lav; + SV * const req = SvRV(sv); + SV * const pv = *hv_fetchs((HV*)req, "original", FALSE); + + /* get the left hand term */ + lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE)); + + first = SvIV(*av_fetch(lav,0,0)); + if ( first > (int)PERL_REVISION /* probably 'use 6.0' */ + || hv_exists((HV*)req, "qv", 2 ) /* qv style */ + || av_len(lav) > 1 /* FP with > 3 digits */ + || strstr(SvPVX(pv),".0") /* FP with leading 0 */ + ) { + DIE(aTHX_ "Perl %"SVf" required--this is only " + "%"SVf", stopped", SVfARG(vnormal(req)), + SVfARG(vnormal(PL_patchlevel))); + } + else { /* probably 'use 5.10' or 'use 5.8' */ + SV * hintsv = newSV(0); + I32 second = 0; + + if (av_len(lav)>=1) + second = SvIV(*av_fetch(lav,1,0)); + + second /= second >= 600 ? 100 : 10; + hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d", + (int)first, (int)second,0); + upg_version(hintsv, TRUE); + + DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)" + "--this is only %"SVf", stopped", + SVfARG(vnormal(req)), + SVfARG(vnormal(hintsv)), + SVfARG(vnormal(PL_patchlevel))); + } + } } - RETPUSHYES; + /* We do this only with use, not require. */ + if (PL_compcv && + /* If we request a version >= 5.6.0, then v-string are OK + so set $^H{v_string} to suppress the v-string warning */ + vcmp(sv, sv_2mortal(upg_version(newSVnv(5.006), FALSE))) >= 0) { + HV * hinthv = GvHV(PL_hintgv); + if( hinthv ) { + SV *hint = newSViv(1); + (void)hv_stores(hinthv, "v_string", hint); + /* This will call through to Perl_magic_sethint() which in turn + sets PL_hints correctly. */ + SvSETMAGIC(hint); + } + /* If we request a version >= 5.9.5, load feature.pm with the + * feature bundle that corresponds to the required version. */ + if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) { + SV *const importsv = vnormal(sv); + *SvPVX_mutable(importsv) = ':'; + ENTER; + Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL); + LEAVE; + } + } + + RETPUSHYES; } name = SvPV_const(sv, len); if (!(name && len > 0 && *name)) DIE(aTHX_ "Null filename used"); TAINT_PROPER("require"); + + +#ifdef VMS + /* The key in the %ENV hash is in the syntax of file passed as the argument + * usually this is in UNIX format, but sometimes in VMS format, which + * can result in a module being pulled in more than once. + * To prevent this, the key must be stored in UNIX format if the VMS + * name can be translated to UNIX. + */ + if ((unixname = tounixspec(name, NULL)) != NULL) { + unixlen = strlen(unixname); + vms_unixname = 1; + } + else +#endif + { + /* if not VMS or VMS name can not be translated to UNIX, pass it + * through. + */ + unixname = (char *) name; + unixlen = len; + } if (PL_op->op_type == OP_REQUIRE) { - SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); + SV * const * const svp = hv_fetch(GvHVn(PL_incgv), + unixname, unixlen, 0); if ( svp ) { if (*svp != &PL_sv_undef) RETPUSHYES; else - DIE(aTHX_ "Compilation failed in require"); + DIE(aTHX_ "Attempt to reload %s aborted.\n" + "Compilation failed in require", unixname); } } @@ -3125,7 +3209,7 @@ PP(pp_require) if (path_is_absolute(name)) { tryname = name; - tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE); + tryrsfp = doopen_pm(name, len); } #ifdef MACOS_TRADITIONAL if (!tryrsfp) { @@ -3134,7 +3218,7 @@ PP(pp_require) MacPerl_CanonDir(name, newname, 1); if (path_is_absolute(newname)) { tryname = newname; - tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE); + tryrsfp = doopen_pm(newname, strlen(newname)); } } #endif @@ -3142,11 +3226,11 @@ PP(pp_require) AV * const ar = GvAVn(PL_incgv); I32 i; #ifdef VMS - char *unixname; - if ((unixname = tounixspec(name, NULL)) != NULL) + if (vms_unixname) #endif { namesv = newSV(0); + sv_upgrade(namesv, SVt_PV); for (i = 0; i <= AvFILL(ar); i++) { SV * const dirsv = *av_fetch(ar, i, TRUE); @@ -3276,7 +3360,16 @@ PP(pp_require) || (*name == ':' && name[1] != ':' && strchr(name+2, ':')) #endif ) { - const char *dir = SvPVx_nolen_const(dirsv); + const char *dir; + STRLEN dirlen; + + if (SvOK(dirsv)) { + dir = SvPV_const(dirsv, dirlen); + } else { + dir = ""; + dirlen = 0; + } + #ifdef MACOS_TRADITIONAL char buf1[256]; char buf2[256]; @@ -3304,13 +3397,32 @@ PP(pp_require) "%s\\%s", dir, name); # else - Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); + /* The equivalent of + Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); + but without the need to parse the format string, or + call strlen on either pointer, and with the correct + allocation up front. */ + { + char *tmp = SvGROW(namesv, dirlen + len + 2); + + memcpy(tmp, dir, dirlen); + tmp +=dirlen; + *tmp++ = '/'; + /* name came from an SV, so it will have a '\0' at the + end that we can copy as part of this memcpy(). */ + memcpy(tmp, name, len + 1); + + SvCUR_set(namesv, dirlen + len + 1); + + /* Don't even actually have to turn SvPOK_on() as we + access it directly with SvPVX() below. */ + } # endif # endif #endif TAINT_PROPER("require"); tryname = SvPVX_const(namesv); - tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE); + tryrsfp = doopen_pm(tryname, SvCUR(namesv)); if (tryrsfp) { if (tryname[0] == '.' && tryname[1] == '/') tryname += 2; @@ -3368,20 +3480,19 @@ PP(pp_require) /* name is never assigned to again, so len is still strlen(name) */ /* Check whether a hook in @INC has already filled %INC */ if (!hook_sv) { - (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0); + (void)hv_store(GvHVn(PL_incgv), + unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0); } else { - SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); + SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0); if (!svp) - (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 ); + (void)hv_store(GvHVn(PL_incgv), + unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 ); } ENTER; SAVETMPS; - lex_start(NULL); - SAVEGENERICSV(PL_rsfp_filters); - PL_rsfp_filters = NULL; + lex_start(NULL, tryrsfp, TRUE); - PL_rsfp = tryrsfp; SAVEHINTS(); PL_hints = 0; SAVECOMPILEWARNINGS(); @@ -3389,10 +3500,6 @@ PP(pp_require) PL_compiling.cop_warnings = pWARN_ALL ; else if (PL_dowarn & G_WARN_ALL_OFF) PL_compiling.cop_warnings = pWARN_NONE ; - else if (PL_taint_warn) { - PL_compiling.cop_warnings - = Perl_new_warnings_bitfield(aTHX_ NULL, WARN_TAINTstring, WARNsize); - } else PL_compiling.cop_warnings = pWARN_STD ; @@ -3418,7 +3525,10 @@ PP(pp_require) encoding = PL_encoding; PL_encoding = NULL; - op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq)); + if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq)) + op = DOCATCH(PL_eval_start); + else + op = PL_op->op_next; /* Restore encoding. */ PL_encoding = encoding; @@ -3437,7 +3547,7 @@ PP(pp_entereval) char *tmpbuf = tbuf; char *safestr; STRLEN len; - OP *ret; + bool ok; CV* runcv; U32 seq; HV *saved_hh = NULL; @@ -3449,10 +3559,11 @@ PP(pp_entereval) } sv = POPs; + TAINT_IF(SvTAINTED(sv)); TAINT_PROPER("eval"); ENTER; - lex_start(sv); + lex_start(sv, NULL, FALSE); SAVETMPS; /* switch to eval mode */ @@ -3507,15 +3618,15 @@ PP(pp_entereval) /* prepare to compile string */ if (PERLDB_LINE && PL_curstash != PL_debstash) - save_lines(CopFILEAV(&PL_compiling), PL_linestr); + save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr); PUTBACK; - ret = doeval(gimme, NULL, runcv, seq); + ok = doeval(gimme, NULL, runcv, seq); if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */ - && ret != PL_op->op_next) { /* Successive compilation. */ + && ok) { /* Copy in anything fake and short. */ my_strlcpy(safestr, fakestr, fakelen); } - return DOCATCH(ret); + return ok ? DOCATCH(PL_eval_start) : PL_op->op_next; } PP(pp_leaveeval) @@ -3574,7 +3685,7 @@ PP(pp_leaveeval) /* Unassume the success we assumed earlier. */ SV * const nsv = cx->blk_eval.old_namesv; (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); - retop = Perl_die(aTHX_ "%"SVf" did not return a true value", (void*)nsv); + retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv)); /* die_where() did LEAVE, or we won't be here */ } else { @@ -3619,7 +3730,6 @@ Perl_create_eval_scope(pTHX_ U32 flags) PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); PUSHEVAL(cx, 0, 0); - PL_eval_root = PL_op; /* Only needed so that goto works right. */ PL_in_eval = EVAL_INEVAL; if (flags & G_KEEPERR) @@ -3734,9 +3844,8 @@ PP(pp_leavegiven) } /* Helper routines used by pp_smartmatch */ -STATIC -PMOP * -S_make_matcher(pTHX_ regexp *re) +STATIC PMOP * +S_make_matcher(pTHX_ REGEXP *re) { dVAR; PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED); @@ -3748,8 +3857,7 @@ S_make_matcher(pTHX_ regexp *re) return matcher; } -STATIC -bool +STATIC bool S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) { dVAR; @@ -3763,8 +3871,7 @@ S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) return (SvTRUEx(POPs)); } -STATIC -void +STATIC void S_destroy_matcher(pTHX_ PMOP *matcher) { dVAR; @@ -3782,8 +3889,7 @@ PP(pp_smartmatch) /* This version of do_smartmatch() implements the * table of smart matches that is found in perlsyn. */ -STATIC -OP * +STATIC OP * S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) { dVAR; @@ -3792,8 +3898,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) SV *e = TOPs; /* e is for 'expression' */ SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */ SV *This, *Other; /* 'This' (and Other to match) to play with C++ */ - MAGIC *mg; - regexp *this_regex, *other_regex; + REGEXP *this_regex, *other_regex; # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0) @@ -3808,24 +3913,22 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) && NOT_EMPTY_PROTO(This) && (Other = d))) # define SM_REGEX ( \ - (SvROK(d) && SvMAGICAL(This = SvRV(d)) \ - && (mg = mg_find(This, PERL_MAGIC_qr)) \ - && (this_regex = (regexp *)mg->mg_obj) \ + (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \ + && (this_regex = This) \ && (Other = e)) \ || \ - (SvROK(e) && SvMAGICAL(This = SvRV(e)) \ - && (mg = mg_find(This, PERL_MAGIC_qr)) \ - && (this_regex = (regexp *)mg->mg_obj) \ + (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \ + && (this_regex = This) \ && (Other = d)) ) # define SM_OTHER_REF(type) \ (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type) -# define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other)) \ - && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr)) \ - && (other_regex = (regexp *)mg->mg_obj)) - +# define SM_OTHER_REGEX (SvROK(Other) \ + && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \ + && (other_regex = SvRV(Other))) + # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \ sv_2mortal(newSViv(PTR2IV(sv))), 0) @@ -3934,23 +4037,19 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) AV * const other_av = (AV *) SvRV(Other); const I32 other_len = av_len(other_av) + 1; I32 i; - - if (HvUSEDKEYS((HV *) This) != other_len) - RETPUSHNO; - - for(i = 0; i < other_len; ++i) { + + for (i = 0; i < other_len; ++i) { SV ** const svp = av_fetch(other_av, i, FALSE); char *key; STRLEN key_len; - if (!svp) /* ??? When can this happen? */ - RETPUSHNO; - - key = SvPV(*svp, key_len); - if(!hv_exists((HV *) This, key, key_len)) - RETPUSHNO; + if (svp) { /* ??? When can this not happen? */ + key = SvPV(*svp, key_len); + if (hv_exists((HV *) This, key, key_len)) + RETPUSHYES; + } } - RETPUSHYES; + RETPUSHNO; } else if (SM_OTHER_REGEX) { PMOP * const matcher = make_matcher(other_regex); @@ -4006,12 +4105,12 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) RETPUSHNO; } else { - hv_store_ent(seen_this, - sv_2mortal(newSViv(PTR2IV(*this_elem))), - &PL_sv_undef, 0); - hv_store_ent(seen_other, - sv_2mortal(newSViv(PTR2IV(*other_elem))), - &PL_sv_undef, 0); + (void)hv_store_ent(seen_this, + sv_2mortal(newSViv(PTR2IV(*this_elem))), + &PL_sv_undef, 0); + (void)hv_store_ent(seen_other, + sv_2mortal(newSViv(PTR2IV(*other_elem))), + &PL_sv_undef, 0); PUSHs(*this_elem); PUSHs(*other_elem); @@ -4527,7 +4626,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) /* I was having segfault trouble under Linux 2.2.5 after a parse error occured. (Had to hack around it with a test - for PL_error_count == 0.) Solaris doesn't segfault -- + for PL_parser->error_count == 0.) Solaris doesn't segfault -- not sure where the trouble is yet. XXX */ if (IoFMT_GV(datasv)) { @@ -4592,7 +4691,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) DEFSV = upstream; PUSHMARK(SP); - PUSHs(sv_2mortal(newSViv(0))); + mPUSHi(0); if (filter_state) { PUSHs(filter_state); }