dSP;
register PMOP *pm = (PMOP*)cLOGOP->op_other;
SV *tmpstr;
- MAGIC *mg = Null(MAGIC*);
+ MAGIC *mg = NULL;
/* prevent recompiling under /o and ithreads. */
#if defined(USE_ITHREADS)
{
if (PM_GETRE(pm)) {
ReREFCNT_dec(PM_GETRE(pm));
- PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
+ PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
}
if (PL_op->op_flags & OPf_SPECIAL)
PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
if (SvTYPE(sv) < SVt_PVMG)
SvUPGRADE(sv, SVt_PVMG);
if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
- sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
- mg = mg_find(sv, PERL_MAGIC_regex_global);
+#ifdef PERL_OLD_COPY_ON_WRITE
+ if (SvIsCOW(lsv))
+ sv_force_normal_flags(sv, 0);
+#endif
+ mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
+ NULL, 0);
}
i = m - orig;
if (DO_UTF8(sv))
{
UV *p = (UV*)*rsp;
U32 i;
+ PERL_UNUSED_CONTEXT;
if (!p || p[1] < rx->nparens) {
#ifdef PERL_OLD_COPY_ON_WRITE
{
UV *p = (UV*)*rsp;
U32 i;
+ PERL_UNUSED_CONTEXT;
RX_MATCH_COPY_FREE(rx);
RX_MATCH_COPIED_set(rx, *p);
Perl_rxres_free(pTHX_ void **rsp)
{
UV * const p = (UV*)*rsp;
+ PERL_UNUSED_CONTEXT;
if (p) {
#ifdef PERL_POISON
void *tmp = INT2PTR(char*,*p);
Safefree(tmp);
if (*p)
- Poison(*p, 1, sizeof(*p));
+ PoisonFree(*p, 1, sizeof(*p));
#else
Safefree(INT2PTR(char*,*p));
#endif
}
#endif
Safefree(p);
- *rsp = Null(void*);
+ *rsp = NULL;
}
}
RETURN;
}
- EXTEND(SP, 10);
+ EXTEND(SP, 11);
if (!stashname)
PUSHs(&PL_sv_undef);
mask = newSVsv(old_warnings);
PUSHs(sv_2mortal(mask));
}
+
+ PUSHs(cx->blk_oldcop->cop_hints ?
+ sv_2mortal(newRV_noinc(
+ (SV*)Perl_refcounted_he_chain_2hv(aTHX_
+ cx->blk_oldcop->cop_hints)))
+ : &PL_sv_undef);
RETURN;
}
hasargs = 0;
SPAGAIN;
- if (CvXSUB(cv)) {
+ if (CvISXSUB(cv)) {
CvDEPTH(cv)++;
PUSHMARK(SP);
(void)(*CvXSUB(cv))(aTHX_ cv);
TAINT_NOT;
if (gimme == G_VOID)
- ; /* do nothing */
+ /*EMPTY*/; /* do nothing */
else if (gimme == G_SCALAR) {
if (mark < SP)
*++newsp = sv_mortalcopy(*SP);
}
/* First do some returnish stuff. */
- (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
+ SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
FREETMPS;
cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
}
}
- else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
+ else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
AV* const av = GvAV(PL_defgv);
items = AvFILLp(av) + 1;
EXTEND(SP, items+1); /* @_ could have been extended. */
/* Now do some callish stuff. */
SAVETMPS;
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
- if (CvXSUB(cv)) {
- OP* retop = cx->blk_sub.retop;
+ if (CvISXSUB(cv)) {
+ OP* const retop = cx->blk_sub.retop;
+ SV **newsp;
+ I32 gimme;
if (reified) {
I32 index;
for (index=0; index<items; index++)
sv_2mortal(SP[-index]);
}
-#ifdef PERL_XSUB_OLDSTYLE
- if (CvOLDSTYLE(cv)) {
- I32 (*fp3)(int,int,int);
- while (SP > mark) {
- SP[1] = SP[0];
- SP--;
- }
- fp3 = (I32(*)(int,int,int))CvXSUB(cv);
- items = (*fp3)(CvXSUBANY(cv).any_i32,
- mark - PL_stack_base + 1,
- items);
- SP = PL_stack_base + items;
- }
- else
-#endif /* PERL_XSUB_OLDSTYLE */
- {
- SV **newsp;
- I32 gimme;
- /* XS subs don't have a CxSUB, so pop it */
- POPBLOCK(cx, PL_curpm);
- /* Push a mark for the start of arglist */
- PUSHMARK(mark);
- PUTBACK;
- (void)(*CvXSUB(cv))(aTHX_ cv);
- /* Put these at the bottom since the vars are set but not used */
- PERL_UNUSED_VAR(newsp);
- PERL_UNUSED_VAR(gimme);
- }
+ /* XS subs don't have a CxSUB, so pop it */
+ POPBLOCK(cx, PL_curpm);
+ /* Push a mark for the start of arglist */
+ PUSHMARK(mark);
+ PUTBACK;
+ (void)(*CvXSUB(cv))(aTHX_ cv);
LEAVE;
return retop;
}
else {
- AV* padlist = CvPADLIST(cv);
+ AV* const padlist = CvPADLIST(cv);
if (CxTYPE(cx) == CXt_EVAL) {
PL_in_eval = cx->blk_eval.old_in_eval;
PL_eval_root = cx->blk_eval.old_eval_root;
cx->blk_sub.hasargs = 0;
}
cx->blk_sub.cv = cv;
- cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
+ cx->blk_sub.olddepth = CvDEPTH(cv);
CvDEPTH(cv)++;
if (CvDEPTH(cv) < 2)
- (void)SvREFCNT_inc(cv);
+ SvREFCNT_inc_void_NN(cv);
else {
if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
sub_crush_depth(cv);
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
if (cx->blk_sub.hasargs)
{
- AV* av = (AV*)PAD_SVl(0);
- SV** ary;
+ AV* const av = (AV*)PAD_SVl(0);
cx->blk_sub.savearray = GvAV(PL_defgv);
- GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
+ GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
CX_CURPAD_SAVE(cx->blk_sub);
cx->blk_sub.argarray = av;
if (items >= AvMAX(av) + 1) {
- ary = AvALLOC(av);
+ SV **ary = AvALLOC(av);
if (AvARRAY(av) != ary) {
AvMAX(av) += AvARRAY(av) - AvALLOC(av);
SvPV_set(av, (char*)ary);
* it's for informational purposes only.
*/
SV * const sv = GvSV(PL_DBsub);
- CV *gotocv;
-
save_item(sv);
if (PERLDB_SUB_NN) {
const int type = SvTYPE(sv);
} else {
gv_efullname3(sv, CvGV(cv), NULL);
}
- if ( PERLDB_GOTO
- && (gotocv = get_cv("DB::goto", FALSE)) ) {
- PUSHMARK( PL_stack_sp );
- call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
- PL_stack_sp--;
+ if (PERLDB_GOTO) {
+ CV * const gotocv = get_cv("DB::goto", FALSE);
+ if (gotocv) {
+ PUSHMARK( PL_stack_sp );
+ call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
+ PL_stack_sp--;
+ }
}
}
RETURNOP(CvSTART(cv));
/* find label */
- PL_lastgotoprobe = 0;
+ PL_lastgotoprobe = NULL;
*enterops = 0;
for (ix = cxstack_ix; ix >= 0; ix--) {
cx = &cxstack[ix];
#endif
}
PL_exit_flags |= PERL_EXIT_EXPECTED;
+#ifdef PERL_MAD
+ /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
+ if (anum || !(PL_minus_c && PL_madskills))
+ my_exit(anum);
+#else
my_exit(anum);
+#endif
PUSHs(&PL_sv_undef);
RETURN;
}
}
JMPENV_POP;
PL_op = oldop;
- return Nullop;
+ return NULL;
}
OP *
(*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
lex_end();
/* XXX DAPM do this properly one year */
- *padp = (AV*)SvREFCNT_inc(PL_comppad);
+ *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
LEAVE;
if (IN_PERL_COMPILETIME)
PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
CvOUTSIDE_SEQ(PL_compcv) = seq;
- CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
+ CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
/* set up a scratch pad */
CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
- SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
+ if (!PL_madskills)
+ SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
/* make sure we compile in the right package */
SAVEFREESV(PL_beginav);
SAVEI32(PL_error_count);
+#ifdef PERL_MAD
+ SAVEI32(PL_madskills);
+ PL_madskills = 0;
+#endif
+
/* try to compile it */
- PL_eval_root = Nullop;
+ PL_eval_root = NULL;
PL_error_count = 0;
PL_curcop = &PL_compiling;
- PL_curcop->cop_arybase = 0;
- if (saveop && saveop->op_type != OP_REQUIRE && saveop->op_flags & OPf_SPECIAL)
+ 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);
PL_op = saveop;
if (PL_eval_root) {
op_free(PL_eval_root);
- PL_eval_root = Nullop;
+ PL_eval_root = NULL;
}
SP = PL_stack_base + POPMARK; /* pop original mark */
if (!startop) {
{
Stat_t st;
const int st_rc = PerlLIO_stat(name, &st);
- if (st_rc < 0) {
- return Nullfp;
+ if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
+ return NULL;
}
- if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
- Perl_die(aTHX_ "%s %s not allowed in require",
- S_ISDIR(st.st_mode) ? "Directory" : "Block device", name);
- }
return PerlIO_open(name, mode);
}
fp = check_type_and_open(name, mode);
}
else {
- Stat_t pmstat;
- if (PerlLIO_stat(name, &pmstat) < 0 ||
- pmstat.st_mtime < pmcstat.st_mtime)
- {
- fp = check_type_and_open(pmc, mode);
- }
- else {
- fp = check_type_and_open(name, mode);
- }
+ fp = check_type_and_open(pmc, mode);
}
SvREFCNT_dec(pmcsv);
}
save the gv to manage the lifespan of
the pipe, but this didn't help. XXX */
filter_child_proc = (GV *)arg;
- (void)SvREFCNT_inc(filter_child_proc);
+ SvREFCNT_inc_simple_void(filter_child_proc);
}
else {
if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
PerlIO_close(IoOFP(io));
}
- IoIFP(io) = Nullfp;
- IoOFP(io) = Nullfp;
+ IoIFP(io) = NULL;
+ IoOFP(io) = NULL;
}
}
if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
filter_sub = arg;
- (void)SvREFCNT_inc(filter_sub);
+ SvREFCNT_inc_void_NN(filter_sub);
if (i < count) {
filter_state = SP[i];
- (void)SvREFCNT_inc(filter_state);
+ SvREFCNT_inc_simple_void(filter_state);
}
if (!tryrsfp) {
} else {
SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
if (!svp)
- (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
+ (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
}
ENTER;
PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
SAVEFREESV(PL_compiling.cop_io);
}
+ if (PL_compiling.cop_hints) {
+ PL_compiling.cop_hints->refcounted_he_refcnt--;
+ }
+ PL_compiling.cop_hints = PL_curcop->cop_hints;
+ if (PL_compiling.cop_hints) {
+#ifdef USE_ITHREADS
+ /* PL_curcop could be pointing to an optree owned by another /.*parent/
+ thread. We can't manipulate the reference count of the refcounted he
+ there (race condition) so we have to do something less than
+ pleasant to keep it read only. The simplest solution seems to be to
+ copy their chain. We might want to cache this.
+ Alternatively we could add a flag to the refcounted he *we* point to
+ here saying "I don't own a reference count on the thing I point to",
+ and arrange for Perl_refcounted_he_free() to spot that. If so, we'd
+ still need to copy the topmost refcounted he so that we could change
+ its flag. So still not trivial. (Flag bits could be hung from the
+ shared HEK) */
+ PL_compiling.cop_hints
+ = Perl_refcounted_he_copy(aTHX_ PL_compiling.cop_hints);
+#else
+ PL_compiling.cop_hints->refcounted_he_refcnt++;
+#endif
+ }
/* special case: an eval '' executed within the DB package gets lexically
* placed in the first non-DB CV rather than the current CV - this
* allows the debugger to execute code, find lexicals etc, in the
RETURNOP(retop);
}
-PP(pp_entertry)
+/* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
+ close to the related Perl_create_eval_scope. */
+void
+Perl_delete_eval_scope(pTHX)
{
- dVAR; dSP;
+ SV **newsp;
+ PMOP *newpm;
+ I32 gimme;
register PERL_CONTEXT *cx;
- const I32 gimme = GIMME_V;
+ I32 optype;
+
+ POPBLOCK(cx,newpm);
+ POPEVAL(cx);
+ PL_curpm = newpm;
+ LEAVE;
+ PERL_UNUSED_VAR(newsp);
+ PERL_UNUSED_VAR(gimme);
+ PERL_UNUSED_VAR(optype);
+}
+/* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
+ also needed by Perl_fold_constants. */
+PERL_CONTEXT *
+Perl_create_eval_scope(pTHX_ U32 flags)
+{
+ PERL_CONTEXT *cx;
+ const I32 gimme = GIMME_V;
+
ENTER;
SAVETMPS;
- PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
+ PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
PUSHEVAL(cx, 0, 0);
- cx->blk_eval.retop = cLOGOP->op_other->op_next;
+ PL_eval_root = PL_op; /* Only needed so that goto works right. */
PL_in_eval = EVAL_INEVAL;
- sv_setpvn(ERRSV,"",0);
- PUTBACK;
+ if (flags & G_KEEPERR)
+ PL_in_eval |= EVAL_KEEPERR;
+ else
+ sv_setpvn(ERRSV,"",0);
+ if (flags & G_FAKINGEVAL) {
+ PL_eval_root = PL_op; /* Only needed so that goto works right. */
+ }
+ return cx;
+}
+
+PP(pp_entertry)
+{
+ dVAR;
+ PERL_CONTEXT *cx = create_eval_scope(0);
+ cx->blk_eval.retop = cLOGOP->op_other->op_next;
return DOCATCH(PL_op->op_next);
}
I32 gimme;
SV **newsp;
PMOP *newpm;
- SV **mark;
+ PERL_UNUSED_CONTEXT;
POPBLOCK(cx,newpm);
assert(CxTYPE(cx) == CXt_GIVEN);
- mark = newsp;
SP = newsp;
PUTBACK;
/* perhaps someone can come up with a better name for
this? it is not really "absolute", per se ... */
static bool
-S_path_is_absolute(pTHX_ const char *name)
+S_path_is_absolute(const char *name)
{
if (PERL_FILE_IS_ABSOLUTE(name)
#ifdef MACOS_TRADITIONAL
https://perl5.git.perl.org / perl5.git / blobdiff