#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
/* ============================================================================
} else {
SvROK_off(ref);
SvRV_set(ref, NULL);
- SvREFCNT_dec(target);
+ SvREFCNT_dec_NN(target);
}
}
}
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);
}
/*
#endif
}
else
+ {
+ if (SvIsCOW(sv)) sv_force_normal(sv);
s = SvPVX_mutable(sv);
+ }
if (newlen > SvLEN(sv)) { /* need more room? */
STRLEN minlen = SvCUR(sv);
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, SV* sstr, const I32 flags)
{
}
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
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);
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();
}
- 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)
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);
}
vtable = (vtable_index == magic_vtable_max)
? NULL : PL_magic_vtables + vtable_index;
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
#endif
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;
}
: 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);
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));
}
}
#endif
if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
/* make sure SvREFCNT(sv)==0 happens very seldom */
- SvREFCNT(sv) = (~(U32)0)/2;
+ SvREFCNT(sv) = SvREFCNT_IMMORTAL;
continue;
}
break;
SvRV_set(tmpref, NULL);
SvROK_off(tmpref);
}
- SvREFCNT_dec(tmpref);
+ SvREFCNT_dec_NN(tmpref);
}
}
} while (SvOBJECT(sv) && SvSTASH(sv) != stash);
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 (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 (SvREADONLY(sv) && 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 (SvREADONLY(sv) && SvIMMORTAL(sv)) {
- /* make sure SvREFCNT(sv)==0 happens very seldom */
- SvREFCNT(sv) = (~(U32)0)/2;
- return;
+ /* make sure SvREFCNT(sv)==0 happens very seldom */
+ SvREFCNT(sv) = SvREFCNT_IMMORTAL;
+ return;
}
- sv_clear(sv);
- if (! SvREFCNT(sv))
- del_SV(sv);
+ 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
+
}
+
/*
=for apidoc sv_len
}
/* Now both are in UTF-8. */
if (cur1 != cur2) {
- SvREFCNT_dec(svrecode);
+ SvREFCNT_dec_NN(svrecode);
return FALSE;
}
}
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)
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
/*
=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
*/
/* 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 */
}
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);
= 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
+#ifdef PERL_ANY_COW
new_state->re_state_nrs
= sv_dup(old_state->re_state_nrs, param);
#endif
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;
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) {
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);
} 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