X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=39f18b227bd38bc120bcc8038cc35a5b61473b0d;hb=4d7c789858ca4beacd2cf4028e969fabc2a97426;hp=ba0a503aca70de49af22a1585096e5276eb226a6;hpb=04fe65b0c880322a5ab5677fef6303b6149b8676;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index ba0a503..39f18b2 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -38,6 +38,8 @@ #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) +#define dopoptosub(plop) dopoptosub_at(cxstack, (plop)) + PP(pp_wantarray) { dVAR; @@ -1300,13 +1302,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; @@ -2665,14 +2660,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) { @@ -2693,7 +2680,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 */ @@ -3019,7 +3006,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) } 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); @@ -3028,36 +3015,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) { @@ -3085,10 +3076,14 @@ 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, TRUE); @@ -3098,20 +3093,68 @@ PP(pp_require) SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel))); } else { - if ( vcmp(sv,PL_patchlevel) > 0 ) - DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped", - SVfARG(vnormal(sv)), SVfARG(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))); + } + } } - /* If we request a version >= 5.9.5, load feature.pm with the - * feature bundle that corresponds to the required version. - * We do this only with use, not require. */ - if (PL_compcv && vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) { + /* 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; @@ -3149,7 +3192,8 @@ PP(pp_require) 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); } } @@ -3157,7 +3201,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) { @@ -3166,7 +3210,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 @@ -3178,6 +3222,7 @@ PP(pp_require) #endif { namesv = newSV(0); + sv_upgrade(namesv, SVt_PV); for (i = 0; i <= AvFILL(ar); i++) { SV * const dirsv = *av_fetch(ar, i, TRUE); @@ -3307,7 +3352,16 @@ PP(pp_require) || (*name == ':' && name[1] != ':' && strchr(name+2, ':')) #endif ) { - const char *dir = SvOK(dirsv) ? SvPV_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]; @@ -3335,13 +3389,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;