sv_setsv(tmpstr, sv);
continue;
}
- sv_catsv(tmpstr, msv);
+ sv_catsv_nomg(tmpstr, msv);
}
SvSETMAGIC(tmpstr);
SP = ORIGMARK;
PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
#endif
} else if (PL_curcop->cop_hints_hash) {
- SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
- "regcomp", 7, 0, 0);
+ SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
if (ptr && SvIOK(ptr) && SvIV(ptr))
eng = INT2PTR(regexp_engine*,SvIV(ptr));
}
tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
}
+ /* If it is gmagical, create a mortal copy, but without calling
+ get-magic, as we have already done that. */
+ if(SvGMAGICAL(tmpstr)) {
+ SV *mortalcopy = sv_newmortal();
+ sv_setsv_flags(mortalcopy, tmpstr, 0);
+ tmpstr = mortalcopy;
+ }
+
if (eng)
PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
else
(void)ReREFCNT_inc(rx);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
rxres_save(&cx->sb_rxres, rx);
+ PL_curpm = pm;
RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
}
/* copy the new items down to the destination list */
dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
if (gimme == G_ARRAY) {
- while (items-- > 0)
- *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
+ /* add returned items to the collection (making mortal copies
+ * if necessary), then clear the current temps stack frame
+ * *except* for those items. We do this splicing the items
+ * into the start of the tmps frame (so some items may be on
+ * the tmps stack twice), then moving PL_tmps_floor above
+ * them, then freeing the frame. That way, the only tmps that
+ * accumulate over iterations are the return values for map.
+ * We have to do to this way so that everything gets correctly
+ * freed if we die during the map.
+ */
+ I32 tmpsbase;
+ I32 i = items;
+ /* make space for the slice */
+ EXTEND_MORTAL(items);
+ tmpsbase = PL_tmps_floor + 1;
+ Move(PL_tmps_stack + tmpsbase,
+ PL_tmps_stack + tmpsbase + items,
+ PL_tmps_ix - PL_tmps_floor,
+ SV*);
+ PL_tmps_ix += items;
+
+ while (i-- > 0) {
+ SV *sv = POPs;
+ if (!SvTEMP(sv))
+ sv = sv_mortalcopy(sv);
+ *dst-- = sv;
+ PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
+ }
+ /* clear the stack frame except for the items */
+ PL_tmps_floor += items;
+ FREETMPS;
+ /* FREETMPS may have cleared the TEMP flag on some of the items */
+ i = items;
+ while (i-- > 0)
+ SvTEMP_on(PL_tmps_stack[--tmpsbase]);
}
else {
/* scalar context: we don't care about which values map returns
(void)POPs;
*dst-- = &PL_sv_undef;
}
+ FREETMPS;
}
}
+ else {
+ FREETMPS;
+ }
LEAVE_with_name("grep_item"); /* exit inner scope */
/* All done yet? */
PERL_ARGS_ASSERT_QERROR;
- if (PL_in_eval)
- sv_catsv(ERRSV, err);
+ if (PL_in_eval) {
+ if (PL_in_eval & EVAL_KEEPERR) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
+ SvPV_nolen_const(err));
+ }
+ else
+ sv_catsv(ERRSV, err);
+ }
else if (PL_errors)
sv_catsv(PL_errors, err);
else
SV *namesv;
register PERL_CONTEXT *cx;
SV **newsp;
+ COP *oldcop;
+ JMPENV *restartjmpenv;
+ OP *restartop;
if (cxix < cxstack_ix)
dounwind(cxix);
}
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
+ oldcop = cx->blk_oldcop;
+ restartjmpenv = cx->blk_eval.cur_top_env;
+ restartop = cx->blk_eval.retop;
if (gimme == G_SCALAR)
*++newsp = &PL_sv_undef;
* XXX it might be better to find a way to avoid messing with
* PL_curcop in save_re_context() instead, but this is a more
* minimal fix --GSAR */
- PL_curcop = cx->blk_oldcop;
+ PL_curcop = oldcop;
if (optype == OP_REQUIRE) {
const char* const msg = SvPVx_nolen_const(exceptsv);
else {
sv_setsv(ERRSV, exceptsv);
}
- assert(CxTYPE(cx) == CXt_EVAL);
- PL_restartjmpenv = cx->blk_eval.cur_top_env;
- PL_restartop = cx->blk_eval.retop;
+ PL_restartjmpenv = restartjmpenv;
+ PL_restartop = restartop;
JMPENV_JUMP(3);
/* NOTREACHED */
}
}
PUSHs(cx->blk_oldcop->cop_hints_hash ?
- sv_2mortal(newRV_noinc(
- MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
- cx->blk_oldcop->cop_hints_hash))))
+ sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
: &PL_sv_undef);
RETURN;
}
dVAR; dSP; dMARK;
register PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
- SV **svp;
+ void *itervar; /* location of the iteration variable */
U8 cxtype = CXt_LOOP_FOR;
-#ifdef USE_ITHREADS
- PAD *iterdata;
-#endif
ENTER_with_name("loop1");
SAVETMPS;
- if (PL_op->op_targ) {
- if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
+ if (PL_op->op_targ) { /* "my" variable */
+ if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
SVs_PADSTALE, SVs_PADSTALE);
}
SAVEPADSVANDMORTALIZE(PL_op->op_targ);
-#ifndef USE_ITHREADS
- svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
+#ifdef USE_ITHREADS
+ itervar = PL_comppad;
#else
- iterdata = NULL;
+ itervar = &PAD_SVl(PL_op->op_targ);
#endif
}
- else {
+ else { /* symbol table variable */
GV * const gv = MUTABLE_GV(POPs);
- svp = &GvSV(gv); /* symbol table variable */
- SAVEGENERICSV(*svp);
+ SV** svp = &GvSV(gv);
+ save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
*svp = newSV(0);
-#ifdef USE_ITHREADS
- iterdata = (PAD*)gv;
-#endif
+ itervar = (void *)gv;
}
if (PL_op->op_private & OPpITER_DEF)
ENTER_with_name("loop2");
PUSHBLOCK(cx, cxtype, SP);
-#ifdef USE_ITHREADS
- PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
-#else
- PUSHLOOP_FOR(cx, svp, MARK, 0);
-#endif
+ PUSHLOOP_FOR(cx, itervar, MARK);
if (PL_op->op_flags & OPf_STACKED) {
SV *maybe_ary = POPs;
if (SvTYPE(maybe_ary) != SVt_PVAV) {
retop = cx->blk_eval.retop;
if (CxTRYBLOCK(cx))
break;
- lex_end();
if (optype == OP_REQUIRE &&
(MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
{
enterops, enterops + GOTO_DEPTH);
if (retop)
break;
+ if (gotoprobe->op_sibling &&
+ gotoprobe->op_sibling->op_type == OP_UNSTACK &&
+ gotoprobe->op_sibling->op_sibling) {
+ retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
+ label, enterops, enterops + GOTO_DEPTH);
+ if (retop)
+ break;
+ }
}
PL_lastgotoprobe = gotoprobe;
}
PERL_ARGS_ASSERT_SV_COMPILE_2OP;
ENTER_with_name("eval");
- lex_start(sv, NULL, FALSE);
+ lex_start(sv, NULL, 0);
SAVETMPS;
/* switch to eval mode */
(*startop)->op_type = OP_NULL;
(*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
- lex_end();
/* XXX DAPM do this properly one year */
*padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
LEAVE_with_name("eval");
else
CLEAR_ERRSV();
- CALL_BLOCK_HOOKS(eval, saveop);
+ CALL_BLOCK_HOOKS(bhk_eval, saveop);
/* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
* so honour CATCH_GET and trap it here if necessary */
namesv = cx->blk_eval.old_namesv;
}
}
- lex_end();
if (yystatus != 3)
LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
}
}
- if (PL_unitcheckav)
+ if (PL_unitcheckav) {
+ OP *es = PL_eval_start;
call_list(PL_scopestack_ix, PL_unitcheckav);
+ PL_eval_start = es;
+ }
/* compiled okay, so do it */
}
STATIC PerlIO *
-S_check_type_and_open(pTHX_ const char *name)
+S_check_type_and_open(pTHX_ SV *name)
{
Stat_t st;
- const int st_rc = PerlLIO_stat(name, &st);
+ const char *p = SvPV_nolen_const(name);
+ const int st_rc = PerlLIO_stat(p, &st);
PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
return NULL;
}
- return PerlIO_open(name, PERL_SCRIPT_MODE);
+#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
+ return PerlIO_openn(aTHX_ NULL, PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
+#else
+ return PerlIO_open(p, PERL_SCRIPT_MODE);
+#endif
}
#ifndef PERL_DISABLE_PMC
STATIC PerlIO *
-S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
+S_doopen_pm(pTHX_ SV *name)
{
PerlIO *fp;
+ STRLEN namelen;
+ const char *p = SvPV_const(name, namelen);
PERL_ARGS_ASSERT_DOOPEN_PM;
- if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
- SV *const pmcsv = newSV(namelen + 2);
- char *const pmc = SvPVX(pmcsv);
+ if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
+ SV *const pmcsv = sv_mortalcopy(name);
Stat_t pmcstat;
- memcpy(pmc, name, namelen);
- pmc[namelen] = 'c';
- pmc[namelen + 1] = '\0';
+ sv_catpvn(pmcsv, "c", 1);
- if (PerlLIO_stat(pmc, &pmcstat) < 0) {
- fp = check_type_and_open(name);
- }
- else {
- fp = check_type_and_open(pmc);
- }
- SvREFCNT_dec(pmcsv);
- }
- else {
- fp = check_type_and_open(name);
+ if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
+ return check_type_and_open(pmcsv);
}
- return fp;
+ return check_type_and_open(name);
}
#else
-# define doopen_pm(name, namelen) check_type_and_open(name)
+# define doopen_pm(name) check_type_and_open(name)
#endif /* !PERL_DISABLE_PMC */
PP(pp_require)
sv = POPs;
if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
- sv = new_version(sv);
+ sv = sv_2mortal(new_version(sv));
if (!sv_derived_from(PL_patchlevel, "version"))
upg_version(PL_patchlevel, TRUE);
if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
/* prepare to compile file */
if (path_is_absolute(name)) {
+ /* At this point, name is SvPVX(sv) */
tryname = name;
- tryrsfp = doopen_pm(name, len);
+ tryrsfp = doopen_pm(sv);
}
if (!tryrsfp) {
AV * const ar = GvAVn(PL_incgv);
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. */
+ SvPOK_on(namesv);
}
# endif
#endif
TAINT_PROPER("require");
tryname = SvPVX_const(namesv);
- tryrsfp = doopen_pm(tryname, SvCUR(namesv));
+ tryrsfp = doopen_pm(namesv);
if (tryrsfp) {
if (tryname[0] == '.' && tryname[1] == '/') {
++tryname;
ENTER_with_name("eval");
SAVETMPS;
- lex_start(NULL, tryrsfp, TRUE);
+ lex_start(NULL, tryrsfp, 0);
SAVEHINTS();
PL_hints = 0;
{
dVAR;
dSP;
- mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
+ mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
RETURN;
}
TAINT_PROPER("eval");
ENTER_with_name("eval");
- lex_start(sv, NULL, FALSE);
+ lex_start(sv, NULL, 0);
SAVETMPS;
/* switch to eval mode */
}
SAVECOMPILEWARNINGS();
PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
- if (PL_compiling.cop_hints_hash) {
- Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
- }
+ cophh_free(CopHINTHASH_get(&PL_compiling));
if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) {
/* The label, if present, is the first entry on the chain. So rather
than writing a blank label in front of it (which involves an
allocation), just use the next entry in the chain. */
PL_compiling.cop_hints_hash
- = PL_curcop->cop_hints_hash->refcounted_he_next;
+ = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next);
/* Check the assumption that this removed the label. */
assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
}
else
- PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
- if (PL_compiling.cop_hints_hash) {
- HINTS_REFCNT_LOCK;
- PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
- HINTS_REFCNT_UNLOCK;
- }
+ PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash);
/* 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
assert(CvDEPTH(PL_compcv) == 1);
#endif
CvDEPTH(PL_compcv) = 0;
- lex_end();
if (optype == OP_REQUIRE &&
!(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
https://perl5.git.perl.org / perl5.git / blobdiff