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))
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
RETURN;
}
- EXTEND(SP, 10);
+ EXTEND(SP, 11);
if (!stashname)
PUSHs(&PL_sv_undef);
/* XXX only hints propagated via op_private are currently
* visible (others are not easily accessible, since they
* use the global PL_hints) */
- PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
- HINT_PRIVATE_MASK)));
+ PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
{
SV * mask ;
SV * const old_warnings = cx->blk_oldcop->cop_warnings ;
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;
}
/* find label */
- PL_lastgotoprobe = 0;
+ PL_lastgotoprobe = NULL;
*enterops = 0;
for (ix = cxstack_ix; ix >= 0; ix--) {
cx = &cxstack[ix];
*padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
LEAVE;
if (IN_PERL_COMPILETIME)
- PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ CopHINTS_set(&PL_compiling, PL_hints);
#ifdef OP_IN_REGISTER
op = PL_opsave;
#endif
PL_eval_root = NULL;
PL_error_count = 0;
PL_curcop = &PL_compiling;
- PL_curcop->cop_arybase = 0;
+ CopARYBASE_set(PL_curcop, 0);
if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
PL_in_eval |= EVAL_KEEPERR;
else
{
Stat_t st;
const int st_rc = PerlLIO_stat(name, &st);
- if (st_rc < 0) {
+ 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);
}
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);
}
PUSHs(other);
PUSHs(*svp);
PUTBACK;
- if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
+ if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
(void) pp_i_eq();
else
(void) pp_eq();
/* Otherwise, numeric comparison */
PUSHs(d); PUSHs(e);
PUTBACK;
- if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
+ if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
(void) pp_i_eq();
else
(void) pp_eq();
projects / p5sagit/p5-mst-13.2.git / blobdiff