#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
+#define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
+
PP(pp_wantarray)
{
dVAR;
register PMOP *pm = (PMOP*)cLOGOP->op_other;
SV *tmpstr;
MAGIC *mg = NULL;
+ regexp * re;
/* prevent recompiling under /o and ithreads. */
#if defined(USE_ITHREADS)
}
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))
{
const regexp_engine *eng = re ? re->engine : NULL;
-
+ U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
if (re) {
ReREFCNT_dec(re);
PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
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 (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);
+ pm_flags |= RXf_UTF8;
+
+ 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;
+ re->extflags |= RXf_TAINTED;
else
- pm->op_pmdynflags &= ~PMdf_TAINTED;
+ re->extflags &= ~RXf_TAINTED;
}
#endif
if (!PM_GETRE(pm)->prelen && PL_curpm)
pm = PL_curpm;
- else if (PM_GETRE(pm)->extflags & RXf_WHITE)
- 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;
}
(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
}
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;
sv_catsv(PL_errors, err);
else
Perl_warn(aTHX_ "%"SVf, SVfARG(err));
- ++PL_error_count;
+ if (PL_parser)
+ ++PL_parser->error_count;
}
OP *
}
}
-STATIC void
-S_docatch_body(pTHX)
-{
- dVAR;
- CALLRUNOPS(aTHX);
- return;
-}
-
STATIC OP *
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 */
I32 gimme = G_VOID;
I32 optype;
OP dummy;
- OP *rop;
char tbuf[TYPE_DIGITS(long) + 12 + 10];
char *tmpbuf = tbuf;
char *safestr;
STRLEN len;
ENTER;
- lex_start(sv);
+ lex_start(sv, NULL, FALSE);
SAVETMPS;
/* switch to eval mode */
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);
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(optype);
- return rop;
+ return PL_eval_start;
}
* 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).
*/
-STATIC OP *
+STATIC bool
S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
{
dVAR; dSP;
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. */
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);
}
}
PERL_UNUSED_VAR(newsp);
- RETPUSHUNDEF;
+ PUSHs(&PL_sv_undef);
+ PUTBACK;
+ return FALSE;
}
CopLINE_set(&PL_compiling, 0);
if (startop) {
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);
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)
{
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;
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);
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;
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);
}
}
if (path_is_absolute(name)) {
tryname = name;
- tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
+ tryrsfp = doopen_pm(name, len);
}
#ifdef MACOS_TRADITIONAL
if (!tryrsfp) {
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
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);
|| (*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];
"%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;
/* 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();
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;
char *tmpbuf = tbuf;
char *safestr;
STRLEN len;
- OP *ret;
+ bool ok;
CV* runcv;
U32 seq;
HV *saved_hh = NULL;
TAINT_PROPER("eval");
ENTER;
- lex_start(sv);
+ lex_start(sv, NULL, FALSE);
SAVETMPS;
/* switch to eval mode */
/* 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)
}
/* Helper routines used by pp_smartmatch */
-STATIC
-PMOP *
+STATIC PMOP *
S_make_matcher(pTHX_ regexp *re)
{
dVAR;
return matcher;
}
-STATIC
-bool
+STATIC bool
S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
{
dVAR;
return (SvTRUEx(POPs));
}
-STATIC
-void
+STATIC void
S_destroy_matcher(pTHX_ PMOP *matcher)
{
dVAR;
/* 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;
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);
/* 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)) {
https://perl5.git.perl.org / perl5.git / blobdiff