X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=8b320bf92a6de0f1ef1a469808db70b86994cc1e;hb=bb407f0b8769c638c05e60ebfd157a1e676a6c22;hp=93b89b14a729cf4773a397d7e032b19b29d9d9c7;hpb=a4f3a277dab3a9e285418160103305f0e5819cf9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 93b89b1..8b320bf 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -26,24 +26,19 @@ #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) -static I32 sortcv(pTHXo_ SV *a, SV *b); -static I32 sortcv_stacked(pTHXo_ SV *a, SV *b); -static I32 sortcv_xsub(pTHXo_ SV *a, SV *b); -static I32 sv_ncmp(pTHXo_ SV *a, SV *b); -static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b); -static I32 amagic_ncmp(pTHXo_ SV *a, SV *b); -static I32 amagic_i_ncmp(pTHXo_ SV *a, SV *b); -static I32 amagic_cmp(pTHXo_ SV *a, SV *b); -static I32 amagic_cmp_locale(pTHXo_ SV *a, SV *b); -static I32 run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen); - -#ifdef PERL_OBJECT -static I32 sv_cmp_static(pTHXo_ SV *a, SV *b); -static I32 sv_cmp_locale_static(pTHXo_ SV *a, SV *b); -#else +static I32 sortcv(pTHX_ SV *a, SV *b); +static I32 sortcv_stacked(pTHX_ SV *a, SV *b); +static I32 sortcv_xsub(pTHX_ SV *a, SV *b); +static I32 sv_ncmp(pTHX_ SV *a, SV *b); +static I32 sv_i_ncmp(pTHX_ SV *a, SV *b); +static I32 amagic_ncmp(pTHX_ SV *a, SV *b); +static I32 amagic_i_ncmp(pTHX_ SV *a, SV *b); +static I32 amagic_cmp(pTHX_ SV *a, SV *b); +static I32 amagic_cmp_locale(pTHX_ SV *a, SV *b); +static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen); + #define sv_cmp_static Perl_sv_cmp #define sv_cmp_locale_static Perl_sv_cmp_locale -#endif PP(pp_wantarray) { @@ -86,29 +81,36 @@ PP(pp_regcomp) SV *tmpstr; STRLEN len; MAGIC *mg = Null(MAGIC*); - + tmpstr = POPs; + + /* prevent recompiling under /o and ithreads. */ +#if defined(USE_ITHREADS) || defined(USE_5005THREADS) + if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) + RETURN; +#endif + if (SvROK(tmpstr)) { SV *sv = SvRV(tmpstr); if(SvMAGICAL(sv)) - mg = mg_find(sv, 'r'); + mg = mg_find(sv, PERL_MAGIC_qr); } if (mg) { regexp *re = (regexp *)mg->mg_obj; - ReREFCNT_dec(pm->op_pmregexp); - pm->op_pmregexp = ReREFCNT_inc(re); + ReREFCNT_dec(PM_GETRE(pm)); + PM_SETRE(pm, ReREFCNT_inc(re)); } else { t = SvPV(tmpstr, len); /* Check against the last compiled regexp. */ - if (!pm->op_pmregexp || !pm->op_pmregexp->precomp || - pm->op_pmregexp->prelen != len || - memNE(pm->op_pmregexp->precomp, t, len)) + if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp || + PM_GETRE(pm)->prelen != len || + memNE(PM_GETRE(pm)->precomp, t, len)) { - if (pm->op_pmregexp) { - ReREFCNT_dec(pm->op_pmregexp); - pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */ + if (PM_GETRE(pm)) { + ReREFCNT_dec(PM_GETRE(pm)); + PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */ } if (PL_op->op_flags & OPf_SPECIAL) PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ @@ -121,7 +123,7 @@ PP(pp_regcomp) if (pm->op_pmdynflags & PMdf_UTF8) t = (char*)bytes_to_utf8((U8*)t, &len); } - pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm); + PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm)); if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8)) Safefree(t); PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed @@ -138,15 +140,17 @@ PP(pp_regcomp) } #endif - if (!pm->op_pmregexp->prelen && PL_curpm) + if (!PM_GETRE(pm)->prelen && PL_curpm) pm = PL_curpm; - else if (strEQ("\\s+", pm->op_pmregexp->precomp)) + 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 (pm->op_pmflags & PMf_KEEP) { pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ -#if !defined(USE_ITHREADS) && !defined(USE_THREADS) +#if !defined(USE_ITHREADS) && !defined(USE_5005THREADS) /* XXX can't change the optree at runtime either */ cLOGOP->op_first->op_next = PL_op->op_next; #endif @@ -227,9 +231,9 @@ PP(pp_substcont) I32 i; if (SvTYPE(sv) < SVt_PVMG) (void)SvUPGRADE(sv, SVt_PVMG); - if (!(mg = mg_find(sv, 'g'))) { - sv_magic(sv, Nullsv, 'g', Nullch, 0); - mg = mg_find(sv, 'g'); + if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { + sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0); + mg = mg_find(sv, PERL_MAGIC_regex_global); } i = m - orig; if (DO_UTF8(sv)) @@ -312,18 +316,18 @@ PP(pp_formline) register char *s; register char *send; register I32 arg; - register SV *sv; - char *item; - I32 itemsize; - I32 fieldsize; + register SV *sv = Nullsv; + char *item = Nullch; + I32 itemsize = 0; + I32 fieldsize = 0; I32 lines = 0; bool chopspace = (strchr(PL_chopset, ' ') != Nullch); - char *chophere; - char *linemark; + char *chophere = Nullch; + char *linemark = Nullch; NV value; - bool gotsome; + bool gotsome = FALSE; STRLEN len; - STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1; + STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1; bool item_is_utf = FALSE; if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { @@ -373,7 +377,7 @@ PP(pp_formline) PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg); else PerlIO_printf(Perl_debug_log, "%-16s\n", name); - } ) + } ); switch (*fpc++) { case FF_LINEMARK: linemark = t; @@ -551,7 +555,13 @@ PP(pp_formline) if (item_is_utf) { while (arg--) { if (UTF8_IS_CONTINUED(*s)) { - switch (UTF8SKIP(s)) { + STRLEN skip = UTF8SKIP(s); + switch (skip) { + default: + Move(s,t,skip,char); + s += skip; + t += skip; + break; case 7: *t++ = *s++; case 6: *t++ = *s++; case 5: *t++ = *s++; @@ -765,7 +775,7 @@ PP(pp_grepstart) ENTER; /* enter outer scope */ SAVETMPS; - /* SAVE_DEFSV does *not* suffice here for USE_THREADS */ + /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */ SAVESPTR(DEFSV); ENTER; /* enter inner scope */ SAVEVPTR(PL_curpm); @@ -881,7 +891,7 @@ PP(pp_sort) register I32 max; HV *stash; GV *gv; - CV *cv; + CV *cv = 0; I32 gimme = GIMME; OP* nextop = PL_op->op_next; I32 overloading = 0; @@ -979,7 +989,7 @@ PP(pp_sort) PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV); PL_sortstash = stash; } -#ifdef USE_THREADS +#ifdef USE_5005THREADS sv_lock((SV *)PL_firstgv); sv_lock((SV *)PL_secondgv); #endif @@ -1001,10 +1011,10 @@ PP(pp_sort) /* This is mostly copied from pp_entersub */ AV *av = (AV*)PL_curpad[0]; -#ifndef USE_THREADS +#ifndef USE_5005THREADS cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ cx->blk_sub.oldcurpad = PL_curpad; cx->blk_sub.argarray = av; } @@ -1025,7 +1035,7 @@ PP(pp_sort) ? ( (PL_op->op_private & OPpSORT_INTEGER) ? ( overloading ? amagic_i_ncmp : sv_i_ncmp) : ( overloading ? amagic_ncmp : sv_ncmp)) - : ( (PL_op->op_private & OPpLOCALE) + : ( IN_LOCALE_RUNTIME ? ( overloading ? amagic_cmp_locale : sv_cmp_locale_static) @@ -1073,7 +1083,7 @@ PP(pp_flip) if (PL_op->op_private & OPpFLIP_LINENUM) { struct io *gp_io; flip = PL_last_in_gv - && (gp_io = GvIOp(PL_last_in_gv)) + && (gp_io = GvIO(PL_last_in_gv)) && SvIV(sv) == (IV)IoLINES(gp_io); } else { flip = SvTRUE(sv); @@ -1154,7 +1164,8 @@ PP(pp_flop) SV *targ = PAD_SV(cUNOP->op_first->op_targ); sv_inc(targ); if ((PL_op->op_private & OPpFLIP_LINENUM) - ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv))) + ? (GvIO(PL_last_in_gv) + && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv))) : SvTRUE(sv) ) { sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); sv_catpv(targ, "E0"); @@ -1179,27 +1190,27 @@ S_dopoptolabel(pTHX_ char *label) case CXt_SUBST: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); break; case CXt_SUB: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); break; case CXt_FORMAT: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); break; case CXt_EVAL: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); break; case CXt_NULL: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); return -1; case CXt_LOOP: if (!cx->blk_loop.label || @@ -1314,27 +1325,27 @@ S_dopoptoloop(pTHX_ I32 startingblock) case CXt_SUBST: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); break; case CXt_SUB: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); break; case CXt_FORMAT: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); break; case CXt_EVAL: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); break; case CXt_NULL: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); return -1; case CXt_LOOP: DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); @@ -1427,10 +1438,6 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) } else { sv_setpvn(ERRSV, message, msglen); - if (PL_hints & HINT_UTF8) - SvUTF8_on(ERRSV); - else - SvUTF8_off(ERRSV); } } else @@ -1486,7 +1493,7 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) #endif PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); (void)PerlIO_flush(serr); #ifdef USE_SFIO errno = e; @@ -1539,7 +1546,7 @@ PP(pp_caller) if (MAXARG) count = POPi; - EXTEND(SP, 10); + for (;;) { /* we may be in a higher stacklevel, so dig down deeper */ while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { @@ -1548,8 +1555,10 @@ PP(pp_caller) cxix = dopoptosub_at(ccstack, top_si->si_cxix); } if (cxix < 0) { - if (GIMME != G_ARRAY) + if (GIMME != G_ARRAY) { + EXTEND(SP, 1); RETPUSHUNDEF; + } RETURN; } if (PL_DBsub && cxix >= 0 && @@ -1571,6 +1580,7 @@ PP(pp_caller) stashname = CopSTASHPV(cx->blk_oldcop); if (GIMME != G_ARRAY) { + EXTEND(SP, 1); if (!stashname) PUSHs(&PL_sv_undef); else { @@ -1581,6 +1591,8 @@ PP(pp_caller) RETURN; } + EXTEND(SP, 10); + if (!stashname) PUSHs(&PL_sv_undef); else @@ -1753,21 +1765,21 @@ PP(pp_enteriter) ENTER; SAVETMPS; -#ifdef USE_THREADS +#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_THREADS */ +#endif /* USE_5005THREADS */ if (PL_op->op_targ) { #ifndef USE_ITHREADS svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */ SAVESPTR(*svp); #else SAVEPADSV(PL_op->op_targ); - iterdata = (void*)PL_op->op_targ; + iterdata = INT2PTR(void*, PL_op->op_targ); cxtype |= CXp_PADVAR; #endif } @@ -2223,7 +2235,7 @@ PP(pp_goto) if (cxix < cxstack_ix) dounwind(cxix); TOPBLOCK(cx); - if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) + if (CxREALEVAL(cx)) DIE(aTHX_ "Can't goto subroutine from an eval-string"); mark = PL_stack_sp; if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { @@ -2235,10 +2247,10 @@ PP(pp_goto) EXTEND(PL_stack_sp, items); /* @_ could have been extended. */ Copy(AvARRAY(av), PL_stack_sp, items, SV*); PL_stack_sp += items; -#ifndef USE_THREADS +#ifndef USE_5005THREADS SvREFCNT_dec(GvAV(PL_defgv)); GvAV(PL_defgv) = cx->blk_sub.savearray; -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ /* abandon @_ if it got reified */ if (AvREAL(av)) { (void)sv_2mortal((SV*)av); /* delay until return */ @@ -2250,7 +2262,7 @@ PP(pp_goto) } else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ AV* av; -#ifdef USE_THREADS +#ifdef USE_5005THREADS av = (AV*)PL_curpad[0]; #else av = GvAV(PL_defgv); @@ -2292,7 +2304,7 @@ PP(pp_goto) PL_stack_sp--; /* There is no cv arg. */ /* Push a mark for the start of arglist */ PUSHMARK(mark); - (void)(*CvXSUB(cv))(aTHXo_ cv); + (void)(*CvXSUB(cv))(aTHX_ cv); /* Pop the current context like a decent sub should */ POPBLOCK(cx, PL_curpm); /* Do _not_ use PUTBACK, keep the XSUB's return stack! */ @@ -2362,7 +2374,7 @@ PP(pp_goto) svp = AvARRAY(padlist); } } -#ifdef USE_THREADS +#ifdef USE_5005THREADS if (!cx->blk_sub.hasargs) { AV* av = (AV*)PL_curpad[0]; @@ -2375,20 +2387,20 @@ PP(pp_goto) PUTBACK ; } } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ SAVEVPTR(PL_curpad); PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); -#ifndef USE_THREADS +#ifndef USE_5005THREADS if (cx->blk_sub.hasargs) -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ { AV* av = (AV*)PL_curpad[0]; SV** ary; -#ifndef USE_THREADS +#ifndef USE_5005THREADS cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ cx->blk_sub.oldcurpad = PL_curpad; cx->blk_sub.argarray = av; ++mark; @@ -2788,7 +2800,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp) return rop; } -/* With USE_THREADS, eval_owner must be held on entry to doeval */ +/* With USE_5005THREADS, eval_owner must be held on entry to doeval */ STATIC OP * S_doeval(pTHX_ int gimme, OP** startop) { @@ -2829,11 +2841,14 @@ S_doeval(pTHX_ int gimme, OP** startop) PL_compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)PL_compcv, SVt_PVCV); CvEVAL_on(PL_compcv); -#ifdef USE_THREADS + 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_THREADS */ +#endif /* USE_5005THREADS */ PL_comppad = newAV(); av_push(PL_comppad, Nullsv); @@ -2842,11 +2857,11 @@ S_doeval(pTHX_ int gimme, OP** startop) PL_comppad_name_fill = 0; PL_min_intro_pending = 0; PL_padix = 0; -#ifdef USE_THREADS +#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_THREADS */ +#endif /* USE_5005THREADS */ comppadlist = newAV(); AvREAL_off(comppadlist); @@ -2860,7 +2875,7 @@ S_doeval(pTHX_ int gimme, OP** startop) CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller); } - SAVEFREESV(PL_compcv); + SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ /* make sure we compile in the right package */ @@ -2879,8 +2894,6 @@ S_doeval(pTHX_ int gimme, OP** startop) PL_error_count = 0; PL_curcop = &PL_compiling; PL_curcop->cop_arybase = 0; - SvREFCNT_dec(PL_rs); - PL_rs = newSVpvn("\n", 1); if (saveop && saveop->op_flags & OPf_SPECIAL) PL_in_eval |= EVAL_KEEPERR; else @@ -2918,18 +2931,14 @@ S_doeval(pTHX_ int gimme, OP** startop) Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n")); } - SvREFCNT_dec(PL_rs); - PL_rs = SvREFCNT_inc(PL_nrs); -#ifdef USE_THREADS +#ifdef USE_5005THREADS MUTEX_LOCK(&PL_eval_mutex); PL_eval_owner = 0; COND_SIGNAL(&PL_eval_cond); MUTEX_UNLOCK(&PL_eval_mutex); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ RETPUSHUNDEF; } - SvREFCNT_dec(PL_rs); - PL_rs = SvREFCNT_inc(PL_nrs); CopLINE_set(&PL_compiling, 0); if (startop) { *startop = PL_eval_root; @@ -2964,12 +2973,12 @@ S_doeval(pTHX_ int gimme, OP** startop) 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 +#ifdef USE_5005THREADS MUTEX_LOCK(&PL_eval_mutex); PL_eval_owner = 0; COND_SIGNAL(&PL_eval_cond); MUTEX_UNLOCK(&PL_eval_mutex); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ RETURNOP(PL_eval_start); } @@ -3013,20 +3022,21 @@ PP(pp_require) SV *sv; char *name; STRLEN len; - char *tryname; + char *tryname = Nullch; SV *namesv = Nullsv; SV** svp; - I32 gimme = G_SCALAR; + I32 gimme = GIMME_V; PerlIO *tryrsfp = 0; STRLEN n_a; int filter_has_file = 0; GV *filter_child_proc = 0; SV *filter_state = 0; SV *filter_sub = 0; + SV *hook_sv = 0; sv = POPs; if (SvNIOKp(sv)) { - if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */ + if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */ UV rev = 0, ver = 0, sver = 0; STRLEN len; U8 *s = (U8*)SvPVX(sv); @@ -3051,6 +3061,9 @@ PP(pp_require) "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION, PERL_VERSION, PERL_SUBVERSION); } + if (ckWARN(WARN_PORTABLE)) + Perl_warner(aTHX_ WARN_PORTABLE, + "v-string in use/require non-portable"); RETPUSHYES; } else if (!SvPOKp(sv)) { /* require 5.005_03 */ @@ -3069,7 +3082,7 @@ PP(pp_require) if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) { DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--" "this is only v%d.%d.%d, stopped" - " (did you mean v%"UVuf".%"UVuf".0?)", + " (did you mean v%"UVuf".%03"UVuf"?)", rev, ver, sver, PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, rev, ver/100); } @@ -3133,12 +3146,14 @@ trylocal: { int count; SV *loader = dirsv; - if (SvTYPE(SvRV(loader)) == SVt_PVAV) { + if (SvTYPE(SvRV(loader)) == SVt_PVAV + && !sv_isobject(loader)) + { loader = *av_fetch((AV *)SvRV(loader), 0, TRUE); } Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s", - PTR2UV(SvANY(loader)), name); + PTR2UV(SvRV(dirsv)), name); tryname = SvPVX(namesv); tryrsfp = 0; @@ -3219,6 +3234,7 @@ trylocal: { LEAVE; if (tryrsfp) { + hook_sv = dirsv; break; } @@ -3307,8 +3323,14 @@ trylocal: { SETERRNO(0, SS$_NORMAL); /* Assume success here to prevent recursive requirement. */ - (void)hv_store(GvHVn(PL_incgv), name, strlen(name), - newSVpv(CopFILE(&PL_compiling), 0), 0 ); + len = strlen(name); + /* Check whether a hook in @INC has already filled %INC */ + if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) { + (void)hv_store(GvHVn(PL_incgv), name, len, + (hook_sv ? SvREFCNT_inc(hook_sv) + : newSVpv(CopFILE(&PL_compiling), 0)), + 0 ); + } ENTER; SAVETMPS; @@ -3346,15 +3368,15 @@ trylocal: { CopLINE_set(&PL_compiling, 0); PUTBACK; -#ifdef USE_THREADS +#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_THREADS */ - return DOCATCH(doeval(G_SCALAR, NULL)); +#endif /* USE_5005THREADS */ + return DOCATCH(doeval(gimme, NULL)); } PP(pp_dofile) @@ -3430,14 +3452,14 @@ PP(pp_entereval) if (PERLDB_LINE && PL_curstash != PL_debstash) save_lines(CopFILEAV(&PL_compiling), PL_linestr); PUTBACK; -#ifdef USE_THREADS +#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_THREADS */ +#endif /* USE_5005THREADS */ ret = doeval(gimme, NULL); if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */ && ret != PL_op->op_next) { /* Successive compilation. */ @@ -3586,14 +3608,14 @@ S_doparseform(pTHX_ SV *sv) STRLEN len; register char *s = SvPV_force(sv, len); register char *send = s + len; - register char *base; + register char *base = Nullch; register I32 skipspaces = 0; - bool noblank; - bool repeat; + bool noblank = FALSE; + bool repeat = FALSE; bool postspace = FALSE; U16 *fops; register U16 *fpc; - U16 *linepc; + U16 *linepc = 0; register I32 arg; bool ischop; @@ -3772,7 +3794,7 @@ S_doparseform(pTHX_ SV *sv) } Copy(fops, s, arg, U16); Safefree(fops); - sv_magic(sv, Nullsv, 'f', Nullch, 0); + sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0); SvCOMPILED_on(sv); } @@ -3793,12 +3815,11 @@ S_doparseform(pTHX_ SV *sv) #ifdef TESTHARNESS #include typedef void SV; -#define pTHXo_ #define pTHX_ #define STATIC #define New(ID,VAR,N,TYPE) VAR=(TYPE *)malloc((N)*sizeof(TYPE)) #define Safefree(VAR) free(VAR) -typedef int (*SVCOMPARE_t) (pTHXo_ SV*, SV*); +typedef int (*SVCOMPARE_t) (pTHX_ SV*, SV*); #endif /* TESTHARNESS */ typedef char * aptr; /* pointer for arithmetic on sizes */ @@ -4142,16 +4163,8 @@ S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp) return; } - -#ifdef PERL_OBJECT -#undef this -#define this pPerl -#include "XSUB.h" -#endif - - static I32 -sortcv(pTHXo_ SV *a, SV *b) +sortcv(pTHX_ SV *a, SV *b) { I32 oldsaveix = PL_savestack_ix; I32 oldscopeix = PL_scopestack_ix; @@ -4174,14 +4187,14 @@ sortcv(pTHXo_ SV *a, SV *b) } static I32 -sortcv_stacked(pTHXo_ SV *a, SV *b) +sortcv_stacked(pTHX_ SV *a, SV *b) { I32 oldsaveix = PL_savestack_ix; I32 oldscopeix = PL_scopestack_ix; I32 result; AV *av; -#ifdef USE_THREADS +#ifdef USE_5005THREADS av = (AV*)PL_curpad[0]; #else av = GvAV(PL_defgv); @@ -4219,7 +4232,7 @@ sortcv_stacked(pTHXo_ SV *a, SV *b) } static I32 -sortcv_xsub(pTHXo_ SV *a, SV *b) +sortcv_xsub(pTHX_ SV *a, SV *b) { dSP; I32 oldsaveix = PL_savestack_ix; @@ -4233,7 +4246,7 @@ sortcv_xsub(pTHXo_ SV *a, SV *b) *++SP = a; *++SP = b; PUTBACK; - (void)(*CvXSUB(cv))(aTHXo_ cv); + (void)(*CvXSUB(cv))(aTHX_ cv); if (PL_stack_sp != PL_stack_base + 1) Perl_croak(aTHX_ "Sort subroutine didn't return single value"); if (!SvNIOKp(*PL_stack_sp)) @@ -4248,7 +4261,7 @@ sortcv_xsub(pTHXo_ SV *a, SV *b) static I32 -sv_ncmp(pTHXo_ SV *a, SV *b) +sv_ncmp(pTHX_ SV *a, SV *b) { NV nv1 = SvNV(a); NV nv2 = SvNV(b); @@ -4256,7 +4269,7 @@ sv_ncmp(pTHXo_ SV *a, SV *b) } static I32 -sv_i_ncmp(pTHXo_ SV *a, SV *b) +sv_i_ncmp(pTHX_ SV *a, SV *b) { IV iv1 = SvIV(a); IV iv2 = SvIV(b); @@ -4274,7 +4287,7 @@ sv_i_ncmp(pTHXo_ SV *a, SV *b) } STMT_END static I32 -amagic_ncmp(pTHXo_ register SV *a, register SV *b) +amagic_ncmp(pTHX_ register SV *a, register SV *b) { SV *tmpsv; tryCALL_AMAGICbin(a,b,ncmp,&tmpsv); @@ -4292,11 +4305,11 @@ amagic_ncmp(pTHXo_ register SV *a, register SV *b) return 1; return d? -1 : 0; } - return sv_ncmp(aTHXo_ a, b); + return sv_ncmp(aTHX_ a, b); } static I32 -amagic_i_ncmp(pTHXo_ register SV *a, register SV *b) +amagic_i_ncmp(pTHX_ register SV *a, register SV *b) { SV *tmpsv; tryCALL_AMAGICbin(a,b,ncmp,&tmpsv); @@ -4314,11 +4327,11 @@ amagic_i_ncmp(pTHXo_ register SV *a, register SV *b) return 1; return d? -1 : 0; } - return sv_i_ncmp(aTHXo_ a, b); + return sv_i_ncmp(aTHX_ a, b); } static I32 -amagic_cmp(pTHXo_ register SV *str1, register SV *str2) +amagic_cmp(pTHX_ register SV *str1, register SV *str2) { SV *tmpsv; tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv); @@ -4340,7 +4353,7 @@ amagic_cmp(pTHXo_ register SV *str1, register SV *str2) } static I32 -amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2) +amagic_cmp_locale(pTHX_ register SV *str1, register SV *str2) { SV *tmpsv; tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv); @@ -4362,7 +4375,7 @@ amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2) } static I32 -run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen) +run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) { SV *datasv = FILTER_DATA(idx); int filter_has_file = IoLINES(datasv); @@ -4430,19 +4443,3 @@ run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen) return len; } - -#ifdef PERL_OBJECT - -static I32 -sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2) -{ - return sv_cmp_locale(str1, str2); -} - -static I32 -sv_cmp_static(pTHXo_ register SV *str1, register SV *str2) -{ - return sv_cmp(str1, str2); -} - -#endif /* PERL_OBJECT */