/* 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.
if (!re || !re->precomp || re->prelen != (I32)len ||
memNE(re->precomp, t, len))
{
+ const regexp_engine *eng = re ? re->engine : NULL;
+
if (re) {
ReREFCNT_dec(re);
PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
+ } else if (PL_curcop->cop_hints_hash) {
+ SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
+ "regcomp", 7, 0, 0);
+ if (ptr && SvIOK(ptr) && SvIV(ptr))
+ eng = INT2PTR(regexp_engine*,SvIV(ptr));
}
+
if (PL_op->op_flags & OPf_SPECIAL)
PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
if (pm->op_pmdynflags & PMdf_UTF8)
t = (char*)bytes_to_utf8((U8*)t, &len);
}
- PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm));
+ 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);
PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
if (!PM_GETRE(pm)->prelen && PL_curpm)
pm = PL_curpm;
- else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
+ else if (PM_GETRE(pm)->extflags & RXf_WHITE)
pm->op_pmflags |= PMf_WHITE;
else
pm->op_pmflags &= ~PMf_WHITE;
FREETMPS; /* Prevent excess tmp stack */
/* Are we done */
- if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
+ if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
s == m, cx->sb_targ, NULL,
((cx->sb_rflags & REXEC_COPY_STR)
? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
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(lsv))
+ if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
#endif
mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
const I32 cxix = dopoptosub(cxstack_ix);
assert(cxix >= 0); /* We should only be called from inside subs */
- if (CX_SUB_LVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
- return CX_SUB_LVAL(cxstack + cxix);
+ if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
+ return cxstack[cxix].blk_sub.lval;
else
return 0;
}
else if (PL_errors)
sv_catsv(PL_errors, err);
else
- Perl_warn(aTHX_ "%"SVf, (void*)err);
+ Perl_warn(aTHX_ "%"SVf, SVfARG(err));
++PL_error_count;
}
SV * const sv = newSV(0);
gv_efullname3(sv, cvgv, NULL);
PUSHs(sv_2mortal(sv));
- PUSHs(sv_2mortal(newSViv((I32)CX_SUB_HASARGS_GET(cx))));
+ PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
}
else {
PUSHs(sv_2mortal(newSVpvs("(unknown)")));
- PUSHs(sv_2mortal(newSViv((I32)CX_SUB_HASARGS_GET(cx))));
+ PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
}
}
else {
PUSHs(&PL_sv_undef);
PUSHs(&PL_sv_undef);
}
- if (CxTYPE(cx) == CXt_SUB && CX_SUB_HASARGS_GET(cx)
+ if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
&& CopSTASH_eq(PL_curcop, PL_debstash))
{
AV * const ary = cx->blk_sub.argarray;
/* 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:
case CXt_LOOP:
pop2 = CXt_LOOP;
newsp = PL_stack_base + cx->blk_loop.resetsp;
- nextop = cx->blk_loop.last_op->op_next;
+ nextop = cx->blk_loop.my_op->op_lastop->op_next;
break;
case CXt_SUB:
pop2 = CXt_SUB;
if (PL_scopestack_ix < inner)
leave_scope(PL_scopestack[PL_scopestack_ix]);
PL_curcop = cx->blk_oldcop;
- return cx->blk_loop.next_op;
+ return CX_LOOP_NEXTOP_GET(cx);
}
PP(pp_redo)
if (cxix < cxstack_ix)
dounwind(cxix);
- redo_op = cxstack[cxix].blk_loop.redo_op;
+ redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
if (redo_op->op_type == OP_ENTER) {
/* pop one less context to avoid $x being freed in while (my $x..) */
cxstack_ix++;
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");
}
}
else if (CxMULTICALL(cx))
DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
- if (CxTYPE(cx) == CXt_SUB && CX_SUB_HASARGS_GET(cx)) {
+ if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
/* put @_ back onto stack */
AV* av = cx->blk_sub.argarray;
PL_in_eval = cx->blk_eval.old_in_eval;
PL_eval_root = cx->blk_eval.old_eval_root;
cx->cx_type = CXt_SUB;
- CX_SUB_HASARGS_SET(cx, 0);
+ cx->blk_sub.hasargs = 0;
}
cx->blk_sub.cv = cv;
cx->blk_sub.olddepth = CvDEPTH(cv);
}
SAVECOMPPAD();
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
- if (CX_SUB_HASARGS_GET(cx))
+ if (cx->blk_sub.hasargs)
{
AV* const av = (AV*)PAD_SVl(0);
SV **ary = AvALLOC(av);
if (AvARRAY(av) != ary) {
AvMAX(av) += AvARRAY(av) - AvALLOC(av);
- SvPV_set(av, (char*)ary);
+ AvARRAY(av) = ary;
}
if (items >= AvMAX(av) + 1) {
AvMAX(av) = items - 1;
Renew(ary,items+1,SV*);
AvALLOC(av) = ary;
- SvPV_set(av, (char*)ary);
+ AvARRAY(av) = ary;
}
}
++mark;
}
}
if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
- /*
- * We do not care about using sv to call CV;
- * it's for informational purposes only.
- */
- SV * const sv = GvSV(PL_DBsub);
- save_item(sv);
- if (PERLDB_SUB_NN) {
- const int type = SvTYPE(sv);
- if (type < SVt_PVIV && type != SVt_IV)
- sv_upgrade(sv, SVt_PVIV);
- (void)SvIOK_on(sv);
- SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
- } else {
- gv_efullname3(sv, CvGV(cv), NULL);
- }
+ Perl_get_db_sub(aTHX_ NULL, cv);
if (PERLDB_GOTO) {
CV * const gotocv = get_cv("DB::goto", FALSE);
if (gotocv) {
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++;
* outside is the lexically enclosing CV (if any) that invoked us.
*/
-/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
STATIC OP *
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;
SAVESPTR(PL_curstash);
PL_curstash = CopSTASH(PL_curcop);
}
+ /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
SAVESPTR(PL_beginav);
PL_beginav = newAV();
SAVEFREESV(PL_beginav);
+ SAVESPTR(PL_unitcheckav);
+ PL_unitcheckav = newAV();
+ SAVEFREESV(PL_unitcheckav);
SAVEI32(PL_error_count);
#ifdef PERL_MAD
}
else {
if (!*msg) {
- sv_setpv(ERRSV, "Compilation error");
+ sv_setpvs(ERRSV, "Compilation error");
}
}
PERL_UNUSED_VAR(newsp);
}
}
+ if (PL_unitcheckav)
+ call_list(PL_scopestack_ix, PL_unitcheckav);
+
/* compiled okay, so do it */
CvDEPTH(PL_compcv) = 1;
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));
+ SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
}
- RETPUSHYES;
+ /* 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)))) >= 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))
for (i = 0; i <= AvFILL(ar); i++) {
SV * const dirsv = *av_fetch(ar, i, TRUE);
+ if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
+ mg_get(dirsv);
if (SvROK(dirsv)) {
int count;
+ SV **svp;
SV *loader = dirsv;
if (SvTYPE(SvRV(loader)) == SVt_PVAV
count = call_sv(loader, G_ARRAY);
SPAGAIN;
+ /* Adjust file name if the hook has set an %INC entry */
+ svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+ if (svp)
+ tryname = SvPVX_const(*svp);
+
if (count > 0) {
int i = 0;
SV *arg;
ENTER;
SAVETMPS;
- lex_start(sv_2mortal(newSVpvs("")));
+ lex_start(NULL);
SAVEGENERICSV(PL_rsfp_filters);
PL_rsfp_filters = NULL;
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 ;
}
sv = POPs;
- if (!SvPV_nolen_const(sv))
- RETPUSHUNDEF;
+ TAINT_IF(SvTAINTED(sv));
TAINT_PROPER("eval");
ENTER;
/* 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 {
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)
PL_curcop = cx->blk_oldcop;
if (CxFOREACH(cx))
- return cx->blk_loop.next_op;
+ return CX_LOOP_NEXTOP_GET(cx);
else
return cx->blk_givwhen.leave_op;
}
projects / p5sagit/p5-mst-13.2.git / blobdiff