#ifdef PERL_OLD_COPY_ON_WRITE
#define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
#define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
-/* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
- on-write. */
#endif
/* ============================================================================
dump all remaining SVs (debugging aid)
sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
- do_clean_named_io_objs()
+ do_clean_named_io_objs(),do_curse()
Attempt to free all objects pointed to by RVs,
- and try to do the same for all objects indirectly
- referenced by typeglobs too. Called once from
+ try to do the same for all objects indir-
+ ectly referenced by typeglobs too, and
+ then do a final sweep, cursing any
+ objects that remain. Called once from
perl_destruct(), prior to calling sv_clean_all()
below.
} else {
SvROK_off(ref);
SvRV_set(ref, NULL);
- SvREFCNT_dec(target);
+ SvREFCNT_dec_NN(target);
}
}
}
-
- /* XXX Might want to check arrays, etc. */
}
DEBUG_D((PerlIO_printf(Perl_debug_log,
"Cleaning named glob SV object:\n "), sv_dump(obj)));
GvSV(sv) = NULL;
- SvREFCNT_dec(obj);
+ SvREFCNT_dec_NN(obj);
}
if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
DEBUG_D((PerlIO_printf(Perl_debug_log,
"Cleaning named glob AV object:\n "), sv_dump(obj)));
GvAV(sv) = NULL;
- SvREFCNT_dec(obj);
+ SvREFCNT_dec_NN(obj);
}
if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
DEBUG_D((PerlIO_printf(Perl_debug_log,
"Cleaning named glob HV object:\n "), sv_dump(obj)));
GvHV(sv) = NULL;
- SvREFCNT_dec(obj);
+ SvREFCNT_dec_NN(obj);
}
if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
DEBUG_D((PerlIO_printf(Perl_debug_log,
"Cleaning named glob CV object:\n "), sv_dump(obj)));
GvCV_set(sv, NULL);
- SvREFCNT_dec(obj);
+ SvREFCNT_dec_NN(obj);
}
- SvREFCNT_dec(sv); /* undo the inc above */
+ SvREFCNT_dec_NN(sv); /* undo the inc above */
}
/* clear any IO slots in a GV which hold objects (except stderr, defout);
DEBUG_D((PerlIO_printf(Perl_debug_log,
"Cleaning named glob IO object:\n "), sv_dump(obj)));
GvIOp(sv) = NULL;
- SvREFCNT_dec(obj);
+ SvREFCNT_dec_NN(obj);
}
- SvREFCNT_dec(sv); /* undo the inc above */
+ SvREFCNT_dec_NN(sv); /* undo the inc above */
}
/* Void wrapper to pass to visit() */
}
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
SvFLAGS(sv) |= SVf_BREAK;
- SvREFCNT_dec(sv);
+ SvREFCNT_dec_NN(sv);
}
/*
/* HEs use this offset for their arena. */
{ 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
- /* The bind placeholder pretends to be an RV for now.
- Also it's marked as "can't upgrade" to stop anyone using it before it's
- implemented. */
- { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
-
/* IVs are in the head, so the allocation size is 0. */
{ 0,
sizeof(IV), /* This is used to copy out the IV body. */
SVt_PV, FALSE, NONV, HASARENA,
FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
+ /* The invlist placeholder pretends to be an RV for now.
+ Also it's marked as "can't upgrade" to stop anyone using it before it's
+ implemented. */
+ { 0, 0, 0, SVt_INVLIST, TRUE, NONV, NOARENA, 0 },
+
{ sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
+ STRUCT_OFFSET(XPV, xpv_cur),
{ sizeof(regexp),
sizeof(regexp),
0,
- SVt_REGEXP, FALSE, NONV, HASARENA,
+ SVt_REGEXP, TRUE, NONV, HASARENA,
FIT_ARENA(0, sizeof(regexp))
},
*/
void
-Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
+Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
{
dVAR;
void* old_body;
assert(!SvPAD_TYPED(sv));
break;
default:
- if (old_type_details->cant_upgrade)
+ if (UNLIKELY(old_type_details->cant_upgrade))
Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
}
- if (old_type > new_type)
+ if (UNLIKELY(old_type > new_type))
Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
(int)old_type, (int)new_type);
#ifndef NODEFAULT_SHAREKEYS
HvSHAREKEYS_on(sv); /* key-sharing on by default */
#endif
- HvMAX(sv) = 7; /* (start with 8 buckets) */
+ /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
+ HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
}
/* SVt_NULL isn't the only thing upgraded to AV or HV.
SvNV_set(sv, 0);
#endif
- if (new_type == SVt_PVIO) {
+ if (UNLIKELY(new_type == SVt_PVIO)) {
IO * const io = MUTABLE_IO(sv);
GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
IoPAGE_LEN(sv) = 60;
}
- if (new_type == SVt_REGEXP)
+ if (UNLIKELY(new_type == SVt_REGEXP))
sv->sv_u.svu_rx = (regexp *)new_body;
else if (old_type < SVt_PV) {
/* referant will be NULL unless the old type was SVt_IV emulating
*/
int
-Perl_sv_backoff(pTHX_ register SV *const sv)
+Perl_sv_backoff(pTHX_ SV *const sv)
{
STRLEN delta;
const char * const s = SvPVX_const(sv);
*/
char *
-Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
+Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
{
char *s;
PERL_ARGS_ASSERT_SV_GROW;
- if (PL_madskills && newlen >= 0x100000) {
- PerlIO_printf(Perl_debug_log,
- "Allocation too large: %"UVxf"\n", (UV)newlen);
- }
#ifdef HAS_64K_LIMIT
if (newlen >= 0x10000) {
PerlIO_printf(Perl_debug_log,
#endif
}
else
+ {
+ if (SvIsCOW(sv)) sv_force_normal(sv);
s = SvPVX_mutable(sv);
+ }
+
+#ifdef PERL_NEW_COPY_ON_WRITE
+ /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
+ * to store the COW count. So in general, allocate one more byte than
+ * asked for, to make it likely this byte is always spare: and thus
+ * make more strings COW-able.
+ * If the new size is a big power of two, don't bother: we assume the
+ * caller wanted a nice 2^N sized block and will be annoyed at getting
+ * 2^N+1 */
+ if (newlen & 0xff)
+ newlen++;
+#endif
if (newlen > SvLEN(sv)) { /* need more room? */
STRLEN minlen = SvCUR(sv);
*/
void
-Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
+Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
{
dVAR;
*/
void
-Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
+Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
{
PERL_ARGS_ASSERT_SV_SETIV_MG;
*/
void
-Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
+Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
{
PERL_ARGS_ASSERT_SV_SETUV;
*/
void
-Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
+Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
{
PERL_ARGS_ASSERT_SV_SETUV_MG;
*/
void
-Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
+Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
{
dVAR;
*/
void
-Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
+Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
{
PERL_ARGS_ASSERT_SV_SETNV_MG;
/* For sv_2nv these three cases are "SvNOK and don't bother casting" */
STATIC int
-S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
+S_sv_2iuv_non_preserve(pTHX_ SV *const sv
# ifdef DEBUGGING
, I32 numtype
# endif
*/
IV
-Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
+Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
{
dVAR;
*/
UV
-Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
+Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
{
dVAR;
*/
NV
-Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
+Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
{
dVAR;
if (!sv)
*/
SV *
-Perl_sv_2num(pTHX_ register SV *const sv)
+Perl_sv_2num(pTHX_ SV *const sv)
{
PERL_ARGS_ASSERT_SV_2NUM;
*/
char *
-Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
+Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
{
dVAR;
char *s;
Move(ptr, s, len, char);
s += len;
*s = '\0';
+ SvPOK_on(sv);
}
else if (SvNOK(sv)) {
if (SvTYPE(sv) < SVt_PVNV)
/* The +20 is pure guesswork. Configure test needed. --jhi */
s = SvGROW_mutable(sv, NV_DIG + 20);
/* some Xenix systems wipe out errno here */
- Gconvert(SvNVX(sv), NV_DIG, 0, s);
+
+#ifndef USE_LOCALE_NUMERIC
+ Gconvert(SvNVX(sv), NV_DIG, 0, s);
+ SvPOK_on(sv);
+#else
+ /* Gconvert always uses the current locale. That's the right thing
+ * to do if we're supposed to be using locales. But otherwise, we
+ * want the result to be based on the C locale, so we need to
+ * change to the C locale during the Gconvert and then change back.
+ * But if we're already in the C locale (PL_numeric_standard is
+ * TRUE in that case), no need to do any changing */
+ if (PL_numeric_standard || IN_LOCALE_RUNTIME) {
+ Gconvert(SvNVX(sv), NV_DIG, 0, s);
+ }
+ else {
+ char *loc = savepv(setlocale(LC_NUMERIC, NULL));
+ setlocale(LC_NUMERIC, "C");
+ Gconvert(SvNVX(sv), NV_DIG, 0, s);
+ setlocale(LC_NUMERIC, loc);
+ Safefree(loc);
+ }
+
+ /* We don't call SvPOK_on(), because it may come to pass that the
+ * locale changes so that the stringification we just did is no
+ * longer correct. We will have to re-stringify every time it is
+ * needed */
+#endif
RESTORE_ERRNO;
while (*s) s++;
}
*lp = len;
SvCUR_set(sv, len);
}
- SvPOK_on(sv);
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
PTR2UV(sv),SvPVX_const(sv)));
if (flags & SV_CONST_RETURN)
*/
void
-Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
+Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
{
PERL_ARGS_ASSERT_SV_COPYPV;
}
void
-Perl_sv_copypv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
+Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
{
STRLEN len;
const char *s;
*/
char *
-Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *const lp)
+Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
{
PERL_ARGS_ASSERT_SV_2PVBYTE;
*/
char *
-Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *const lp)
+Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
{
PERL_ARGS_ASSERT_SV_2PVUTF8;
*/
bool
-Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags)
+Perl_sv_2bool_flags(pTHX_ SV *const sv, const I32 flags)
{
dVAR;
*/
STRLEN
-Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
+Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
{
dVAR;
*/
bool
-Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
+Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
{
dVAR;
*/
void
-Perl_sv_utf8_encode(pTHX_ register SV *const sv)
+Perl_sv_utf8_encode(pTHX_ SV *const sv)
{
PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
*/
bool
-Perl_sv_utf8_decode(pTHX_ register SV *const sv)
+Perl_sv_utf8_decode(pTHX_ SV *const sv)
{
PERL_ARGS_ASSERT_SV_UTF8_DECODE;
);
}
else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
+ if (GvIO(dstr) && dtype == SVt_PVGV) {
+ DEBUG_o(Perl_deb(aTHX_
+ "glob_assign_glob clearing PL_stashcache\n"));
+ /* It's a cache. It will rebuild itself quite happily.
+ It's a lot of effort to work out exactly which key (or keys)
+ might be invalidated by the creation of the this file handle.
+ */
+ hv_clear(PL_stashcache);
+ }
return;
}
static void
S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
{
- SV * const sref = SvREFCNT_inc(SvRV(sstr));
- SV *dref = NULL;
+ SV * const sref = SvRV(sstr);
+ SV *dref;
const int intro = GvINTRO(dstr);
SV **location;
U8 import_flag = 0;
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
}
}
- SAVEGENERICSV(*location);
- }
- else
- dref = *location;
+ /* SAVEt_GVSLOT takes more room on the savestack and has more
+ overhead in leave_scope than SAVEt_GENERIC_SV. But for CVs
+ leave_scope needs access to the GV so it can reset method
+ caches. We must use SAVEt_GVSLOT whenever the type is
+ SVt_PVCV, even if the stash is anonymous, as the stash may
+ gain a name somehow before leave_scope. */
+ if (stype == SVt_PVCV) {
+ /* There is no save_pushptrptrptr. Creating it for this
+ one call site would be overkill. So inline the ss add
+ routines here. */
+ dSS_ADD;
+ SS_ADD_PTR(dstr);
+ SS_ADD_PTR(location);
+ SS_ADD_PTR(SvREFCNT_inc(*location));
+ SS_ADD_UV(SAVEt_GVSLOT);
+ SS_ADD_END(4);
+ }
+ else SAVEGENERICSV(*location);
+ }
+ dref = *location;
if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
CV* const cv = MUTABLE_CV(*location);
if (cv) {
}
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
GvASSUMECV_on(dstr);
- if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
+ if(GvSTASH(dstr)) gv_method_changed(dstr); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
}
- *location = sref;
+ *location = SvREFCNT_inc_simple_NN(sref);
if (import_flag && !(GvFLAGS(dstr) & import_flag)
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
GvFLAGS(dstr) |= import_flag;
}
break;
}
- SvREFCNT_dec(dref);
+ if (!intro) SvREFCNT_dec(dref);
if (SvTAINTED(sstr))
SvTAINT(dstr);
return;
}
+/* Work around compiler warnings about unsigned >= THRESHOLD when thres-
+ hold is 0. */
+#if SV_COW_THRESHOLD
+# define GE_COW_THRESHOLD(len) ((len) >= SV_COW_THRESHOLD)
+#else
+# define GE_COW_THRESHOLD(len) 1
+#endif
+#if SV_COWBUF_THRESHOLD
+# define GE_COWBUF_THRESHOLD(len) ((len) >= SV_COWBUF_THRESHOLD)
+#else
+# define GE_COWBUF_THRESHOLD(len) 1
+#endif
+
void
-Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
+Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
{
dVAR;
U32 sflags;
}
break;
- /* case SVt_BIND: */
+ /* case SVt_INVLIST: */
case SVt_PVLV:
case SVt_PVGV:
case SVt_PVMG:
}
else if (sflags & SVp_POK) {
bool isSwipe = 0;
+ const STRLEN cur = SvCUR(sstr);
+ const STRLEN len = SvLEN(sstr);
/*
* Check to see if we can just swipe the string. If so, it's a
source scalar is a shared hash key scalar. */
(((flags & SV_COW_SHARED_HASH_KEYS)
? !(sflags & SVf_IsCOW)
+#ifdef PERL_NEW_COPY_ON_WRITE
+ || (len &&
+ ((!GE_COWBUF_THRESHOLD(cur) && SvLEN(dstr) > cur)
+ /* If this is a regular (non-hek) COW, only so many COW
+ "copies" are possible. */
+ || CowREFCNT(sstr) == SV_COW_REFCNT_MAX))
+#endif
: 1 /* If making a COW copy is forbidden then the behaviour we
desire is as if the source SV isn't actually already
COW, even if it is. So we act as if the source flags
are not COW, rather than actually testing them. */
)
-#ifndef PERL_OLD_COPY_ON_WRITE
+#ifndef PERL_ANY_COW
/* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
Conceptually PERL_OLD_COPY_ON_WRITE being defined should
)
&&
!(isSwipe =
+#ifdef PERL_NEW_COPY_ON_WRITE
+ /* slated for free anyway (and not COW)? */
+ (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP &&
+#else
(sflags & SVs_TEMP) && /* slated for free anyway? */
+#endif
!(sflags & SVf_OOK) && /* and not involved in OOK hack? */
(!(flags & SV_NOSTEAL)) &&
/* and we're allowed to steal temps */
SvREFCNT(sstr) == 1 && /* and no other references to it? */
- SvLEN(sstr)) /* and really is a string */
-#ifdef PERL_OLD_COPY_ON_WRITE
+ len) /* and really is a string */
+#ifdef PERL_ANY_COW
&& ((flags & SV_COW_SHARED_HASH_KEYS)
? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
+# ifdef PERL_OLD_COPY_ON_WRITE
&& (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
- && SvTYPE(sstr) >= SVt_PVIV))
+ && SvTYPE(sstr) >= SVt_PVIV
+# else
+ && !(SvFLAGS(dstr) & SVf_BREAK)
+ && !(sflags & SVf_IsCOW)
+ && GE_COW_THRESHOLD(cur) && cur+1 < len
+ && (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1)
+# endif
+ ))
: 1)
#endif
) {
/* Failed the swipe test, and it's not a shared hash key either.
Have to copy the string. */
- STRLEN len = SvCUR(sstr);
- SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
- Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
- SvCUR_set(dstr, len);
+ SvGROW(dstr, cur + 1); /* inlined from sv_setpvn */
+ Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
+ SvCUR_set(dstr, cur);
*SvEND(dstr) = '\0';
} else {
/* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
sv_dump(sstr);
sv_dump(dstr);
}
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
if (!isSwipe) {
if (!(sflags & SVf_IsCOW)) {
SvIsCOW_on(sstr);
+# ifdef PERL_OLD_COPY_ON_WRITE
/* Make the source SV into a loop of 1.
(about to become 2) */
SV_COW_NEXT_SV_SET(sstr, sstr);
+# else
+ CowREFCNT(sstr) = 0;
+# endif
}
}
#endif
if (!isSwipe) {
/* making another shared SV. */
- STRLEN cur = SvCUR(sstr);
- STRLEN len = SvLEN(sstr);
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
if (len) {
+# ifdef PERL_OLD_COPY_ON_WRITE
assert (SvTYPE(dstr) >= SVt_PVIV);
/* SvIsCOW_normal */
/* splice us in between source and next-after-source. */
SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
SV_COW_NEXT_SV_SET(sstr, dstr);
+# else
+ CowREFCNT(sstr)++;
+# endif
SvPV_set(dstr, SvPVX_mutable(sstr));
} else
#endif
*/
void
-Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
+Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
{
PERL_ARGS_ASSERT_SV_SETSV_MG;
SvSETMAGIC(dstr);
}
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
+# ifdef PERL_OLD_COPY_ON_WRITE
+# define SVt_COW SVt_PVIV
+# else
+# define SVt_COW SVt_PV
+# endif
SV *
Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
{
}
else
new_SV(dstr);
- SvUPGRADE(dstr, SVt_PVIV);
+ SvUPGRADE(dstr, SVt_COW);
assert (SvPOK(sstr));
assert (SvPOKp(sstr));
+# ifdef PERL_OLD_COPY_ON_WRITE
assert (!SvIOK(sstr));
assert (!SvIOKp(sstr));
assert (!SvNOK(sstr));
assert (!SvNOKp(sstr));
+# endif
if (SvIsCOW(sstr)) {
new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
goto common_exit;
}
+# ifdef PERL_OLD_COPY_ON_WRITE
SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
+# else
+ assert(SvCUR(sstr)+1 < SvLEN(sstr));
+ assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
+# endif
} else {
assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
- SvUPGRADE(sstr, SVt_PVIV);
+ SvUPGRADE(sstr, SVt_COW);
SvIsCOW_on(sstr);
DEBUG_C(PerlIO_printf(Perl_debug_log,
"Fast copy on write: Converting sstr to COW\n"));
+# ifdef PERL_OLD_COPY_ON_WRITE
SV_COW_NEXT_SV_SET(dstr, sstr);
+# else
+ CowREFCNT(sstr) = 0;
+# endif
}
+# ifdef PERL_OLD_COPY_ON_WRITE
SV_COW_NEXT_SV_SET(sstr, dstr);
+# else
+ CowREFCNT(sstr)++;
+# endif
new_pv = SvPVX_mutable(sstr);
common_exit:
SvPV_set(dstr, new_pv);
- SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_IsCOW);
+ SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
if (SvUTF8(sstr))
SvUTF8_on(dstr);
SvLEN_set(dstr, len);
*/
void
-Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
+Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
{
dVAR;
char *dptr;
*/
void
-Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
+Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
{
PERL_ARGS_ASSERT_SV_SETPVN_MG;
*/
void
-Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
+Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
{
dVAR;
STRLEN len;
*/
void
-Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
+Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
{
PERL_ARGS_ASSERT_SV_SETPV_MG;
}
void
-Perl_sv_sethek(pTHX_ register SV *const sv, const HEK *const hek)
+Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
{
dVAR;
sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
SvUTF8_on(sv);
return;
- } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
+ } else if (flags & HVhek_UNSHARED) {
sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
if (HEK_UTF8(hek))
SvUTF8_on(sv);
(which it can do by means other than releasing copy-on-write Svs)
or by changing the other copy-on-write SVs in the loop. */
STATIC void
-S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
+S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
{
PERL_ARGS_ASSERT_SV_RELEASE_COW;
*/
void
-Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
+Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
{
dVAR;
PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
if (SvREADONLY(sv)) {
- if (IN_PERL_RUNTIME)
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
- else
- if (SvIsCOW(sv)) {
- const char * const pvx = SvPVX_const(sv);
- const STRLEN len = SvLEN(sv);
- const STRLEN cur = SvCUR(sv);
- /* next COW sv in the loop. If len is 0 then this is a shared-hash
- key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
- we'll fail an assertion. */
- SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
+ else if (SvIsCOW(sv)) {
+ const char * const pvx = SvPVX_const(sv);
+ const STRLEN len = SvLEN(sv);
+ const STRLEN cur = SvCUR(sv);
+# ifdef PERL_OLD_COPY_ON_WRITE
+ /* next COW sv in the loop. If len is 0 then this is a shared-hash
+ key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
+ we'll fail an assertion. */
+ SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
+# endif
- if (DEBUG_C_TEST) {
+ if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log,
"Copy on write: Force normal %ld\n",
(long) flags);
sv_dump(sv);
- }
- SvIsCOW_off(sv);
+ }
+ SvIsCOW_off(sv);
+# ifdef PERL_NEW_COPY_ON_WRITE
+ if (len && CowREFCNT(sv) == 0)
+ /* We own the buffer ourselves. */
+ NOOP;
+ else
+# endif
+ {
+
/* This SV doesn't own the buffer, so need to Newx() a new one: */
+# ifdef PERL_NEW_COPY_ON_WRITE
+ /* Must do this first, since the macro uses SvPVX. */
+ if (len) CowREFCNT(sv)--;
+# endif
SvPV_set(sv, NULL);
SvLEN_set(sv, 0);
if (flags & SV_COW_DROP_PV) {
*SvEND(sv) = '\0';
}
if (len) {
+# ifdef PERL_OLD_COPY_ON_WRITE
sv_release_COW(sv, pvx, next);
+# endif
} else {
unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
}
sv_dump(sv);
}
}
+ }
#else
if (SvREADONLY(sv)) {
- if (IN_PERL_RUNTIME)
Perl_croak_no_modify();
}
else
SvANY(temp) = temp_p;
temp->sv_u.svu_rx = (regexp *)temp_p;
- SvREFCNT_dec(temp);
+ SvREFCNT_dec_NN(temp);
}
else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
}
*/
void
-Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
+Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
{
STRLEN delta;
STRLEN old_delta;
evacp = p - evacn;
#endif
+ /* This sets 'delta' to the accumulated value of all deltas so far */
delta += old_delta;
assert(delta);
+
+ /* If 'delta' fits in a byte, store it just prior to the new beginning of
+ * the string; otherwise store a 0 byte there and store 'delta' just prior
+ * to that, using as many bytes as a STRLEN occupies. Thus it overwrites a
+ * portion of the chopped part of the string */
if (delta < 0x100) {
*--p = (U8) delta;
} else {
*/
void
-Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
+Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
{
dVAR;
STRLEN dlen;
=cut */
void
-Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
+Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
{
dVAR;
=cut */
void
-Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
+Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
{
dVAR;
STRLEN len;
*/
void
-Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
+Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr)
{
PERL_ARGS_ASSERT_SV_CATPV_MG;
*/
void
-Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
+Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
const char *const name, const I32 namlen)
{
dVAR;
tsv = SvRV(sv);
Perl_sv_add_backref(aTHX_ tsv, sv);
SvWEAKREF_on(sv);
- SvREFCNT_dec(tsv);
+ SvREFCNT_dec_NN(tsv);
return sv;
}
}
if (is_array) {
AvFILLp(av) = -1;
- SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
+ SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */
}
return;
}
*/
void
-Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
+Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
{
dVAR;
const U32 refcnt = SvREFCNT(sv);
: newSVpvn_flags( "__ANON__", 8, 0 );
sv_catpvs(gvname, "::__ANON__");
anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
- SvREFCNT_dec(gvname);
+ SvREFCNT_dec_NN(gvname);
CvANON_on(cv);
CvCVGV_RC_on(cv);
SvREFCNT_dec(SvSTASH(sv));
}
switch (type) {
- /* case SVt_BIND: */
+ /* case SVt_INVLIST: */
case SVt_PVIO:
if (IoIFP(sv) &&
IoIFP(sv) != PerlIO_stdin() &&
PL_last_in_gv = NULL;
else if ((const GV *)sv == PL_statgv)
PL_statgv = NULL;
+ else if ((const GV *)sv == PL_stderrgv)
+ PL_stderrgv = NULL;
case SVt_PVMG:
case SVt_PVNV:
case SVt_PVIV:
next_sv = target;
}
}
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
else if (SvPVX_const(sv)
&& !(SvTYPE(sv) == SVt_PVIO
&& !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
sv_dump(sv);
}
if (SvLEN(sv)) {
+# ifdef PERL_OLD_COPY_ON_WRITE
sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
+# else
+ if (CowREFCNT(sv)) {
+ CowREFCNT(sv)--;
+ SvLEN_set(sv, 0);
+ }
+# endif
} else {
unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
}
- } else if (SvLEN(sv)) {
+ }
+# ifdef PERL_OLD_COPY_ON_WRITE
+ else
+# endif
+ if (SvLEN(sv)) {
Safefree(SvPVX_mutable(sv));
}
}
continue;
}
#endif
- if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
+ if (SvIMMORTAL(sv)) {
/* make sure SvREFCNT(sv)==0 happens very seldom */
- SvREFCNT(sv) = (~(U32)0)/2;
+ SvREFCNT(sv) = SvREFCNT_IMMORTAL;
continue;
}
break;
dSP;
HV* stash;
do {
- CV* destructor;
- stash = SvSTASH(sv);
- destructor = StashHANDLER(stash,DESTROY);
- if (destructor
+ stash = SvSTASH(sv);
+ assert(SvTYPE(stash) == SVt_PVHV);
+ if (HvNAME(stash)) {
+ CV* destructor = NULL;
+ if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash);
+ if (!destructor) {
+ GV * const gv =
+ gv_fetchmeth_autoload(stash, "DESTROY", 7, 0);
+ if (gv) destructor = GvCV(gv);
+ if (!SvOBJECT(stash))
+ SvSTASH(stash) =
+ destructor ? (HV *)destructor : ((HV *)0)+1;
+ }
+ assert(!destructor || destructor == ((CV *)0)+1
+ || SvTYPE(destructor) == SVt_PVCV);
+ if (destructor && destructor != ((CV *)0)+1
/* A constant subroutine can have no side effects, so
don't bother calling it. */
&& !CvCONST(destructor)
SvRV_set(tmpref, NULL);
SvROK_off(tmpref);
}
- SvREFCNT_dec(tmpref);
+ SvREFCNT_dec_NN(tmpref);
}
+ }
} while (SvOBJECT(sv) && SvSTASH(sv) != stash);
}
if (SvOBJECT(sv)) {
- SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
+ HV * const stash = SvSTASH(sv);
+ /* Curse before freeing the stash, as freeing the stash could cause
+ a recursive call into S_curse. */
SvOBJECT_off(sv); /* Curse the object. */
- if (SvTYPE(sv) != SVt_PVIO)
- --PL_sv_objcount;/* XXX Might want something more general */
+ SvSTASH_set(sv,0); /* SvREFCNT_dec may try to read this */
+ SvREFCNT_dec(stash); /* possibly of changed persuasion */
}
return TRUE;
}
void
Perl_sv_free(pTHX_ SV *const sv)
{
- dVAR;
- if (!sv)
- return;
- if (SvREFCNT(sv) == 0) {
- if (SvFLAGS(sv) & SVf_BREAK)
- /* this SV's refcnt has been artificially decremented to
- * trigger cleanup */
- return;
- if (PL_in_clean_all) /* All is fair */
- return;
- if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
- /* make sure SvREFCNT(sv)==0 happens very seldom */
- SvREFCNT(sv) = (~(U32)0)/2;
- return;
- }
- if (ckWARN_d(WARN_INTERNAL)) {
-#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
- Perl_dump_sv_child(aTHX_ sv);
-#else
- #ifdef DEBUG_LEAKING_SCALARS
- sv_dump(sv);
- #endif
-#ifdef DEBUG_LEAKING_SCALARS_ABORT
- if (PL_warnhook == PERL_WARNHOOK_FATAL
- || ckDEAD(packWARN(WARN_INTERNAL))) {
- /* Don't let Perl_warner cause us to escape our fate: */
- abort();
- }
-#endif
- /* This may not return: */
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
- "Attempt to free unreferenced scalar: SV 0x%"UVxf
- pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
-#endif
- }
-#ifdef DEBUG_LEAKING_SCALARS_ABORT
- abort();
-#endif
- return;
- }
- if (--(SvREFCNT(sv)) > 0)
- return;
- Perl_sv_free2(aTHX_ sv);
+ SvREFCNT_dec(sv);
}
+
+/* Private helper function for SvREFCNT_dec().
+ * Called with rc set to original SvREFCNT(sv), where rc == 0 or 1 */
+
void
-Perl_sv_free2(pTHX_ SV *const sv)
+Perl_sv_free2(pTHX_ SV *const sv, const U32 rc)
{
dVAR;
PERL_ARGS_ASSERT_SV_FREE2;
+ if (LIKELY( rc == 1 )) {
+ /* normal case */
+ SvREFCNT(sv) = 0;
+
#ifdef DEBUGGING
- if (SvTEMP(sv)) {
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
- "Attempt to free temp prematurely: SV 0x%"UVxf
- pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
- return;
+ if (SvTEMP(sv)) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
+ "Attempt to free temp prematurely: SV 0x%"UVxf
+ pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
+ return;
+ }
+#endif
+ if (SvIMMORTAL(sv)) {
+ /* make sure SvREFCNT(sv)==0 happens very seldom */
+ SvREFCNT(sv) = SvREFCNT_IMMORTAL;
+ return;
+ }
+ sv_clear(sv);
+ if (! SvREFCNT(sv)) /* may have have been resurrected */
+ del_SV(sv);
+ return;
+ }
+
+ /* handle exceptional cases */
+
+ assert(rc == 0);
+
+ if (SvFLAGS(sv) & SVf_BREAK)
+ /* this SV's refcnt has been artificially decremented to
+ * trigger cleanup */
+ return;
+ if (PL_in_clean_all) /* All is fair */
+ return;
+ if (SvIMMORTAL(sv)) {
+ /* make sure SvREFCNT(sv)==0 happens very seldom */
+ SvREFCNT(sv) = SvREFCNT_IMMORTAL;
+ return;
}
+ if (ckWARN_d(WARN_INTERNAL)) {
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+ Perl_dump_sv_child(aTHX_ sv);
+#else
+ #ifdef DEBUG_LEAKING_SCALARS
+ sv_dump(sv);
+ #endif
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+ if (PL_warnhook == PERL_WARNHOOK_FATAL
+ || ckDEAD(packWARN(WARN_INTERNAL))) {
+ /* Don't let Perl_warner cause us to escape our fate: */
+ abort();
+ }
+#endif
+ /* This may not return: */
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+ "Attempt to free unreferenced scalar: SV 0x%"UVxf
+ pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
#endif
- if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
- /* make sure SvREFCNT(sv)==0 happens very seldom */
- SvREFCNT(sv) = (~(U32)0)/2;
- return;
}
- sv_clear(sv);
- if (! SvREFCNT(sv))
- del_SV(sv);
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+ abort();
+#endif
+
}
+
/*
=for apidoc sv_len
*/
STRLEN
-Perl_sv_len(pTHX_ register SV *const sv)
+Perl_sv_len(pTHX_ SV *const sv)
{
STRLEN len;
*/
STRLEN
-Perl_sv_len_utf8(pTHX_ register SV *const sv)
+Perl_sv_len_utf8(pTHX_ SV *const sv)
{
if (!sv)
return 0;
/* This function is subject to size and sign problems */
void
-Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
+Perl_sv_pos_u2b(pTHX_ SV *const sv, I32 *const offsetp, I32 *const lenp)
{
PERL_ARGS_ASSERT_SV_POS_U2B;
*
*/
void
-Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
+Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp)
{
const U8* s;
const STRLEN byte = *offsetp;
*/
I32
-Perl_sv_eq_flags(pTHX_ register SV *sv1, register SV *sv2, const U32 flags)
+Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
{
dVAR;
const char *pv1;
}
/* Now both are in UTF-8. */
if (cur1 != cur2) {
- SvREFCNT_dec(svrecode);
+ SvREFCNT_dec_NN(svrecode);
return FALSE;
}
}
*/
I32
-Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
+Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2)
{
return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
}
I32
-Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2,
+Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2,
const U32 flags)
{
dVAR;
STRLEN cur1, cur2;
const char *pv1, *pv2;
- char *tpv = NULL;
I32 cmp;
SV *svrecode = NULL;
}
SvREFCNT_dec(svrecode);
- if (tpv)
- Safefree(tpv);
return cmp;
}
*/
I32
-Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
+Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2)
{
return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
}
I32
-Perl_sv_cmp_locale_flags(pTHX_ register SV *const sv1, register SV *const sv2,
+Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2,
const U32 flags)
{
dVAR;
static char *
S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
{
- I32 bytesread;
- const U32 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
+ SSize_t bytesread;
+ const STRLEN recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
/* Grab the size of the record we're getting */
- char *const buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
+ char *buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
+
+ /* Go yank in */
#ifdef VMS
+#include <rms.h>
int fd;
-#endif
+ Stat_t st;
- /* Go yank in */
-#ifdef VMS
- /* VMS wants read instead of fread, because fread doesn't respect */
- /* RMS record boundaries. This is not necessarily a good thing to be */
- /* doing, but we've got no other real choice - except avoid stdio
- as implementation - perhaps write a :vms layer ?
- */
+ /* With a true, record-oriented file on VMS, we need to use read directly
+ * to ensure that we respect RMS record boundaries. The user is responsible
+ * for providing a PL_rs value that corresponds to the FAB$W_MRS (maximum
+ * record size) field. N.B. This is likely to produce invalid results on
+ * varying-width character data when a record ends mid-character.
+ */
fd = PerlIO_fileno(fp);
- if (fd != -1) {
+ if (fd != -1
+ && PerlLIO_fstat(fd, &st) == 0
+ && (st.st_fab_rfm == FAB$C_VAR
+ || st.st_fab_rfm == FAB$C_VFC
+ || st.st_fab_rfm == FAB$C_FIX)) {
+
bytesread = PerlLIO_read(fd, buffer, recsize);
}
- else /* in-memory file from PerlIO::Scalar */
+ else /* in-memory file from PerlIO::Scalar
+ * or not a record-oriented file
+ */
#endif
{
bytesread = PerlIO_read(fp, buffer, recsize);
+
+ /* At this point, the logic in sv_get() means that sv will
+ be treated as utf-8 if the handle is utf8.
+ */
+ if (PerlIO_isutf8(fp) && bytesread > 0) {
+ char *bend = buffer + bytesread;
+ char *bufp = buffer;
+ size_t charcount = 0;
+ bool charstart = TRUE;
+ STRLEN skip = 0;
+
+ while (charcount < recsize) {
+ /* count accumulated characters */
+ while (bufp < bend) {
+ if (charstart) {
+ skip = UTF8SKIP(bufp);
+ }
+ if (bufp + skip > bend) {
+ /* partial at the end */
+ charstart = FALSE;
+ break;
+ }
+ else {
+ ++charcount;
+ bufp += skip;
+ charstart = TRUE;
+ }
+ }
+
+ if (charcount < recsize) {
+ STRLEN readsize;
+ STRLEN bufp_offset = bufp - buffer;
+ SSize_t morebytesread;
+
+ /* originally I read enough to fill any incomplete
+ character and the first byte of the next
+ character if needed, but if there's many
+ multi-byte encoded characters we're going to be
+ making a read call for every character beyond
+ the original read size.
+
+ So instead, read the rest of the character if
+ any, and enough bytes to match at least the
+ start bytes for each character we're going to
+ read.
+ */
+ if (charstart)
+ readsize = recsize - charcount;
+ else
+ readsize = skip - (bend - bufp) + recsize - charcount - 1;
+ buffer = SvGROW(sv, append + bytesread + readsize + 1) + append;
+ bend = buffer + bytesread;
+ morebytesread = PerlIO_read(fp, bend, readsize);
+ if (morebytesread <= 0) {
+ /* we're done, if we still have incomplete
+ characters the check code in sv_gets() will
+ warn about them.
+
+ I'd originally considered doing
+ PerlIO_ungetc() on all but the lead
+ character of the incomplete character, but
+ read() doesn't do that, so I don't.
+ */
+ break;
+ }
+
+ /* prepare to scan some more */
+ bytesread += morebytesread;
+ bend = buffer + bytesread;
+ bufp = buffer + bufp_offset;
+ }
+ }
+ }
}
if (bytesread < 0)
*/
char *
-Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
+Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
{
dVAR;
const char *rsptr;
*/
void
-Perl_sv_inc(pTHX_ register SV *const sv)
+Perl_sv_inc(pTHX_ SV *const sv)
{
if (!sv)
return;
*/
void
-Perl_sv_inc_nomg(pTHX_ register SV *const sv)
+Perl_sv_inc_nomg(pTHX_ SV *const sv)
{
dVAR;
char *d;
*/
void
-Perl_sv_dec(pTHX_ register SV *const sv)
+Perl_sv_dec(pTHX_ SV *const sv)
{
dVAR;
if (!sv)
*/
void
-Perl_sv_dec_nomg(pTHX_ register SV *const sv)
+Perl_sv_dec_nomg(pTHX_ SV *const sv)
{
dVAR;
int flags;
*/
SV *
-Perl_sv_2mortal(pTHX_ register SV *const sv)
+Perl_sv_2mortal(pTHX_ SV *const sv)
{
dVAR;
if (!sv)
return NULL;
- if (SvREADONLY(sv) && SvIMMORTAL(sv))
+ if (SvIMMORTAL(sv))
return sv;
PUSH_EXTEND_MORTAL__SV_C(sv);
SvTEMP_on(sv);
sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
SvUTF8_on (sv);
return sv;
- } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
- /* We don't have a pointer to the hv, so we have to replicate the
- flag into every HEK. This hv is using custom a hasing
- algorithm. Hence we can't return a shared string scalar, as
- that would contain the (wrong) hash value, and might get passed
- into an hv routine with a regular hash.
- Similarly, a hash that isn't using shared hash keys has to have
+ } else if (flags & HVhek_UNSHARED) {
+ /* A hash that isn't using shared hash keys has to have
the flag in every key so that we know not to try to call
share_hek_hek on it. */
Creates a new SV with its SvPVX_const pointing to a shared string in the string
table. If the string does not already exist in the table, it is
-created first. Turns on READONLY and FAKE. If the C<hash> parameter
+created first. Turns on the SvIsCOW flag (or READONLY
+and FAKE in 5.16 and earlier). If the C<hash> parameter
is non-zero, that value is used; otherwise the hash is computed.
The string's hash can later be retrieved from the SV
with the C<SvSHARED_HASH()> macro. The idea here is
*/
SV *
-Perl_newSVsv(pTHX_ register SV *const old)
+Perl_newSVsv(pTHX_ SV *const old)
{
dVAR;
SV *sv;
*/
void
-Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
+Perl_sv_reset(pTHX_ const char *s, HV *const stash)
{
PERL_ARGS_ASSERT_SV_RESET;
char todo[PERL_UCHAR_MAX+1];
const char *send;
- if (!stash)
+ if (!stash || SvTYPE(stash) != SVt_PVHV)
return;
if (!s) { /* reset ?? searches */
*/
I32
-Perl_sv_true(pTHX_ register SV *const sv)
+Perl_sv_true(pTHX_ SV *const sv)
{
if (!sv)
return 0;
PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
if (flags & SV_GMAGIC) SvGETMAGIC(sv);
- if (SvTHINKFIRST(sv) && !SvROK(sv))
+ if (SvTHINKFIRST(sv) && (!SvROK(sv) || SvREADONLY(sv)))
sv_force_normal_flags(sv, 0);
if (SvPOK(sv)) {
char *s;
STRLEN len;
- if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
- const char * const ref = sv_reftype(sv,0);
- if (PL_op)
- Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
- ref, OP_DESC(PL_op));
- else
- Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
- }
if (SvTYPE(sv) > SVt_PVLV
|| isGV_with_GP(sv))
/* diag_listed_as: Can't coerce %s to %s in %s */
? "GLOB" : "SCALAR");
case SVt_PVFM: return "FORMAT";
case SVt_PVIO: return "IO";
- case SVt_BIND: return "BIND";
+ case SVt_INVLIST: return "INVLIST";
case SVt_REGEXP: return "REGEXP";
default: return "UNKNOWN";
}
*/
SV *
-Perl_sv_ref(pTHX_ register SV *dst, const SV *const sv, const int ob)
+Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob)
{
PERL_ARGS_ASSERT_SV_REF;
/*
=for apidoc newSVrv
-Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
-it will be upgraded to one. If C<classname> is non-null then the new SV will
-be blessed in the specified package. The new SV is returned and its
-reference count is 1.
+Creates a new SV for the existing RV, C<rv>, to point to. If C<rv> is not an
+RV then it will be upgraded to one. If C<classname> is non-null then the new
+SV will be blessed in the specified package. The new SV is returned and its
+reference count is 1. The reference count 1 is owned by C<rv>.
=cut
*/
if (SvREADONLY(tmpRef) && !SvIsCOW(tmpRef))
Perl_croak_no_modify();
if (SvOBJECT(tmpRef)) {
- if (SvTYPE(tmpRef) != SVt_PVIO)
- --PL_sv_objcount;
SvREFCNT_dec(SvSTASH(tmpRef));
}
}
SvOBJECT_on(tmpRef);
- if (SvTYPE(tmpRef) != SVt_PVIO)
- ++PL_sv_objcount;
SvUPGRADE(tmpRef, SVt_PVMG);
SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
/* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
assigned to as BEGIN {$a = \"Foo"} will fail. */
if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
- SvREFCNT_dec(target);
+ SvREFCNT_dec_NN(target);
else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
sv_2mortal(target); /* Schedule for freeing later */
}
%-<num>p include an SV with precision <num>
%2p include a HEK
%3p include a HEK with precision of 256
- %<num>p (where num != 2 or 3) reserved for future
+ %4p char* preceded by utf8 flag and length
+ %<num>p (where num is 1 or > 4) reserved for future
extensions
Robin Barker 2005-07-14 (but modified since)
STRLEN n = 0;
if (*q == '-')
sv = *q++;
+ else if (strnEQ(q, UTF8f, sizeof(UTF8f)-1)) { /* UTF8f */
+ /* The argument has already gone through cBOOL, so the cast
+ is safe. */
+ is_utf8 = (bool)va_arg(*args, int);
+ elen = va_arg(*args, UV);
+ eptr = va_arg(*args, char *);
+ q += sizeof(UTF8f)-1;
+ goto string;
+ }
n = expect_number(&q);
if (*q++ == 'p') {
if (sv) { /* SVf */
have = esignlen + zeros + elen;
if (have < zeros)
- croak_memory_wrap();
+ Perl_croak_memory_wrap();
need = (have > width ? have : width);
gap = need - have;
if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
- croak_memory_wrap();
+ Perl_croak_memory_wrap();
SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
p = SvEND(sv);
if (esignlen && fill == '0') {
SvANY(dstr) = new_XNV();
SvNV_set(dstr, SvNVX(sstr));
break;
- /* case SVt_BIND: */
+ /* case SVt_INVLIST: */
default:
{
/* These are all the types that need complex bodies allocating. */
SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
} else if (SvMAGIC(dstr))
SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
- if (SvSTASH(dstr))
+ if (SvOBJECT(dstr) && SvSTASH(dstr))
SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
+ else SvSTASH_set(dstr, 0); /* don't copy DESTROY cache */
}
/* The cast silences a GCC warning about unhandled types. */
}
daux->xhv_name_count = saux->xhv_name_count;
+ daux->xhv_fill_lazy = saux->xhv_fill_lazy;
daux->xhv_riter = saux->xhv_riter;
daux->xhv_eiter = saux->xhv_eiter
? he_dup(saux->xhv_eiter,
}
}
- if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
- ++PL_sv_objcount;
-
return dstr;
}
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
break;
+ case SAVEt_GVSLOT: /* any slot in GV */
+ sv = (const SV *)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
+ sv = (const SV *)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
+ break;
case SAVEt_HV: /* hash reference */
case SAVEt_AV: /* array reference */
sv = (const SV *) POPPTR(ss,ix);
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup(sv, param);
break;
- case SAVEt_RE_STATE:
- {
- const struct re_save_state *const old_state
- = (struct re_save_state *)
- (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
- struct re_save_state *const new_state
- = (struct re_save_state *)
- (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
-
- Copy(old_state, new_state, 1, struct re_save_state);
- ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
-
- new_state->re_state_bostr
- = pv_dup(old_state->re_state_bostr);
- new_state->re_state_regeol
- = pv_dup(old_state->re_state_regeol);
-#ifdef PERL_OLD_COPY_ON_WRITE
- new_state->re_state_nrs
- = sv_dup(old_state->re_state_nrs, param);
-#endif
- new_state->re_state_reg_magic
- = (MAGIC*) any_dup(old_state->re_state_reg_magic,
- proto_perl);
- new_state->re_state_reg_oldcurpm
- = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
- proto_perl);
- new_state->re_state_reg_curpm
- = (PMOP*) any_dup(old_state->re_state_reg_curpm,
- proto_perl);
- new_state->re_state_reg_oldsaved
- = pv_dup(old_state->re_state_reg_oldsaved);
- new_state->re_state_reg_poscache
- = pv_dup(old_state->re_state_reg_poscache);
- new_state->re_state_reg_starttry
- = pv_dup(old_state->re_state_reg_starttry);
- break;
- }
case SAVEt_COMPILE_WARNINGS:
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
PL_Proc = ipP;
#endif /* PERL_IMPLICIT_SYS */
+
param->flags = flags;
/* Nothing in the core code uses this, but we make it available to
extensions (using mg_dup). */
param->new_perl = my_perl;
param->unreferenced = NULL;
+
INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
PL_body_arenas = NULL;
Zero(&PL_body_roots, 1, PL_body_roots);
PL_sv_count = 0;
- PL_sv_objcount = 0;
PL_sv_root = NULL;
PL_sv_arenaroot = NULL;
PL_debug = proto_perl->Idebug;
- PL_hash_seed = proto_perl->Ihash_seed;
- PL_rehash_seed = proto_perl->Irehash_seed;
-
/* dbargs array probably holds garbage */
PL_dbargs = NULL;
PL_minus_F = proto_perl->Iminus_F;
PL_doswitches = proto_perl->Idoswitches;
PL_dowarn = proto_perl->Idowarn;
+#ifdef PERL_SAWAMPERSAND
PL_sawampersand = proto_perl->Isawampersand;
+#endif
PL_unsafe = proto_perl->Iunsafe;
PL_perldb = proto_perl->Iperldb;
PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
#endif
/* RE engine related */
- Zero(&PL_reg_state, 1, struct re_save_state);
PL_regmatch_slab = NULL;
+ PL_reg_curpm = NULL;
PL_sub_generation = proto_perl->Isub_generation;
PL_last_swash_tmps = (U8*)NULL;
PL_last_swash_slen = 0;
- PL_glob_index = proto_perl->Iglob_index;
PL_srand_called = proto_perl->Isrand_called;
if (flags & CLONEf_COPY_STACKS) {
/* regex stuff */
- PL_regdummy = proto_perl->Iregdummy;
PL_colorset = 0; /* reinits PL_colors[] */
/*PL_colors[6] = {0,0,0,0,0,0};*/
hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
+ Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
+
/* 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_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);
-
PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);
PL_HasMultiCharFold= sv_dup_inc(proto_perl->IHasMultiCharFold, 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_blank = sv_dup_inc(proto_perl->Iutf8_blank, param);
- PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
- PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
- PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
- PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
- PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
- PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
- PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
- PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
+ for (i = 0; i < POSIX_SWASH_COUNT; i++) {
+ PL_utf8_swash_ptrs[i] = sv_dup_inc(proto_perl->Iutf8_swash_ptrs[i], param);
+ }
+ for (i = 0; i < POSIX_CC_COUNT; i++) {
+ PL_Posix_ptrs[i] = sv_dup_inc(proto_perl->IPosix_ptrs[i], param);
+ PL_L1Posix_ptrs[i] = sv_dup_inc(proto_perl->IL1Posix_ptrs[i], param);
+ PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param);
+ }
PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
PL_utf8_X_regular_begin = sv_dup_inc(proto_perl->Iutf8_X_regular_begin, param);
PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
- PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, 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_perl_idstart = sv_dup_inc(proto_perl->Iutf8_perl_idstart, param);
+ PL_utf8_perl_idcont = sv_dup_inc(proto_perl->Iutf8_perl_idcont, 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_errors = sv_dup_inc(proto_perl->Ierrors, param);
PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
- PL_sortstash = hv_dup(proto_perl->Isortstash, param);
PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
} while (++svp <= last);
AvREAL_off(unreferenced);
}
- SvREFCNT_dec(unreferenced);
+ SvREFCNT_dec_NN(unreferenced);
}
void
void
Perl_init_constants(pTHX)
{
- SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
+ SvREFCNT(&PL_sv_undef) = SvREFCNT_IMMORTAL;
SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
SvANY(&PL_sv_undef) = NULL;
SvANY(&PL_sv_no) = new_XPVNV();
- SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
+ SvREFCNT(&PL_sv_no) = SvREFCNT_IMMORTAL;
SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY
|SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
|SVp_POK|SVf_POK;
SvANY(&PL_sv_yes) = new_XPVNV();
- SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
+ SvREFCNT(&PL_sv_yes) = SvREFCNT_IMMORTAL;
SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY
|SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
|SVp_POK|SVf_POK;
Perl_sv_catpvf(aTHX_ name, "{%s}",
pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL,
PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT ));
- SvREFCNT_dec(sv);
+ SvREFCNT_dec_NN(sv);
}
else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
*SvPVX(name) = '$';
https://perl5.git.perl.org / perl5.git / blobdiff