/* visit(): call the named function for each non-free SV in the arenas
* whose flags field matches the flags/mask args. */
-STATIC I32
+STATIC SSize_t
S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
{
SV* sva;
const SV * const svend = &sva[SvREFCNT(sva)];
SV* sv;
for (sv = sva + 1; sv < svend; ++sv) {
- if (SvTYPE(sv) != (svtype)SVTYPEMASK
+ if (!SvIS_FREED(sv)
&& (sv->sv_flags & mask) == flags
&& SvREFCNT(sv))
{
static void
do_report_used(pTHX_ SV *const sv)
{
- if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
+ if (!SvIS_FREED(sv)) {
PerlIO_printf(Perl_debug_log, "****\n");
sv_dump(sv);
}
=cut
*/
-I32
+SSize_t
Perl_sv_clean_all(pTHX)
{
- I32 cleaned;
+ SSize_t cleaned;
PL_in_clean_all = TRUE;
cleaned = visit(do_clean_all, 0,0);
return cleaned;
}
+
+#ifdef DEBUGGING
+
+/* Called by sv_mark_arenas() for each live SV: set SVf_BREAK */
+
+static void
+S_do_sv_mark_arenas(pTHX_ SV *const sv)
+{
+ sv->sv_flags |= SVf_BREAK;
+}
+
+/* sv_mark_arenas(): for leak debugging: mark all live SVs with SVf_BREAK.
+ * Then later, use sv_sweep_arenas() to list any SVs not so marked.
+ */
+
+void
+Perl_sv_mark_arenas(pTHX)
+{
+ visit(S_do_sv_mark_arenas, 0, 0);
+}
+
+/* Called by sv_sweep_arenas() for each live SV, to list any SVs without
+ * SVf_BREAK set */
+
+static void
+S_do_sv_sweep_arenas(pTHX_ SV *const sv)
+{
+ if (sv->sv_flags & SVf_BREAK) {
+ sv->sv_flags &= ~SVf_BREAK;
+ return;
+ }
+ PerlIO_printf(Perl_debug_log, "Unmarked SV: 0x%p: %s\n",
+ sv, SvPEEK(sv));
+}
+
+
+/* sv_sweep_arenas(): for debugging: list all live SVs that don't have
+ * SVf_BREAK set, then turn off all SVf_BREAK flags. Typically used some
+ * time after sv_mark_arenas(), to find SVs which have been created since
+ * the marking but not yet freed (they may have leaked, or been stored in
+ * an array, or whatever).
+ */
+
+void
+Perl_sv_sweep_arenas(pTHX)
+{
+ visit(S_do_sv_sweep_arenas, 0, 0);
+}
+
+#endif
+
+
/*
ARENASETS: a meta-arena implementation which separates arena-info
into struct arena_set, which contains an array of struct
SvANY(sv) = new_body;
switch(new_type) {
case SVt_PVAV:
- *((XPVAV*) SvANY(sv)) = (XPVAV) {
- .xmg_stash = NULL, .xmg_u = {.xmg_magic = NULL},
- .xav_fill = -1, .xav_max = -1, .xav_alloc = 0
+ {
+ XPVAV pvav = {
+ .xmg_stash = NULL,
+ .xmg_u = {.xmg_magic = NULL},
+ .xav_fill = -1, .xav_max = -1, .xav_alloc = 0
};
+ *((XPVAV*) SvANY(sv)) = pvav;
+ }
AvREAL_only(sv);
break;
case SVt_PVHV:
- *((XPVHV*) SvANY(sv)) = (XPVHV) {
- .xmg_stash = NULL, .xmg_u = {.xmg_magic = NULL},
- .xhv_keys = 0,
- /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
- .xhv_max = PERL_HASH_DEFAULT_HvMAX
+ {
+ XPVHV pvhv = {
+ .xmg_stash = NULL,
+ .xmg_u = {.xmg_magic = NULL},
+ .xhv_keys = 0,
+ /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
+ .xhv_max = PERL_HASH_DEFAULT_HvMAX
};
+ *((XPVHV*) SvANY(sv)) = pvhv;
+ }
assert(!SvOK(sv));
SvOK_off(sv);
#endif
break;
case SVt_PVOBJ:
- *((XPVOBJ*) SvANY(sv)) = (XPVOBJ) {
- .xmg_stash = NULL, .xmg_u = {.xmg_magic = NULL},
- .xobject_maxfield = -1,
- .xobject_iter_sv_at = 0,
- .xobject_fields = NULL,
- };
+ {
+ XPVOBJ pvo = {
+ .xmg_stash = NULL, .xmg_u = {.xmg_magic = NULL},
+ .xobject_maxfield = -1,
+ .xobject_iter_sv_at = 0,
+ .xobject_fields = NULL,
+ };
+ *((XPVOBJ*) SvANY(sv)) = pvo;
+ }
break;
default:
NOT_REACHED;
/* 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;
+ SSize_t pos = mg->mg_len;
if (pos > 0) {
for (c = start + pos; c > start; c--) {
if (UTF8_IS_START(*c))
}
static int
-S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
+S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, const MGVTBL *vtbl, const U32 flags)
{
MAGIC* mg;
MAGIC** mgp;
*/
int
-Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
+Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, const MGVTBL *vtbl)
{
PERL_ARGS_ASSERT_SV_UNMAGICEXT;
return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
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
+ /* It's possible for 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
}
/*
-=for apidoc sv_insert
+=for apidoc sv_insert
+=for apidoc_item sv_insert_flags
-Inserts and/or replaces a string at the specified offset/length within the SV.
-Similar to the Perl C<substr()> function, with C<littlelen> bytes starting at
-C<little> replacing C<len> bytes of the string in C<bigstr> starting at
-C<offset>. Handles get magic.
+These insert and/or replace a string at the specified offset/length within the
+SV. Similar to the Perl C<substr()> function, with C<littlelen> bytes starting
+at C<little> replacing C<len> bytes of the string in C<bigstr> starting at
+C<offset>. They handle get magic.
-=for apidoc sv_insert_flags
-
-Same as C<sv_insert>, but the extra C<flags> are passed to the
-C<SvPV_force_flags> that applies to C<bigstr>.
+C<sv_insert_flags> is identical to plain C<sv_insert>, but the extra C<flags>
+are passed to the C<SvPV_force_flags> operation that is internally applied to
+C<bigstr>.
=cut
*/
HV *stash;
assert(SvREFCNT(sv) == 0);
- assert(SvTYPE(sv) != (svtype)SVTYPEMASK);
+ assert(!SvIS_FREED(sv));
#if NVSIZE <= IVSIZE
if (type <= SVt_NV) {
#else
PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
if (uoffset < 2 * backw) {
- /* The assumption is that going forwards is twice the speed of going
- forward (that's where the 2 * backw comes from).
- (The real figure of course depends on the UTF-8 data.) */
+ /* The assumption is that the average size of a character is 2 bytes,
+ * so going forwards is twice the speed of going backwards (that's
+ * where the 2 * backw comes from). (The real figure of course depends
+ * on the UTF-8 data.) */
const U8 *s = start;
- while (s < send && uoffset--)
- s += UTF8SKIP(s);
+ s = utf8_hop_forward(s, uoffset, send);
assert (s <= send);
if (s > send)
s = send;
return s - start;
}
- while (backw--) {
- send--;
- while (UTF8_IS_CONTINUATION(*send))
- send--;
- }
+ send = utf8_hop_back(send, -backw, start);
return send - start;
}
}
while (end > target) {
- end--;
- while (UTF8_IS_CONTINUATION(*end)) {
- end--;
- }
+ end = utf8_hop_back(end, -1, target);
endu--;
}
return endu;
}
/*
-=for apidoc sv_eq
-
-Returns a boolean indicating whether the strings in the two SVs are
-identical. Is UTF-8 and S<C<'use bytes'>> aware, handles get magic, and will
-coerce its args to strings if necessary.
-
-This function does not handle operator overloading. For a version that does,
-see instead C<sv_streq>.
+=for apidoc sv_eq
+=for apidoc_item sv_eq_flags
-=for apidoc sv_eq_flags
+These each return a boolean indicating whether or not the strings in the two
+SVs are equal. If S<C<'use bytes'>> is in effect, the comparison is
+byte-by-byte; otherwise character-by-character. Each will coerce its args to
+strings if necessary.
-Returns a boolean indicating whether the strings in the two SVs are
-identical. Is UTF-8 and S<C<'use bytes'>> aware and coerces its args to strings
-if necessary. If the flags has the C<SV_GMAGIC> bit set, it handles get-magic, too.
+They differ only in that C<sv_eq> always processes get magic, while
+C<sv_eq_flags> processes get magic only when the C<flags> parameter has the
+C<SV_GMAGIC> bit set.
-This function does not handle operator overloading. For a version that does,
-see instead C<sv_streq_flags>.
+These functions do not handle operator overloading. For versions that do,
+see instead C<L</sv_streq>> or C<L</sv_streq_flags>>.
=cut
*/
* at the beginning of a character. But neither or both are
* (or else earlier bytes would have been different). And
* if we are in the middle of a character, the two
- * characters are comprised of the same number of bytes
+ * characters have the same number of bytes
* (because in this case the start bytes are the same, and
* the start bytes encode the character's length). */
if (UTF8_IS_INVARIANT(*pv1))
if (!old)
return NULL;
- if (SvTYPE(old) == (svtype)SVTYPEMASK) {
+ if (SvIS_FREED(old)) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
return NULL;
}
sv = GvSV(gv);
if (sv && !SvREADONLY(sv)) {
SV_CHECK_THINKFIRST_COW_DROP(sv);
- if (!isGV(sv)) SvOK_off(sv);
+ if (!isGV(sv)) {
+ SvOK_off(sv);
+ SvSETMAGIC(sv);
+ }
}
if (GvAV(gv)) {
av_clear(GvAV(gv));
PERL_ARGS_ASSERT_SV_DUP_COMMON;
- if (SvTYPE(ssv) == (svtype)SVTYPEMASK) {
+ if (SvIS_FREED(ssv)) {
#ifdef DEBUG_LEAKING_SCALARS_ABORT
abort();
#endif
nsi->si_prev = si_dup(si->si_prev, param);
nsi->si_next = si_dup(si->si_next, param);
nsi->si_markoff = si->si_markoff;
+#ifdef PERL_RC_STACK
+ nsi->si_stack_nonrc_base = si->si_stack_nonrc_base;
+#endif
#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
nsi->si_stack_hwm = 0;
#endif
PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
+ PL_hook__require__before = sv_dup_inc(proto_perl->Ihook__require__before, param);
+ PL_hook__require__after = sv_dup_inc(proto_perl->Ihook__require__after, param);
+
/* switches */
PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
PL_inplace = SAVEPV(proto_perl->Iinplace);
PL_numeric_underlying = true;
PL_numeric_underlying_is_standard = true;
-# if defined(USE_POSIX_2008_LOCALE)
- PL_underlying_numeric_obj = NULL;
-# endif
#endif /* !USE_LOCALE_NUMERIC */
#if defined(USE_POSIX_2008_LOCALE)
PL_scratch_locale_obj = NULL;
PL_setlocale_buf = NULL;
PL_setlocale_bufsize = 0;
- PL_stdize_locale_buf = NULL;
- PL_stdize_locale_bufsize = 0;
+#if defined(USE_LOCALE_THREADS) && ! defined(USE_THREAD_SAFE_LOCALE)
+ PL_less_dicey_locale_buf = NULL;
+ PL_less_dicey_locale_bufsize = 0;
+#endif
/* Unicode inversion lists */
/* next PUSHMARK() sets *(PL_markstack_ptr+1) */
i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
- Newx(PL_markstack, i, I32);
+ Newx(PL_markstack, i, Stack_off_t);
PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
- proto_perl->Imarkstack);
PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
- proto_perl->Imarkstack);
Copy(proto_perl->Imarkstack, PL_markstack,
- PL_markstack_ptr - PL_markstack + 1, I32);
+ PL_markstack_ptr - PL_markstack + 1, Stack_off_t);
/* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
* NOTE: unlike the others! */
HV* const stash = MUTABLE_HV(av_shift(param->stashes));
GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
if (cloner && GvCV(cloner)) {
- dSP;
ENTER;
SAVETMPS;
- PUSHMARK(SP);
- mXPUSHs(newSVhek(HvNAME_HEK(stash)));
- PUTBACK;
+ PUSHMARK(PL_stack_sp);
+ rpp_extend(1);
+ SV *newsv = newSVhek(HvNAME_HEK(stash));
+ *++PL_stack_sp = newsv;
+ if (!rpp_stack_is_rc())
+ sv_2mortal(newsv);
call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
FREETMPS;
LEAVE;
switch (obase->op_type) {
case OP_UNDEF:
- /* undef should care if its args are undef - any warnings
+ /* the optimizer rewrites '$x = undef' to 'undef $x' for lexical
+ * variables, which can occur as the source of warnings:
+ * ($x = undef) =~ s/a/b/;
+ * The OPpUNDEF_KEEP_PV flag indicates that this used to be an
+ * assignment op.
+ * Otherwise undef should not care if its args are undef - any warnings
* will be from tied/magic vars */
+ if (
+ (obase->op_private & (OPpTARGET_MY | OPpUNDEF_KEEP_PV)) == (OPpTARGET_MY | OPpUNDEF_KEEP_PV)
+ && (!match || PAD_SVl(obase->op_targ) == uninit_sv)
+ ) {
+ return varname(NULL, '$', obase->op_targ, NULL, 0, FUV_SUBSCRIPT_NONE);
+ }
break;
case OP_RV2AV:
return varname(NULL, '$', obase->op_targ,
NULL, 0, FUV_SUBSCRIPT_NONE);
+ case OP_PADSV_STORE:
+ if (match && PAD_SVl(obase->op_targ) != uninit_sv)
+ goto do_op;
+ return varname(NULL, '$', obase->op_targ,
+ NULL, 0, FUV_SUBSCRIPT_NONE);
+
case OP_GVSV:
gv = cGVOPx_gv(obase);
if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))
}
return varname(NULL, '$', obase->op_targ,
NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+
+ case OP_AELEMFASTLEX_STORE:
+ if (match) {
+ SV **svp;
+ AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
+ if (!av || SvRMAGICAL(av))
+ goto do_op;
+ svp = av_fetch(av, (I8)obase->op_private, FALSE);
+ if (!svp || *svp != uninit_sv)
+ goto do_op;
+ }
+ return varname(NULL, '$', obase->op_targ,
+ NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+
case OP_AELEMFAST:
{
gv = cGVOPx_gv(obase);
https://perl5.git.perl.org / perl5.git / blobdiff