{
PERL_ARGS_ASSERT_SV_SETUV;
- /* With these two if statements:
+ /* With the if statement to ensure that integers are stored as IVs whenever
+ possible:
u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
without
u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
- If you wish to remove them, please benchmark to see what the effect is
+ If you wish to remove the following if statement, so that this routine
+ (and its callers) always return UVs, please benchmark to see what the
+ effect is. Modern CPUs may be different. Or may not :-)
*/
if (u <= (UV)IV_MAX) {
sv_setiv(sv, (IV)u);
STATIC bool
S_glob_2number(pTHX_ GV * const gv)
{
- SV *const buffer = sv_newmortal();
-
PERL_ARGS_ASSERT_GLOB_2NUMBER;
- gv_efullname3(buffer, gv, "*");
-
/* We know that all GVs stringify to something that is not-a-number,
so no need to test that. */
if (ckWARN(WARN_NUMERIC))
+ {
+ SV *const buffer = sv_newmortal();
+ gv_efullname3(buffer, gv, "*");
not_a_number(buffer);
+ }
/* We just want something true to return, so that S_sv_2iuv_common
can tail call us and return true. */
return TRUE;
}
/*
+=for apidoc sv_gmagical_2iv_please
+
+Used internally by C<SvIV_please_nomg>, this function sets the C<SvIVX>
+slot if C<sv_2iv> would have made the scalar C<SvIOK> had it not been
+magical. In that case it returns true.
+
+=cut
+*/
+
+bool
+Perl_sv_gmagical_2iv_please(pTHX_ register SV *sv)
+{
+ bool has_int;
+ PERL_ARGS_ASSERT_SV_GMAGICAL_2IV_PLEASE;
+ assert(SvGMAGICAL(sv) && !SvIOKp(sv) && (SvNOKp(sv) || SvPOKp(sv)));
+ if (S_sv_2iuv_common(aTHX_ sv)) { SvNIOK_off(sv); return 0; }
+ has_int = !!SvIOK(sv);
+ SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
+ return has_int;
+}
+
+/*
=for apidoc sv_2uv_flags
Return the unsigned integer value of an SV, doing any necessary string
if (!referent) {
len = 7;
retval = buffer = savepvn("NULLREF", len);
- } else if (SvTYPE(referent) == SVt_REGEXP) {
+ } else if (SvTYPE(referent) == SVt_REGEXP && (
+ !(PL_curcop->cop_hints & HINT_NO_AMAGIC)
+ || amagic_is_enabled(string_amg)
+ )) {
REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
- I32 seen_evals = 0;
assert(re);
else
SvUTF8_off(sv);
- if ((seen_evals = RX_SEEN_EVALS(re)))
- PL_reginterp_cnt += seen_evals;
-
if (lp)
*lp = RX_WRAPLEN(re);
*/
char *
-Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
+Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *const lp)
{
PERL_ARGS_ASSERT_SV_2PVBYTE;
- SvGETMAGIC(sv);
+ if ((SvTHINKFIRST(sv) && !SvIsCOW(sv)) || isGV_with_GP(sv)) {
+ SV *sv2 = sv_newmortal();
+ sv_copypv(sv2,sv);
+ sv = sv2;
+ }
+ else SvGETMAGIC(sv);
sv_utf8_downgrade(sv,0);
return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
}
*/
char *
-Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
+Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *const lp)
{
PERL_ARGS_ASSERT_SV_2PVUTF8;
+ if ((SvTHINKFIRST(sv) && !SvIsCOW(sv)) || isGV_with_GP(sv))
+ sv = sv_mortalcopy(sv);
sv_utf8_upgrade(sv);
- return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
+ if (SvGMAGICAL(sv)) SvFLAGS(sv) &= ~SVf_POK;
+ assert(SvPOKp(sv));
+ return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
}
stype = SvTYPE(sstr);
dtype = SvTYPE(dstr);
- (void)SvAMAGIC_off(dstr);
if ( SvVOK(dstr) )
{
/* need to nuke the magic */
if (SvOOK(tsv))
svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
}
+ else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
+ /* It's possible for the the last (strong) reference to tsv to have
+ become freed *before* the last thing holding a weak reference.
+ If both survive longer than the backreferences array, then when
+ the referent's reference count drops to 0 and it is freed, it's
+ not able to chase the backreferences, so they aren't NULLed.
+
+ For example, a CV holds a weak reference to its stash. If both the
+ CV and the stash survive longer than the backreferences array,
+ and the CV gets picked for the SvBREAK() treatment first,
+ *and* it turns out that the stash is only being kept alive because
+ of an our variable in the pad of the CV, then midway during CV
+ destruction the stash gets freed, but CvSTASH() isn't set to NULL.
+ It ends up pointing to the freed HV. Hence it's chased in here, and
+ if this block wasn't here, it would hit the !svp panic just below.
+
+ I don't believe that "better" destruction ordering is going to help
+ here - during global destruction there's always going to be the
+ chance that something goes out of order. We've tried to make it
+ foolproof before, and it only resulted in evolutionary pressure on
+ fools. Which made us look foolish for our hubris. :-(
+ */
+ return;
+ }
else {
MAGIC *const mg
= SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
return;
Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
- *svp, PL_phase_names[PL_phase], SvREFCNT(tsv));
+ *svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
}
if (SvTYPE(*svp) == SVt_PVAV) {
sv_unmagic(sv, PERL_MAGIC_backref);
mg_free(sv);
}
+ SvMAGICAL_off(sv);
if (type == SVt_PVMG && SvPAD_TYPED(sv))
SvREFCNT_dec(SvSTASH(sv));
}
SvSTASH(sv) = (HV*)iter_sv;
iter_sv = sv;
- /* XXX ideally we should save the old value of hash_index
- * too, but I can't think of any place to hide it. The
- * effect of not saving it is that for freeing hashes of
- * hashes, we become quadratic in scanning the HvARRAY of
- * the top hash looking for new entries to free; but
- * hopefully this will be dwarfed by the freeing of all
- * the nested hashes. */
+ /* save old hash_index in unused SvMAGIC field */
+ assert(!SvMAGICAL(sv));
+ assert(!SvMAGIC(sv));
+ ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index;
hash_index = 0;
+
next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index);
goto get_next_sv; /* process this new sv */
}
/* no more elements of current HV to free */
sv = iter_sv;
type = SvTYPE(sv);
- /* Restore previous value of iter_sv, squirrelled away */
+ /* Restore previous values of iter_sv and hash_index,
+ * squirrelled away */
assert(!SvOBJECT(sv));
iter_sv = (SV*)SvSTASH(sv);
-
- /* ideally we should restore the old hash_index here,
- * but we don't currently save the old value */
- hash_index = 0;
+ assert(!SvMAGICAL(sv));
+ hash_index = ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index;
/* free any remaining detritus from the hash struct */
Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
Swings and roundabouts. */
SvUPGRADE(sv, SVt_PV);
- SvSCREAM_off(sv);
-
if (append) {
if (PerlIO_isutf8(fp)) {
if (!SvUTF8(sv)) {
/*
=for apidoc newSVpvn
-Creates a new SV and copies a string into it. The reference count for the
-SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
-string. You are responsible for ensuring that the source string is at least
-C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
+Creates a new SV and copies a buffer into it, which may contain NUL characters
+(C<\0>) and other binary data. The reference count for the SV is set to 1.
+Note that if C<len> is zero, Perl will create a zero length (Perl) string. You
+are responsible for ensuring that the source buffer is at least
+C<len> bytes long. If the C<buffer> argument is NULL the new SV will be
+undefined.
=cut
*/
SV *
-Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
+Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len)
{
dVAR;
register SV *sv;
new_SV(sv);
- sv_setpvn(sv,s,len);
+ sv_setpvn(sv,buffer,len);
return sv;
}
}
*st = GvESTASH(gv);
if (lref & ~GV_ADDMG && !GvCVu(gv)) {
- SV *tmpsv;
- ENTER;
- tmpsv = newSV(0);
- gv_efullname3(tmpsv, gv, NULL);
/* XXX this is probably not what they think they're getting.
* It has the same effect as "sub name;", i.e. just a forward
* declaration! */
- newSUB(start_subparse(FALSE, 0),
- newSVOP(OP_CONST, 0, tmpsv),
- NULL, NULL);
- LEAVE;
- if (!GvCVu(gv))
- Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
- SVfARG(SvOK(sv) ? sv : &PL_sv_no));
+ newSTUB(gv,0);
}
return GvCVu(gv);
}
Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
OP_DESC(PL_op));
s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC);
+ if (!s) {
+ s = (char *)"";
+ }
if (lp)
*lp = len;
new_SV(sv);
SV_CHECK_THINKFIRST_COW_DROP(rv);
- (void)SvAMAGIC_off(rv);
if (SvTYPE(rv) >= SVt_PVMG) {
const U32 refcnt = SvREFCNT(rv);
SvUPGRADE(tmpRef, SVt_PVMG);
SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
- if (Gv_AMG(stash))
- SvAMAGIC_on(sv);
- else
- (void)SvAMAGIC_off(sv);
-
if(SvSMAGICAL(tmpRef))
if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
mg_set(tmpRef);
Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
}
else {
+ ncx->blk_oldcop = (COP*)any_dup(ncx->blk_oldcop, param->proto_perl);
switch (CxTYPE(ncx)) {
case CXt_SUB:
ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
param);
ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
+ ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param);
break;
case CXt_LOOP_LAZYSV:
ncx->blk_loop.state_u.lazysv.end
break;
case CXt_BLOCK:
case CXt_NULL:
+ case CXt_WHEN:
+ case CXt_GIVEN:
break;
}
}
= pv_dup(old_state->re_state_reginput);
new_state->re_state_regeol
= pv_dup(old_state->re_state_regeol);
- new_state->re_state_regoffs
- = (regexp_paren_pair*)
- any_dup(old_state->re_state_regoffs, proto_perl);
- new_state->re_state_reglastparen
- = (U32*) any_dup(old_state->re_state_reglastparen,
- proto_perl);
- new_state->re_state_reglastcloseparen
- = (U32*)any_dup(old_state->re_state_reglastcloseparen,
- proto_perl);
- /* XXX This just has to be broken. The old save_re_context
- code did SAVEGENERICPV(PL_reg_start_tmp);
- PL_reg_start_tmp is char **.
- Look above to what the dup code does for
- SAVEt_GENERIC_PVREF
- It can never have worked.
- So this is merely a faithful copy of the exiting bug: */
- new_state->re_state_reg_start_tmp
- = (char **) pv_dup((char *)
- old_state->re_state_reg_start_tmp);
- /* I assume that it only ever "worked" because no-one called
- (pseudo)fork while the regexp engine had re-entered itself.
- */
#ifdef PERL_OLD_COPY_ON_WRITE
new_state->re_state_nrs
= sv_dup(old_state->re_state_nrs, param);
/* RE engine related */
Zero(&PL_reg_state, 1, struct re_save_state);
- PL_reginterp_cnt = 0;
PL_regmatch_slab = NULL;
PL_sub_generation = proto_perl->Isub_generation;
PL_in_clean_objs = proto_perl->Iin_clean_objs;
PL_in_clean_all = proto_perl->Iin_clean_all;
- PL_uid = proto_perl->Iuid;
- PL_euid = proto_perl->Ieuid;
- PL_gid = proto_perl->Igid;
- PL_egid = proto_perl->Iegid;
+ PL_delaymagic_uid = proto_perl->Idelaymagic_uid;
+ PL_delaymagic_euid = proto_perl->Idelaymagic_euid;
+ PL_delaymagic_gid = proto_perl->Idelaymagic_gid;
+ PL_delaymagic_egid = proto_perl->Idelaymagic_egid;
PL_nomemok = proto_perl->Inomemok;
PL_an = proto_perl->Ian;
PL_evalseq = proto_perl->Ievalseq;
PL_hints = proto_perl->Ihints;
- PL_amagic_generation = proto_perl->Iamagic_generation;
-
#ifdef USE_LOCALE_COLLATE
PL_collation_ix = proto_perl->Icollation_ix;
PL_collation_standard = proto_perl->Icollation_standard;
PL_globhook = proto_perl->Iglobhook;
-#ifdef THREADS_HAVE_PIDS
- PL_ppid = proto_perl->Ippid;
-#endif
-
/* swatch cache */
PL_last_swash_hv = NULL; /* reinits on demand */
PL_last_swash_klen = 0;
hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
- /* These two PVs will be free'd special way so must set them same way op.c does */
- PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
- ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
-
+ /* This PV will be free'd special way so must set it same way op.c does */
PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
PL_regex_pad = AvARRAY(PL_regex_padav);
+ PL_stashpadmax = proto_perl->Istashpadmax;
+ PL_stashpadix = proto_perl->Istashpadix ;
+ Newx(PL_stashpad, PL_stashpadmax, HV *);
+ {
+ PADOFFSET o = 0;
+ for (; o < PL_stashpadmax; ++o)
+ PL_stashpad[o] = hv_dup(proto_perl->Istashpad[o], param);
+ }
+
/* shortcuts to various I/O objects */
PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param);
PL_stdingv = gv_dup(proto_perl->Istdingv, param);
PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
#endif /* !USE_LOCALE_NUMERIC */
- /* utf8 character classes */
+ /* Unicode inversion lists */
+ PL_ASCII = sv_dup_inc(proto_perl->IASCII, param);
+ PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
+
+ PL_PerlSpace = sv_dup_inc(proto_perl->IPerlSpace, param);
+ PL_XPerlSpace = sv_dup_inc(proto_perl->IXPerlSpace, param);
+
+ PL_L1PosixAlnum = sv_dup_inc(proto_perl->IL1PosixAlnum, param);
+ PL_PosixAlnum = sv_dup_inc(proto_perl->IPosixAlnum, param);
+
+ PL_L1PosixAlpha = sv_dup_inc(proto_perl->IL1PosixAlpha, param);
+ PL_PosixAlpha = sv_dup_inc(proto_perl->IPosixAlpha, param);
+
+ PL_PosixBlank = sv_dup_inc(proto_perl->IPosixBlank, param);
+ PL_XPosixBlank = sv_dup_inc(proto_perl->IXPosixBlank, param);
+
+ PL_L1Cased = sv_dup_inc(proto_perl->IL1Cased, param);
+
+ PL_PosixCntrl = sv_dup_inc(proto_perl->IPosixCntrl, param);
+ PL_XPosixCntrl = sv_dup_inc(proto_perl->IXPosixCntrl, param);
+
+ PL_PosixDigit = sv_dup_inc(proto_perl->IPosixDigit, param);
+
+ PL_L1PosixGraph = sv_dup_inc(proto_perl->IL1PosixGraph, param);
+ PL_PosixGraph = sv_dup_inc(proto_perl->IPosixGraph, param);
+
+ PL_L1PosixLower = sv_dup_inc(proto_perl->IL1PosixLower, param);
+ PL_PosixLower = sv_dup_inc(proto_perl->IPosixLower, param);
+
+ PL_L1PosixPrint = sv_dup_inc(proto_perl->IL1PosixPrint, param);
+ PL_PosixPrint = sv_dup_inc(proto_perl->IPosixPrint, param);
+
+ PL_L1PosixPunct = sv_dup_inc(proto_perl->IL1PosixPunct, param);
+ PL_PosixPunct = sv_dup_inc(proto_perl->IPosixPunct, param);
+
+ PL_PosixSpace = sv_dup_inc(proto_perl->IPosixSpace, param);
+ PL_XPosixSpace = sv_dup_inc(proto_perl->IXPosixSpace, param);
+
+ PL_L1PosixUpper = sv_dup_inc(proto_perl->IL1PosixUpper, param);
+ PL_PosixUpper = sv_dup_inc(proto_perl->IPosixUpper, param);
+
+ PL_L1PosixWord = sv_dup_inc(proto_perl->IL1PosixWord, param);
+ PL_PosixWord = sv_dup_inc(proto_perl->IPosixWord, param);
+
+ PL_PosixXDigit = sv_dup_inc(proto_perl->IPosixXDigit, param);
+ PL_XPosixXDigit = sv_dup_inc(proto_perl->IXPosixXDigit, param);
+
+ PL_VertSpace = sv_dup_inc(proto_perl->IVertSpace, param);
+
+ /* utf8 character class swashes */
PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
PL_utf8_foldable = sv_dup_inc(proto_perl->Iutf8_foldable, param);
+ PL_utf8_quotemeta = sv_dup_inc(proto_perl->Iutf8_quotemeta, param);
+ PL_ASCII = sv_dup_inc(proto_perl->IASCII, param);
+ PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
+ PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
if (proto_perl->Ipsig_pend) {
}
}
else {
- CV * const cv = gv ? (CV *)gv : find_runcv(NULL);
+ CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL);
SV *sv;
AV *av;
SV * const sv = newSV(0);
*SvPVX(name) = '$';
Perl_sv_catpvf(aTHX_ name, "{%s}",
- pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
+ pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL,
+ PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT ));
SvREFCNT_dec(sv);
}
else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff