}
/* Void wrapper to pass to visit() */
-/* XXX
static void
do_curse(pTHX_ SV * const sv) {
if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
return;
(void)curse(sv, 0);
}
-*/
/*
=for apidoc sv_clean_objs
visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
/* And if there are some very tenacious barnacles clinging to arrays,
closures, or what have you.... */
- /* XXX This line breaks Tk and Gtk2. See [perl #82542].
visit(do_curse, SVs_OBJECT, SVs_OBJECT);
- */
olddef = PL_defoutgv;
PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
if (olddef && isGV_with_GP(olddef))
}
}
}
+
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ /* Update pos. We do it at the end rather than during
+ * the upgrade, to avoid slowing down the common case
+ * (upgrade without pos) */
+ MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
+ if (mg) {
+ I32 pos = mg->mg_len;
+ if (pos > 0 && (U32)pos > invariant_head) {
+ U8 *d = (U8*) SvPVX(sv) + invariant_head;
+ STRLEN n = (U32)pos - invariant_head;
+ while (n > 0) {
+ if (UTF8_IS_START(*d))
+ d++;
+ d++;
+ n--;
+ }
+ mg->mg_len = d - (U8*)SvPVX(sv);
+ }
+ }
+ if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
+ magic_setutf8(sv,mg); /* clear UTF8 cache */
+ }
}
}
if (SvCUR(sv)) {
U8 *s;
STRLEN len;
+ int mg_flags = SV_GMAGIC;
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
- s = (U8 *) SvPV(sv, len);
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ /* update pos */
+ MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
+ if (mg) {
+ I32 pos = mg->mg_len;
+ if (pos > 0) {
+ sv_pos_b2u(sv, &pos);
+ mg_flags = 0; /* sv_pos_b2u does get magic */
+ mg->mg_len = pos;
+ }
+ }
+ if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
+ magic_setutf8(sv,mg); /* clear UTF8 cache */
+
+ }
+ s = (U8 *) SvPV_flags(sv, len, mg_flags);
+
if (!utf8_to_bytes(s, &len)) {
if (fail_ok)
return FALSE;
PERL_ARGS_ASSERT_SV_UTF8_DECODE;
if (SvPOKp(sv)) {
- const U8 *c;
+ const U8 *start, *c;
const U8 *e;
/* The octets may have got themselves encoded - get them back as
/* it is actually just a matter of turning the utf8 flag on, but
* we want to make sure everything inside is valid utf8 first.
*/
- c = (const U8 *) SvPVX_const(sv);
+ c = start = (const U8 *) SvPVX_const(sv);
if (!is_utf8_string(c, SvCUR(sv)+1))
return FALSE;
e = (const U8 *) SvEND(sv);
break;
}
}
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ /* adjust pos to the start of a UTF8 char sequence */
+ MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
+ if (mg) {
+ I32 pos = mg->mg_len;
+ if (pos > 0) {
+ for (c = start + pos; c > start; c--) {
+ if (UTF8_IS_START(*c))
+ break;
+ }
+ mg->mg_len = c - start;
+ }
+ }
+ if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
+ magic_setutf8(sv,mg); /* clear UTF8 cache */
+ }
}
return TRUE;
}
mro_changes = 2;
else {
const STRLEN len = GvNAMELEN(dstr);
- if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
+ if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
+ || (len == 1 && name[0] == ':')) {
mro_changes = 3;
/* Set aside the old stash, so we can reset isa caches on
const char * const name = GvNAME((GV*)dstr);
const STRLEN len = GvNAMELEN(dstr);
if (
- len > 1 && name[len-2] == ':' && name[len-1] == ':'
+ (
+ (len > 1 && name[len-2] == ':' && name[len-1] == ':')
+ || (len == 1 && name[0] == ':')
+ )
&& (!dref || HvENAME_get(dref))
) {
mro_package_moved(
const STRLEN len = GvNAMELEN(dstr);
HV *old_stash = NULL;
bool reset_isa = FALSE;
- if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
+ if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
+ || (len == 1 && name[0] == ':')) {
/* Set aside the old stash, so we can reset isa caches
on its subclasses. */
if((old_stash = GvHV(dstr))) {
}
}
-int
+static int
S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
{
MAGIC* mg;
* store it directly in the HvAUX or mg_obj slot, avoiding the need to
* allocate an AV. (Whether the slot holds an AV tells us whether this is
* active.)
- *
- * If an HV's backref is stored in magic, it is moved back to HvAUX.
*/
/* A discussion about the backreferences array and its refcount:
*
* The AV holding the backreferences is pointed to either as the mg_obj of
- * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
- * structure, from the xhv_backreferences field. (A HV without hv_aux will
- * have the standard magic instead.) The array is created with a refcount
+ * PERL_MAGIC_backref, or in the specific case of a HV, from the
+ * xhv_backreferences field. The array is created with a refcount
* of 2. This means that if during global destruction the array gets
* picked on before its parent to have its refcount decremented by the
* random zapper, it won't actually be freed, meaning it's still there for
if (SvTYPE(tsv) == SVt_PVHV) {
svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
-
- if (!*svp) {
- if ((mg = mg_find(tsv, PERL_MAGIC_backref))) {
- /* Aha. They've got it stowed in magic instead.
- * Move it back to xhv_backreferences */
- *svp = mg->mg_obj;
- /* Stop mg_free decreasing the reference count. */
- mg->mg_obj = NULL;
- /* Stop mg_free even calling the destructor, given that
- there's no AV to free up. */
- mg->mg_virtual = 0;
- sv_unmagic(tsv, PERL_MAGIC_backref);
- mg = NULL;
- }
- }
} else {
if (! ((mg =
(SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
PERL_ARGS_ASSERT_SV_DEL_BACKREF;
- if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
- svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
+ if (SvTYPE(tsv) == SVt_PVHV) {
+ if (SvOOK(tsv))
+ svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
}
- if (!svp || !*svp) {
+ else {
MAGIC *const mg
= SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
svp = mg ? &(mg->mg_obj) : NULL;
if (!av)
return;
+ /* after multiple passes through Perl_sv_clean_all() for a thinngy
+ * that has badly leaked, the backref array may have gotten freed,
+ * since we only protect it against 1 round of cleanup */
+ if (SvIS_FREED(av)) {
+ if (PL_in_clean_all) /* All is fair */
+ return;
+ Perl_croak(aTHX_
+ "panic: magic_killbackrefs (freed backref AV/SV)");
+ }
+
+
is_array = (SvTYPE(av) == SVt_PVAV);
if (is_array) {
assert(!SvIS_FREED(av));
}
/* if not, anonymise: */
- stash = GvSTASH(gv) ? HvNAME(GvSTASH(gv)) : NULL;
+ stash = GvSTASH(gv) && HvNAME(GvSTASH(gv))
+ ? HvENAME(GvSTASH(gv)) : NULL;
gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
stash ? stash : "__ANON__");
anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
if (!curse(sv, 1)) goto get_next_sv;
}
if (type >= SVt_PVMG) {
- if (type == SVt_PVMG && SvPAD_OUR(sv)) {
+ /* Free back-references before magic, in case the magic calls
+ * Perl code that has weak references to sv. */
+ if (type == SVt_PVHV) {
+ Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
+ if (SvMAGIC(sv))
+ mg_free(sv);
+ }
+ else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
SvREFCNT_dec(SvOURSTASH(sv));
- } else if (SvMAGIC(sv))
+ } else if (SvMAGIC(sv)) {
+ /* Free back-references before other types of magic. */
+ sv_unmagic(sv, PERL_MAGIC_backref);
mg_free(sv);
+ }
if (type == SVt_PVMG && SvPAD_TYPED(sv))
SvREFCNT_dec(SvSTASH(sv));
}
if (PL_last_swash_hv == (const HV *)sv) {
PL_last_swash_hv = NULL;
}
- Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
+ assert(!HvARRAY((HV*)sv));
break;
case SVt_PVAV:
{
break;
#endif
case 'l':
+ ++q;
#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
- if (*++q == 'l') { /* lld, llf */
+ if (*q == 'l') { /* lld, llf */
intsize = 'q';
++q;
}
PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
+ PL_utf8_xidstart = sv_dup_inc(proto_perl->Iutf8_xidstart, 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 = hv_dup_inc(proto_perl->Iutf8_foldable, param);
/* Did the locale setup indicate UTF-8? */
}
FREETMPS;
LEAVE;
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ /* clear pos and any utf8 cache */
+ MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
+ if (mg)
+ mg->mg_len = -1;
+ if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
+ magic_setutf8(sv,mg); /* clear UTF8 cache */
+ }
SvUTF8_on(sv);
return SvPVX(sv);
}
https://perl5.git.perl.org / perl5.git / blobdiff