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.
#endif
#ifdef DEBUG_LEAKING_SCALARS
-# define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
+# define FREE_SV_DEBUG_FILE(sv) STMT_START { \
+ if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \
+ } STMT_END
# define DEBUG_SV_SERIAL(sv) \
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
PTR2UV(sv), (long)(sv)->sv_debug_serial))
);
sv->sv_debug_inpad = 0;
sv->sv_debug_parent = NULL;
- sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
+ sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
sv->sv_debug_serial = PL_sv_serial++;
}
}
}
-
- /* XXX Might want to check arrays, etc. */
}
*/
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;
no longer need to unshare so as to free up the IVX slot for its proper
purpose. So it's safe to move the early return earlier. */
- if (new_type != SVt_PV && SvIsCOW(sv)) {
+ if (new_type > SVt_PVMG && SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
}
break;
-
- case SVt_REGEXP:
- /* This ensures that SvTHINKFIRST(sv) is true, and hence that
- sv_force_normal_flags(sv) is called. */
- SvFAKE_on(sv);
case SVt_PVIV:
/* XXX Is this still needed? Was it ever needed? Surely as there is
no route from NV to PVIV, NOK can never be true */
case SVt_PVGV:
case SVt_PVCV:
case SVt_PVLV:
+ case SVt_REGEXP:
case SVt_PVMG:
case SVt_PVNV:
case SVt_PV:
SvOBJECT_on(io);
/* Clear the stashcache because a new IO could overrule a package
name */
+ DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
hv_clear(PL_stashcache);
SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
IoPAGE_LEN(sv) = 60;
}
- if (old_type < SVt_PV) {
+ if (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
SVt_RV */
sv->sv_u.svu_rv = referant;
*/
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;
*/
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
SvUVX(sv)));
}
}
- else if (SvPOKp(sv) && SvLEN(sv)) {
+ else if (SvPOKp(sv)) {
UV value;
const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
/* We want to avoid a possible problem when we cache an IV/ a UV which
*/
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;
return PTR2IV(SvRV(sv));
}
- if (SvVALID(sv)) {
+ if (SvVALID(sv) || isREGEXP(sv)) {
/* FBMs use the space for SvIVX and SvNVX for other purposes, and use
the same flag bit as SVf_IVisUV, so must not let them cache IVs.
In practice they are extremely unlikely to actually get anywhere
accessible by user Perl code - the only way that I'm aware of is when
a constant subroutine which is used as the second argument to index.
+
+ Regexps have no SvIVX and SvNVX fields.
*/
- if (SvIOKp(sv))
- return SvIVX(sv);
- if (SvNOKp(sv))
- return I_V(SvNVX(sv));
- if (SvPOKp(sv) && SvLEN(sv)) {
+ assert(isREGEXP(sv) || SvPOKp(sv));
+ {
UV value;
+ const char * const ptr =
+ isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
const int numtype
- = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+ = grok_number(ptr, SvCUR(sv), &value);
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
- return I_V(Atof(SvPVX_const(sv)));
+ return I_V(Atof(ptr));
}
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- return 0;
}
if (SvTHINKFIRST(sv)) {
+#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
+#endif
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
*/
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;
return PTR2UV(SvRV(sv));
}
- if (SvVALID(sv)) {
+ if (SvVALID(sv) || isREGEXP(sv)) {
/* FBMs use the space for SvIVX and SvNVX for other purposes, and use
- the same flag bit as SVf_IVisUV, so must not let them cache IVs. */
- if (SvIOKp(sv))
- return SvUVX(sv);
- if (SvNOKp(sv))
- return U_V(SvNVX(sv));
- if (SvPOKp(sv) && SvLEN(sv)) {
+ the same flag bit as SVf_IVisUV, so must not let them cache IVs.
+ Regexps have no SvIVX and SvNVX fields. */
+ assert(isREGEXP(sv) || SvPOKp(sv));
+ {
UV value;
+ const char * const ptr =
+ isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
const int numtype
- = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+ = grok_number(ptr, SvCUR(sv), &value);
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
- return U_V(Atof(SvPVX_const(sv)));
+ return U_V(Atof(ptr));
}
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- return 0;
}
if (SvTHINKFIRST(sv)) {
+#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
+#endif
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
*/
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)
return 0.0;
- if (SvGMAGICAL(sv) || SvVALID(sv)) {
+ if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
/* FBMs use the space for SvIVX and SvNVX for other purposes, and use
- the same flag bit as SVf_IVisUV, so must not let them cache NVs. */
+ the same flag bit as SVf_IVisUV, so must not let them cache NVs.
+ Regexps have no SvIVX and SvNVX fields. */
+ const char *ptr;
if (flags & SV_GMAGIC)
mg_get(sv);
if (SvNOKp(sv))
return SvNVX(sv);
- if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
+ if (SvPOKp(sv) && !SvIOKp(sv)) {
+ ptr = SvPVX_const(sv);
+ grokpv:
if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
- !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
+ !grok_number(ptr, SvCUR(sv), NULL))
not_a_number(sv);
- return Atof(SvPVX_const(sv));
+ return Atof(ptr);
}
if (SvIOKp(sv)) {
if (SvIsUV(sv))
if (SvROK(sv)) {
goto return_rok;
}
+ if (isREGEXP(sv)) {
+ ptr = RX_WRAPPED((REGEXP *)sv);
+ goto grokpv;
+ }
assert(SvTYPE(sv) >= SVt_PVMG);
/* This falls through to the report_uninit near the end of the
function. */
}
return PTR2NV(SvRV(sv));
}
+#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
+#endif
if (SvREADONLY(sv) && !SvOK(sv)) {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
SvNOKp_on(sv);
#endif
}
- else if (SvPOKp(sv) && SvLEN(sv)) {
+ else if (SvPOKp(sv)) {
UV value;
const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
*/
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;
*lp = SvCUR(buffer);
return SvPVX(buffer);
}
+ else if (isREGEXP(sv)) {
+ if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
+ return RX_WRAPPED((REGEXP *)sv);
+ }
else {
if (lp)
*lp = 0;
*/
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;
if the whole string is the same in UTF-8 as not.
Returns the number of bytes in the converted string
-This is not as a general purpose byte encoding to Unicode interface:
+This is not a general purpose byte encoding to Unicode interface:
use the Encode extension for that.
=for apidoc sv_utf8_upgrade_nomg
C<sv_utf8_upgrade> and
C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
-This is not as a general purpose byte encoding to Unicode interface:
+This is not a general purpose byte encoding to Unicode interface:
use the Encode extension for that.
=cut
*/
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;
if (sv == &PL_sv_undef)
return 0;
- if (!SvPOK(sv)) {
+ if (!SvPOK_nog(sv)) {
STRLEN len = 0;
if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
(void) sv_2pv_flags(sv,&len, flags);
in this case, either returns false or, if C<fail_ok> is not
true, croaks.
-This is not as a general purpose Unicode to byte encoding interface:
+This is not a general purpose Unicode to byte encoding interface:
use the Encode extension for that.
=cut
*/
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;
static void
S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
{
- SV * const sref = SvREFCNT_inc(SvRV(sstr));
+ SV * const sref = SvRV(sstr);
SV *dref = NULL;
const int intro = GvINTRO(dstr);
SV **location;
GvASSUMECV_on(dstr);
if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(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;
assert(mg);
Perl_magic_clearisa(aTHX_ NULL, mg);
}
+ else if (stype == SVt_PVIO) {
+ DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref 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);
+ }
break;
}
SvREFCNT_dec(dref);
}
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_REGEXP:
+ upgregexp:
if (dtype < SVt_REGEXP)
+ {
+ if (dtype >= SVt_PV) {
+ SvPV_free(dstr);
+ SvPV_set(dstr, 0);
+ SvLEN_set(dstr, 0);
+ SvCUR_set(dstr, 0);
+ }
sv_upgrade(dstr, SVt_REGEXP);
+ }
break;
/* case SVt_BIND: */
return;
}
if (stype == SVt_PVLV)
+ {
+ if (isREGEXP(sstr)) goto upgregexp;
SvUPGRADE(dstr, SVt_PVNV);
+ }
else
SvUPGRADE(dstr, (svtype)stype);
}
}
}
}
- else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
+ else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
+ && (stype == SVt_REGEXP || isREGEXP(sstr))) {
reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
}
else if (sflags & SVp_POK) {
shared hash keys then we don't do the COW setup, even if the
source scalar is a shared hash key scalar. */
(((flags & SV_COW_SHARED_HASH_KEYS)
- ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
+ ? !(sflags & SVf_IsCOW)
: 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
in a newer implementation. */
/* If we are COW and dstr is a suitable target then we drop down
into the else and make dest a COW of us. */
- || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
+ || (SvFLAGS(dstr) & SVf_BREAK)
#endif
)
&&
}
#ifdef PERL_OLD_COPY_ON_WRITE
if (!isSwipe) {
- if ((sflags & (SVf_FAKE | SVf_READONLY))
- != (SVf_FAKE | SVf_READONLY)) {
- SvREADONLY_on(sstr);
- SvFAKE_on(sstr);
+ if (!(sflags & SVf_IsCOW)) {
+ SvIsCOW_on(sstr);
/* Make the source SV into a loop of 1.
(about to become 2) */
SV_COW_NEXT_SV_SET(sstr, sstr);
}
SvLEN_set(dstr, len);
SvCUR_set(dstr, cur);
- SvREADONLY_on(dstr);
- SvFAKE_on(dstr);
+ SvIsCOW_on(dstr);
}
else
{ /* Passes the swipe test. */
*/
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;
if (SvTHINKFIRST(dstr))
sv_force_normal_flags(dstr, SV_COW_DROP_PV);
else if (SvPVX_const(dstr))
- Safefree(SvPVX_const(dstr));
+ Safefree(SvPVX_mutable(dstr));
}
else
new_SV(dstr);
} else {
assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
SvUPGRADE(sstr, SVt_PVIV);
- SvREADONLY_on(sstr);
- SvFAKE_on(sstr);
+ SvIsCOW_on(sstr);
DEBUG_C(PerlIO_printf(Perl_debug_log,
"Fast copy on write: Converting sstr to COW\n"));
SV_COW_NEXT_SV_SET(dstr, sstr);
common_exit:
SvPV_set(dstr, new_pv);
- SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
+ SvFLAGS(dstr) = (SVt_PVIV|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);
SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
SvCUR_set(sv, HEK_LEN(hek));
SvLEN_set(sv, 0);
- SvREADONLY_on(sv);
- SvFAKE_on(sv);
+ SvIsCOW_on(sv);
SvPOK_on(sv);
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;
/* The SV we point to points back to us (there were only two of us
in the loop.)
Hence other SV is no longer copy on write either. */
- SvFAKE_off(after);
- SvREADONLY_off(after);
+ SvIsCOW_off(after);
} else {
/* We need to follow the pointers around the loop. */
SV *next;
*/
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;
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvREADONLY(sv)) {
- if (SvFAKE(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);
(long) flags);
sv_dump(sv);
}
- SvFAKE_off(sv);
- SvREADONLY_off(sv);
+ SvIsCOW_off(sv);
/* This SV doesn't own the buffer, so need to Newx() a new one: */
SvPV_set(sv, NULL);
SvLEN_set(sv, 0);
sv_dump(sv);
}
}
- else if (IN_PERL_RUNTIME)
- Perl_croak_no_modify(aTHX);
- }
#else
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 = SvCUR(sv);
- SvFAKE_off(sv);
- SvREADONLY_off(sv);
+ SvIsCOW_off(sv);
SvPV_set(sv, NULL);
SvLEN_set(sv, 0);
if (flags & SV_COW_DROP_PV) {
}
unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
}
- else if (IN_PERL_RUNTIME)
- Perl_croak_no_modify(aTHX);
- }
#endif
if (SvROK(sv))
sv_unref_flags(sv, flags);
else if (SvFAKE(sv) && isGV_with_GP(sv))
sv_unglob(sv, flags);
- else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
+ else if (SvFAKE(sv) && isREGEXP(sv)) {
/* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
to sv_unglob. We only need it here, so inline it. */
- const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
+ const bool islv = SvTYPE(sv) == SVt_PVLV;
+ const svtype new_type =
+ islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
SV *const temp = newSV_type(new_type);
- void *const temp_p = SvANY(sv);
+ regexp *const temp_p = ReANY((REGEXP *)sv);
if (new_type == SVt_PVMG) {
SvMAGIC_set(temp, SvMAGIC(sv));
SvSTASH_set(temp, SvSTASH(sv));
SvSTASH_set(sv, NULL);
}
- SvCUR_set(temp, SvCUR(sv));
- /* Remember that SvPVX is in the head, not the body. */
- if (SvLEN(temp)) {
- SvLEN_set(temp, SvLEN(sv));
- /* This signals "buffer is owned by someone else" in sv_clear,
- which is the least effort way to stop it freeing the buffer.
- */
- SvLEN_set(sv, SvLEN(sv)+1);
- } else {
- /* Their buffer is already owned by someone else. */
- SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
- SvLEN_set(temp, SvCUR(sv)+1);
+ if (!islv) SvCUR_set(temp, SvCUR(sv));
+ /* Remember that SvPVX is in the head, not the body. But
+ RX_WRAPPED is in the body. */
+ assert(ReANY((REGEXP *)sv)->mother_re);
+ /* Their buffer is already owned by someone else. */
+ if (flags & SV_COW_DROP_PV) {
+ /* SvLEN is already 0. For SVt_REGEXP, we have a brand new
+ zeroed body. For SVt_PVLV, it should have been set to 0
+ before turning into a regexp. */
+ assert(!SvLEN(islv ? sv : temp));
+ sv->sv_u.svu_pv = 0;
+ }
+ else {
+ sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
+ SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
+ SvPOK_on(sv);
}
/* Now swap the rest of the bodies. */
- SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
- SvFLAGS(sv) |= new_type;
- SvANY(sv) = SvANY(temp);
+ SvFAKE_off(sv);
+ if (!islv) {
+ SvFLAGS(sv) &= ~SVTYPEMASK;
+ SvFLAGS(sv) |= new_type;
+ SvANY(sv) = SvANY(temp);
+ }
SvFLAGS(temp) &= ~(SVTYPEMASK);
SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
SvANY(temp) = temp_p;
+ temp->sv_u.svu_rx = (regexp *)temp_p;
SvREFCNT_dec(temp);
}
*/
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;
*/
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;
&& !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
)
{
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
}
if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
*/
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);
assert(GvGP(gv));
assert(!CvANON(cv));
assert(CvGV(cv) == gv);
+ assert(!CvNAMED(cv));
/* will the CV shortly be freed by gp_free() ? */
if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
- SvANY(cv)->xcv_gv = NULL;
+ SvANY(cv)->xcv_gv_u.xcv_gv = NULL;
return;
}
CvANON_on(cv);
CvCVGV_RC_on(cv);
- SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
+ SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
}
goto freescalar;
case SVt_REGEXP:
/* FIXME for plugins */
+ freeregexp:
pregfree2((REGEXP*) sv);
goto freescalar;
case SVt_PVCV:
if ( PL_phase != PERL_PHASE_DESTRUCT
&& (name = HvNAME((HV*)sv)))
{
- if (PL_stashcache)
+ if (PL_stashcache) {
+ DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n",
+ sv));
(void)hv_delete(PL_stashcache, name,
HvNAMEUTF8((HV*)sv) ? -HvNAMELEN_get((HV*)sv) : HvNAMELEN_get((HV*)sv), G_DISCARD);
+ }
hv_name_set((HV*)sv, NULL, 0, 0);
}
}
else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
SvREFCNT_dec(LvTARG(sv));
+ if (isREGEXP(sv)) goto freeregexp;
case SVt_PVGV:
if (isGV_with_GP(sv)) {
if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
}
- SvFAKE_off(sv);
} else if (SvLEN(sv)) {
- Safefree(SvPVX_const(sv));
+ Safefree(SvPVX_mutable(sv));
}
}
#else
Safefree(SvPVX_mutable(sv));
else if (SvPVX_const(sv) && SvIsCOW(sv)) {
unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
- SvFAKE_off(sv);
}
#endif
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)
}
SvREFCNT_dec(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. */
+ SvSTASH_set(sv,0); /* SvREFCNT_dec may try to read this */
+ SvREFCNT_dec(stash); /* possibly of changed persuasion */
if (SvTYPE(sv) != SVt_PVIO)
--PL_sv_objcount;/* XXX Might want something more general */
}
=for apidoc sv_len
Returns the length of the string in the SV. Handles magic and type
-coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
+coercion and sets the UTF8 flag appropriately. See also C<SvCUR>, which
+gives raw access to the xpv_cur slot.
=cut
*/
STRLEN
-Perl_sv_len(pTHX_ register SV *const sv)
+Perl_sv_len(pTHX_ SV *const sv)
{
STRLEN len;
if (!sv)
return 0;
- if (SvGMAGICAL(sv))
- len = mg_length(sv);
- else
- (void)SvPV_const(sv, len);
+ (void)SvPV_const(sv, len);
return len;
}
*/
STRLEN
-Perl_sv_len_utf8(pTHX_ register SV *const sv)
+Perl_sv_len_utf8(pTHX_ SV *const sv)
{
if (!sv)
return 0;
- if (SvGMAGICAL(sv))
- return mg_length(sv);
- else
- {
- STRLEN len;
- const U8 *s = (U8*)SvPV_const(sv, len);
+ SvGETMAGIC(sv);
+ return sv_len_utf8_nomg(sv);
+}
+
+STRLEN
+Perl_sv_len_utf8_nomg(pTHX_ SV * const sv)
+{
+ dVAR;
+ STRLEN len;
+ const U8 *s = (U8*)SvPV_nomg_const(sv, len);
+
+ PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG;
- if (PL_utf8cache) {
+ if (PL_utf8cache && SvUTF8(sv)) {
STRLEN ulen;
MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
utf8_mg_len_cache_update(sv, &mg, ulen);
}
return ulen;
- }
- return Perl_utf8_length(aTHX_ s, s + len);
}
+ return SvUTF8(sv) ? Perl_utf8_length(aTHX_ s, s + len) : len;
}
/* Walk forwards to find the byte corresponding to the passed in UTF-8
if (!uoffset)
return 0;
- if (!SvREADONLY(sv)
+ if (!SvREADONLY(sv) && !SvGMAGICAL(sv) && SvPOK(sv)
&& PL_utf8cache
&& (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
(*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
boffset = real_boffset;
}
- if (PL_utf8cache) {
+ if (PL_utf8cache && !SvGMAGICAL(sv) && SvPOK(sv)) {
if (at_end)
utf8_mg_len_cache_update(sv, mgp, uoffset);
else
/* 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;
const STRLEN ulen)
{
PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
- if (SvREADONLY(sv))
+ if (SvREADONLY(sv) || SvGMAGICAL(sv) || !SvPOK(sv))
return;
if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
*
*/
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;
*/
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;
*/
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;
*/
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;
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (IN_PERL_RUNTIME)
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
if (SvROK(sv)) {
IV i;
*/
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_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
if (IN_PERL_RUNTIME)
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
if (SvROK(sv)) {
IV i;
* permanent location. */
SV *
-Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
+Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags)
{
dVAR;
SV *sv;
+ if (flags & SV_GMAGIC)
+ SvGETMAGIC(oldstr); /* before new_SV, in case it dies */
new_SV(sv);
- sv_setsv(sv,oldstr);
+ sv_setsv_flags(sv,oldstr,flags & ~SV_GMAGIC);
PUSH_EXTEND_MORTAL__SV_C(sv);
SvTEMP_on(sv);
return sv;
*/
SV *
-Perl_sv_2mortal(pTHX_ register SV *const sv)
+Perl_sv_2mortal(pTHX_ SV *const sv)
{
dVAR;
if (!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. */
SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
SvCUR_set(sv, HEK_LEN(hek));
SvLEN_set(sv, 0);
- SvREADONLY_on(sv);
- SvFAKE_on(sv);
+ SvIsCOW_on(sv);
SvPOK_on(sv);
if (HEK_UTF8(hek))
SvUTF8_on(sv);
SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
SvCUR_set(sv, len);
SvLEN_set(sv, 0);
- SvREADONLY_on(sv);
- SvFAKE_on(sv);
+ SvIsCOW_on(sv);
SvPOK_on(sv);
if (is_utf8)
SvUTF8_on(sv);
*/
SV *
-Perl_newSVsv(pTHX_ register SV *const old)
+Perl_newSVsv(pTHX_ SV *const old)
{
dVAR;
SV *sv;
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
return NULL;
}
+ /* Do this here, otherwise we leak the new SV if this croaks. */
+ SvGETMAGIC(old);
new_SV(sv);
- /* SV_GMAGIC is the default for sv_setv()
- SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
+ /* SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
- sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
+ sv_setsv_flags(sv, old, SV_NOSTEAL);
return 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;
+
+ sv_resetpvn(*s ? s : NULL, strlen(s), stash);
+}
+
+void
+Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash)
{
dVAR;
char todo[PERL_UCHAR_MAX+1];
-
- PERL_ARGS_ASSERT_SV_RESET;
+ const char *send;
if (!stash)
return;
- if (!*s) { /* reset ?? searches */
+ if (!s) { /* reset ?? searches */
MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
if (mg) {
const U32 count = mg->mg_len / sizeof(PMOP**);
return;
Zero(todo, 256, char);
- while (*s) {
+ send = s + len;
+ while (s < send) {
I32 max;
I32 i = (unsigned char)*s;
if (s[1] == '-') {
*/
I32
-Perl_sv_true(pTHX_ register SV *const sv)
+Perl_sv_true(pTHX_ SV *const sv)
{
if (!sv)
return 0;
{
PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
- sv_pvn_force(sv,lp);
- sv_utf8_upgrade(sv);
+ sv_pvn_force(sv,0);
+ sv_utf8_upgrade_nomg(sv);
*lp = SvCUR(sv);
return SvPVX(sv);
}
*/
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;
Perl_croak(aTHX_ "Can't bless non-reference value");
tmpRef = SvRV(sv);
if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
- if (SvIsCOW(tmpRef))
- sv_force_normal_flags(tmpRef, 0);
- if (SvREADONLY(tmpRef))
- Perl_croak_no_modify(aTHX);
+ if (SvREADONLY(tmpRef) && !SvIsCOW(tmpRef))
+ Perl_croak_no_modify();
if (SvOBJECT(tmpRef)) {
if (SvTYPE(tmpRef) != SVt_PVIO)
--PL_sv_objcount;
* vectorize happen normally
*/
if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) {
- char *version = savesvpv(vecsv);
if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
- Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_PRINTF),
"vector argument not supported with alpha versions");
- goto unknown;
+ goto vdblank;
}
vecsv = sv_newmortal();
- scan_vstring(version, version + veclen, vecsv);
+ scan_vstring((char *)vecstr, (char *)vecstr + veclen,
+ vecsv);
vecstr = (U8*)SvPV_const(vecsv, veclen);
vec_utf8 = DO_UTF8(vecsv);
- Safefree(version);
}
}
else {
+ vdblank:
vecstr = (U8*)"";
veclen = 0;
}
if (DO_UTF8(argsv)) {
STRLEN old_precis = precis;
if (has_precis && precis < elen) {
- STRLEN ulen = sv_len_utf8(argsv);
- I32 p = precis > ulen ? ulen : precis;
- sv_pos_u2b(argsv, &p, 0); /* sticks at end */
- precis = p;
+ STRLEN ulen = sv_or_pv_len_utf8(argsv, eptr, elen);
+ STRLEN p = precis > ulen ? ulen : precis;
+ precis = sv_or_pv_pos_u2b(argsv, eptr, p, 0);
+ /* sticks at end */
}
if (width) { /* fudge width (can't fudge elen) */
if (has_precis && precis < elen)
width += precis - old_precis;
else
- width += elen - sv_len_utf8(argsv);
+ width +=
+ elen - sv_or_pv_len_utf8(argsv,eptr,elen);
}
is_utf8 = TRUE;
}
have = esignlen + zeros + elen;
if (have < zeros)
- Perl_croak_nocontext("%s", PL_memory_wrap);
+ croak_memory_wrap();
need = (have > width ? have : width);
gap = need - have;
if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
- Perl_croak_nocontext("%s", PL_memory_wrap);
+ croak_memory_wrap();
SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
p = SvEND(sv);
if (esignlen && fill == '0') {
parser->multi_open = proto->multi_open;
parser->multi_start = proto->multi_start;
parser->multi_end = proto->multi_end;
- parser->pending_ident = proto->pending_ident;
parser->preambled = proto->preambled;
parser->sublex_info = proto->sublex_info; /* XXX not quite right */
parser->linestr = sv_dup_inc(proto->linestr, param);
{
PERL_ARGS_ASSERT_RVPV_DUP;
+ assert(!isREGEXP(sstr));
if (SvROK(sstr)) {
if (SvWEAKREF(sstr)) {
SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
if (SvLEN(sstr)) {
/* Normal PV - clone whole allocated space */
SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
- if (SvREADONLY(sstr) && SvFAKE(sstr)) {
- /* Not that normal - actually sstr is copy on write.
- But we are a true, independent SV, so: */
- SvREADONLY_off(dstr);
- SvFAKE_off(dstr);
- }
+ /* sstr may not be that normal, but actually copy on write.
+ But we are a true, independent SV, so: */
+ SvIsCOW_off(dstr);
}
else {
/* Special case - not normally malloced for some reason */
if (isGV_with_GP(sstr)) {
/* Don't need to do anything here. */
}
- else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
+ else if ((SvIsCOW(sstr))) {
/* A "shared" PV - clone it as "shared" PV */
SvPV_set(dstr,
HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
dstr->sv_debug_inpad = sstr->sv_debug_inpad;
dstr->sv_debug_parent = (SV*)sstr;
FREE_SV_DEBUG_FILE(dstr);
- dstr->sv_debug_file = savepv(sstr->sv_debug_file);
+ dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
#endif
ptr_table_store(PL_ptr_table, sstr, dstr);
if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
&& !isGV_with_GP(dstr)
+ && !isREGEXP(dstr)
&& !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
Perl_rvpv_dup(aTHX_ dstr, sstr, param);
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. */
case SVt_PVMG:
break;
case SVt_REGEXP:
+ duprex:
/* FIXME for plugins */
+ dstr->sv_u.svu_rx = ((REGEXP *)dstr)->sv_any;
re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
break;
case SVt_PVLV:
LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
else
LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
+ if (isREGEXP(sstr)) goto duprex;
case SVt_PVGV:
/* non-GP case already handled above */
if(isGV_with_GP(sstr)) {
daux->xhv_mro_meta = saux->xhv_mro_meta
? mro_meta_dup(saux->xhv_mro_meta, param)
: 0;
+ daux->xhv_super = NULL;
/* Record stashes for possible cloning in Perl_clone(). */
if (HvNAME(sstr))
}
assert(!CvSLABBED(dstr));
if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
+ if (CvNAMED(dstr))
+ SvANY((CV *)dstr)->xcv_gv_u.xcv_hek =
+ share_hek_hek(CvNAME_HEK((CV *)sstr));
/* don't dup if copying back - CvGV isn't refcounted, so the
* duped GV may never be freed. A bit of a hack! DAPM */
- SvANY(MUTABLE_CV(dstr))->xcv_gv =
+ else
+ SvANY(MUTABLE_CV(dstr))->xcv_gv_u.xcv_gv =
CvCVGV_RC(dstr)
? gv_dup_inc(CvGV(sstr), param)
: (param->flags & CLONEf_JOIN_IN)
TOPUV(nss,ix) = uv;
switch (type) {
case SAVEt_CLEARSV:
+ case SAVEt_CLEARPADRANGE:
break;
case SAVEt_HELEM: /* hash element */
sv = (const SV *)POPPTR(ss,ix);
new_state->re_state_bostr
= pv_dup(old_state->re_state_bostr);
- new_state->re_state_reginput
- = pv_dup(old_state->re_state_reginput);
new_state->re_state_regeol
= pv_dup(old_state->re_state_regeol);
#ifdef PERL_OLD_COPY_ON_WRITE
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;
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_origargc = proto_perl->Iorigargc;
PL_origargv = proto_perl->Iorigargv;
+#if !NO_TAINT_SUPPORT
/* Set tainting stuff before PerlIO_debug can possibly get called */
PL_tainting = proto_perl->Itainting;
PL_taint_warn = proto_perl->Itaint_warn;
+#else
+ PL_tainting = FALSE;
+ PL_taint_warn = FALSE;
+#endif
PL_minus_c = proto_perl->Iminus_c;
PL_timesbuf = proto_perl->Itimesbuf;
#endif
+#if !NO_TAINT_SUPPORT
PL_tainted = proto_perl->Itainted;
+#else
+ PL_tainted = FALSE;
+#endif
PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
/* magical thingies */
- PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
PL_encoding = sv_dup(proto_perl->Iencoding, 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_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_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
- PL_utf8_X_special_begin = sv_dup_inc(proto_perl->Iutf8_X_special_begin, param);
- PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
- /*not currently used: PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param);*/
PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
- PL_utf8_X_RI = sv_dup_inc(proto_perl->Iutf8_X_RI, param);
- PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
- PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
- PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, 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_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
PL_utf8_foldable = sv_dup_inc(proto_perl->Iutf8_foldable, param);
- PL_utf8_quotemeta = sv_dup_inc(proto_perl->Iutf8_quotemeta, param);
+ PL_utf8_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param);
+ PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param);
PL_ASCII = sv_dup_inc(proto_perl->IASCII, param);
PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
-
if (proto_perl->Ipsig_pend) {
Newxz(PL_psig_pend, SIG_SIZE, int);
}
Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
#endif
+ /* reset stack AV to correct length before its duped via
+ * PL_curstackinfo */
+ AvFILLp(proto_perl->Icurstack) =
+ proto_perl->Istack_sp - proto_perl->Istack_base;
+
/* NOTE: si_dup() looks at PL_markstack */
PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
save_re_context();
PUSHMARK(sp);
EXTEND(SP, 3);
- XPUSHs(encoding);
- XPUSHs(sv);
+ PUSHs(encoding);
+ PUSHs(sv);
/*
NI-S 2002/07/09
Passing sv_yes is wrong - it needs to be or'ed set of constants
save_re_context();
PUSHMARK(sp);
EXTEND(SP, 6);
- XPUSHs(encoding);
- XPUSHs(dsv);
- XPUSHs(ssv);
+ PUSHs(encoding);
+ PUSHs(dsv);
+ PUSHs(ssv);
offsv = newSViv(*offset);
- mXPUSHs(offsv);
- mXPUSHp(tstr, tlen);
+ mPUSHs(offsv);
+ mPUSHp(tstr, tlen);
PUTBACK;
call_method("cat_decode", G_SCALAR);
SPAGAIN;
array = HvARRAY(hv);
- for (i=HvMAX(hv); i>0; i--) {
+ for (i=HvMAX(hv); i>=0; i--) {
HE *entry;
for (entry = array[i]; entry; entry = HeNEXT(entry)) {
if (HeVAL(entry) != val)
return NULL;
av = *PadlistARRAY(CvPADLIST(cv));
sv = *av_fetch(av, targ, FALSE);
- sv_setsv(name, sv);
+ sv_setsv_flags(name, sv, 0);
}
if (subscript_type == FUV_SUBSCRIPT_HASH) {
case OP_PADAV:
case OP_PADHV:
{
- const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
- const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
+ const bool pad = ( obase->op_type == OP_PADAV
+ || obase->op_type == OP_PADHV
+ || obase->op_type == OP_PADRANGE
+ );
+
+ const bool hash = ( obase->op_type == OP_PADHV
+ || obase->op_type == OP_RV2HV
+ || (obase->op_type == OP_PADRANGE
+ && SvTYPE(PAD_SVl(obase->op_targ)) == SVt_PVHV)
+ );
I32 index = 0;
SV *keysv = NULL;
int subscript_type = FUV_SUBSCRIPT_WITHIN;
case OP_OPEN:
o = cUNOPx(obase)->op_first;
- if (o->op_type == OP_PUSHMARK)
+ if ( o->op_type == OP_PUSHMARK
+ || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
+ )
o = o->op_sibling;
if (!o->op_sibling) {
match = 1; /* print etc can return undef on defined args */
/* skip filehandle as it can't produce 'undef' warning */
o = cUNOPx(obase)->op_first;
- if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
+ if ((obase->op_flags & OPf_STACKED)
+ &&
+ ( o->op_type == OP_PUSHMARK
+ || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)))
o = o->op_sibling->op_sibling;
goto do_op2;
* left that is not skipped, then we *know* it is responsible for
* the uninitialized value. If there is more than one op left, we
* have to look for an exact match in the while() loop below.
+ * Note that we skip padrange, because the individual pad ops that
+ * it replaced are still in the tree, so we work on them instead.
*/
o2 = NULL;
for (kid=o; kid; kid = kid->op_sibling) {
if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
|| (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
|| (type == OP_PUSHMARK)
+ || (type == OP_PADRANGE)
)
continue;
}
https://perl5.git.perl.org / perl5.git / blobdiff