/* sv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* "A time to plant, and a time to uproot what was planted..."
*/
+/*
+ * nice_chunk and nice_chunk size need to be set
+ * and queried under the protection of sv_mutex
+ */
+void
+Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
+{
+ void *new_chunk;
+ U32 new_chunk_size;
+ LOCK_SV_MUTEX;
+ new_chunk = (void *)(chunk);
+ new_chunk_size = (chunk_size);
+ if (new_chunk_size > PL_nice_chunk_size) {
+ Safefree(PL_nice_chunk);
+ PL_nice_chunk = (char *) new_chunk;
+ PL_nice_chunk_size = new_chunk_size;
+ } else {
+ Safefree(chunk);
+ }
+ UNLOCK_SV_MUTEX;
+}
#define plant_SV(p) \
STMT_START { \
}
else {
char *chunk; /* must use New here to match call to */
- New(704,chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
+ Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
}
uproot_SV(sv);
do_clean_named_objs(pTHX_ SV *sv)
{
if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
- if ( SvOBJECT(GvSV(sv)) ||
+ if ((
+#ifdef PERL_DONT_CREATE_GVSV
+ GvSV(sv) &&
+#endif
+ SvOBJECT(GvSV(sv))) ||
(GvAV(sv) && SvOBJECT(GvAV(sv))) ||
(GvHV(sv) && SvOBJECT(GvHV(sv))) ||
(GvIO(sv) && SvOBJECT(GvIO(sv))) ||
PL_xpvmg_arenaroot = 0;
PL_xpvmg_root = 0;
- for (arena = (XPV*)PL_xpvgv_arenaroot; arena; arena = arenanext) {
- arenanext = (XPV*)arena->xpv_pv;
- Safefree(arena);
- }
- PL_xpvgv_arenaroot = 0;
- PL_xpvgv_root = 0;
-
for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
arenanext = (XPV*)arena->xpv_pv;
Safefree(arena);
PL_pte_root = 0;
#endif
- if (PL_nice_chunk)
- Safefree(PL_nice_chunk);
+ Safefree(PL_nice_chunk);
PL_nice_chunk = Nullch;
PL_nice_chunk_size = 0;
PL_sv_arenaroot = 0;
Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, "", "");
}
-
/* allocate another arena's worth of struct xrv */
STATIC void
/* allocate another arena's worth of struct xpvnv */
STATIC void
-S_more_xpvnv(pTHX)
-{
+S_more_xpvnv(pTHX) {
XPVNV* xpvnv;
XPVNV* xpvnvend;
New(715, xpvnv, PERL_ARENA_SIZE/sizeof(XPVNV), XPVNV);
xpvmg->xpv_pv = 0;
}
-/* allocate another arena's worth of struct xpvgv */
-
-STATIC void
-S_more_xpvgv(pTHX)
-{
- XPVGV* xpvgv;
- XPVGV* xpvgvend;
- New(720, xpvgv, PERL_ARENA_SIZE/sizeof(XPVGV), XPVGV);
- xpvgv->xpv_pv = (char*)PL_xpvgv_arenaroot;
- PL_xpvgv_arenaroot = xpvgv;
-
- xpvgvend = &xpvgv[PERL_ARENA_SIZE / sizeof(XPVGV) - 1];
- PL_xpvgv_root = ++xpvgv;
- while (xpvgv < xpvgvend) {
- xpvgv->xpv_pv = (char*)(xpvgv + 1);
- xpvgv++;
- }
- xpvgv->xpv_pv = 0;
-}
-
/* allocate another arena's worth of struct xpvlv */
STATIC void
UNLOCK_SV_MUTEX;
}
-/* grab a new struct xpvgv from the free list, allocating more if necessary */
-
-STATIC XPVGV*
-S_new_xpvgv(pTHX)
-{
- XPVGV* xpvgv;
- LOCK_SV_MUTEX;
- if (!PL_xpvgv_root)
- S_more_xpvgv(aTHX);
- xpvgv = PL_xpvgv_root;
- PL_xpvgv_root = (XPVGV*)xpvgv->xpv_pv;
- UNLOCK_SV_MUTEX;
- return xpvgv;
-}
-
-/* return a struct xpvgv to the free list */
-
-STATIC void
-S_del_xpvgv(pTHX_ XPVGV *p)
-{
- LOCK_SV_MUTEX;
- p->xpv_pv = (char*)PL_xpvgv_root;
- PL_xpvgv_root = p;
- UNLOCK_SV_MUTEX;
-}
-
/* grab a new struct xpvlv from the free list, allocating more if necessary */
STATIC XPVLV*
#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
#define del_XPVMG(p) my_safefree(p)
-#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
-#define del_XPVGV(p) my_safefree(p)
-
#define new_XPVLV() my_safemalloc(sizeof(XPVLV))
#define del_XPVLV(p) my_safefree(p)
#define new_XPVMG() (void*)new_xpvmg()
#define del_XPVMG(p) del_xpvmg((XPVMG *)p)
-#define new_XPVGV() (void*)new_xpvgv()
-#define del_XPVGV(p) del_xpvgv((XPVGV *)p)
-
#define new_XPVLV() (void*)new_xpvlv()
#define del_XPVLV(p) del_xpvlv((XPVLV *)p)
#endif /* PURIFY */
+#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
+#define del_XPVGV(p) my_safefree(p)
+
#define new_XPVFM() my_safemalloc(sizeof(XPVFM))
#define del_XPVFM(p) my_safefree(p)
void
Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
{
- /* With these two if statements:
- u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
-
- without
- u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
-
- If you wish to remove them, please benchmark to see what the effect is
- */
- if (u <= (UV)IV_MAX) {
- sv_setiv(sv, (IV)u);
- } else {
- sv_setiv(sv, 0);
- SvIsUV_on(sv);
- sv_setuv(sv,u);
- }
+ sv_setiv(sv, 0);
+ SvIsUV_on(sv);
+ sv_setuv(sv,u);
SvSETMAGIC(sv);
}
{
SV *dsv;
char tmpbuf[64];
- char *pv;
+ const char *pv;
if (DO_UTF8(sv)) {
- dsv = sv_2mortal(newSVpv("", 0));
+ dsv = sv_2mortal(newSVpvn("", 0));
pv = sv_uni_display(dsv, sv, 10, 0);
} else {
char *d = tmpbuf;
return asIV(sv);
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
+ if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
report_uninit();
}
return 0;
#endif /* NV_PRESERVES_UV */
}
} else {
- if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
report_uninit();
if (SvTYPE(sv) < SVt_IV)
/* Typically the caller expects that sv_any is not NULL now. */
return asUV(sv);
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
+ if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
report_uninit();
}
return 0;
}
else {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
+ if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
report_uninit();
}
if (SvTYPE(sv) < SVt_IV)
if (SvNOKp(sv))
return SvNVX(sv);
if (SvPOKp(sv) && SvLEN(sv)) {
- if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
+ if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
!grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
not_a_number(sv);
return Atof(SvPVX_const(sv));
}
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
+ if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
report_uninit();
}
return (NV)0;
else if (SvPOKp(sv) && SvLEN(sv)) {
UV value;
const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
- if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
+ if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
#ifdef NV_PRESERVES_UV
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
#endif /* NV_PRESERVES_UV */
}
else {
- if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
report_uninit();
if (SvTYPE(sv) < SVt_NV)
/* Typically the caller expects that sv_any is not NULL now. */
*/
static char *
-uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
+S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
{
char *ptr = buf + TYPE_CHARS(UV);
char *ebuf = ptr;
}
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
+ if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
report_uninit();
}
if (lp)
}
}
- New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
+ Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
Copy("(?", mg->mg_ptr, 2, char);
Copy(reflags, mg->mg_ptr+2, left, char);
Copy(":", mg->mg_ptr+left+2, 1, char);
#endif
}
else {
- if (ckWARN(WARN_UNINITIALIZED)
- && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
report_uninit();
if (lp)
*lp = 0;
return SvPVX(tsv);
}
else {
- STRLEN len;
+ STRLEN len;
const char *t;
if (tsv) {
s = SvGROW_mutable(sv, len + 1);
SvCUR_set(sv, len);
SvPOKp_on(sv);
- return strcpy(s, t);
+ return memcpy(s, t, len + 1);
}
}
Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
{
sv_utf8_upgrade(sv);
- return SvPV(sv,*lp);
+ return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
}
/*
* we want to make sure everything inside is valid utf8 first.
*/
c = (const U8 *) SvPVX_const(sv);
- if (!is_utf8_string(c, SvCUR(sv)+1))
+ if (!is_utf8_string((U8 *)c, SvCUR(sv)+1))
return FALSE;
e = (const U8 *) SvEND(sv);
while (c < e) {
- U8 ch = *c++;
+ const U8 ch = *c++;
if (!UTF8_IS_INVARIANT(ch)) {
SvUTF8_on(sv);
break;
if (!intro)
cv_ckproto(cv, (GV*)dstr,
SvPOK(sref)
- ? SvPVX_const(sref) : Nullch);
+ ? (char *)SvPVX_const(sref)
+ : Nullch);
}
GvCV(dstr) = (CV*)sref;
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
/* and won't be needed again, potentially */
!(PL_op && PL_op->op_type == OP_AASSIGN))
{
- if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
- if (SvOOK(dstr)) {
- SvFLAGS(dstr) &= ~SVf_OOK;
- Safefree(SvPVX_const(dstr) - SvIVX(dstr));
- }
- else if (SvLEN(dstr))
- Safefree(SvPVX_const(dstr));
+ if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
+ SvPV_free(dstr);
}
(void)SvPOK_only(dstr);
SvPV_set(dstr, SvPVX(sstr));
{
if (SvREADONLY(sv)) {
if (SvFAKE(sv)) {
- const char *pvx = SvPVX_const(sv);
+ const char * const pvx = SvPVX_const(sv);
const STRLEN len = SvCUR(sv);
const U32 hash = SvSHARED_HASH(sv);
SvFAKE_off(sv);
SvREADONLY_off(sv);
SvGROW(sv, len + 1);
- Move(pvx,SvPVX_const(sv),len,char);
+ Move(pvx,SvPVX(sv),len,char);
*SvEND(sv) = '\0';
unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
}
const char *pvx = SvPVX_const(sv);
const STRLEN len = SvCUR(sv);
SvGROW(sv, len + 1);
- Move(pvx,SvPVX_const(sv),len,char);
+ Move(pvx,SvPVX(sv),len,char);
*SvEND(sv) = '\0';
}
SvIV_set(sv, 0);
if (SvTYPE(sv) < SVt_PVMG) {
(void)SvUPGRADE(sv, SVt_PVMG);
}
- Newz(702,mg, 1, MAGIC);
+ Newxz(mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(sv);
SvMAGIC_set(sv, mg);
void
Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
{
- const MGVTBL *vtable = 0;
+ const MGVTBL *vtable;
MAGIC* mg;
if (SvREADONLY(sv)) {
- if (IN_PERL_RUNTIME
+ if (
+ /* its okay to attach magic to shared strings; the subsequent
+ * upgrade to PVMG will unshare the string */
+ !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
+
+ && IN_PERL_RUNTIME
&& how != PERL_MAGIC_regex_global
&& how != PERL_MAGIC_bm
&& how != PERL_MAGIC_fm
vtable = &PL_vtbl_nkeys;
break;
case PERL_MAGIC_dbfile:
- vtable = 0;
+ vtable = NULL;
break;
case PERL_MAGIC_dbline:
vtable = &PL_vtbl_dbline;
vtable = &PL_vtbl_vec;
break;
case PERL_MAGIC_vstring:
- vtable = 0;
+ vtable = NULL;
break;
case PERL_MAGIC_utf8:
vtable = &PL_vtbl_utf8;
/* Useful for attaching extension internal data to perl vars. */
/* Note that multiple extensions may clash if magical scalars */
/* etc holding private data from one are passed to another. */
+ vtable = NULL;
break;
default:
Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
}
/* Rest of work is done else where */
- mg = sv_magicext(sv,obj,how,vtable,name,namlen);
+ mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen);
switch (how) {
case PERL_MAGIC_taint:
AV *av;
SV **svp;
I32 i;
- SV *tsv = SvRV(sv);
+ SV * const tsv = SvRV(sv);
MAGIC *mg = NULL;
if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
Perl_croak(aTHX_ "panic: del_backref");
stash = SvSTASH(sv);
destructor = StashHANDLER(stash,DESTROY);
if (destructor) {
- SV* tmpref = newRV(sv);
+ SV* const tmpref = newRV(sv);
SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
ENTER;
PUSHSTACKi(PERLSI_DESTROY);
SvREFCNT_dec(SvRV(sv));
}
else if (SvPVX_const(sv) && SvLEN(sv))
- Safefree(SvPVX_const(sv));
+ Safefree(SvPVX_mutable(sv));
else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
unsharepvn(SvPVX_const(sv),
SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
SvREFCNT(sv) = (~(U32)0)/2;
return;
}
- if (ckWARN_d(WARN_INTERNAL))
+ if (ckWARN_d(WARN_INTERNAL)) {
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Attempt to free unreferenced scalar: SV 0x%"UVxf
pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+ Perl_dump_sv_child(aTHX_ sv);
+#endif
+ }
return;
}
ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
#endif
}
else {
- ulen = Perl_utf8_length(aTHX_ s, s + len);
+ ulen = Perl_utf8_length(aTHX_ (U8 *)s, (U8 *)s + len);
if (!mg && !SvREADONLY(sv)) {
sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
mg = mg_find(sv, PERL_MAGIC_utf8);
if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
if (!*mgp)
- *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
+ *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
assert(*mgp);
- if ((*mgp)->mg_ptr)
- *cachep = (STRLEN *) (*mgp)->mg_ptr;
- else {
- Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
- (*mgp)->mg_ptr = (char *) *cachep;
- }
- assert(*cachep);
+ if ((*mgp)->mg_ptr)
+ *cachep = (STRLEN *) (*mgp)->mg_ptr;
+ else {
+ Newxz(*cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
+ (*mgp)->mg_ptr = (char *) *cachep;
+ }
+ assert(*cachep);
(*cachep)[i] = offsetp;
(*cachep)[i+1] = s - start;
STRLEN *cache = 0;
const U8 *s = start;
I32 uoffset = *offsetp;
- const U8 *send = s + len;
+ const U8 * const send = s + len;
MAGIC *mg = 0;
bool found = FALSE;
* is made as in S_utf8_mg_pos(), namely that
* walking backward is twice slower than
* walking forward. */
- STRLEN forw = *offsetp;
+ const STRLEN forw = *offsetp;
STRLEN backw = cache[1] - *offsetp;
if (!(forw < 2 * backw)) {
/* Call utf8n_to_uvchr() to validate the sequence
* (unless a simple non-UTF character) */
if (!UTF8_IS_INVARIANT(*s))
- utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
+ utf8n_to_uvchr((U8 *)s, UTF8SKIP(s), &n, 0);
if (n > 0) {
s += n;
len++;
assert(mg);
if (!mg->mg_ptr) {
- Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
+ Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
mg->mg_ptr = (char *) cache;
}
assert(cache);
if (SvUTF8(sv1)) {
/* sv1 is the UTF-8 one,
* if is equal it must be downgrade-able */
- char *pv = (char*)bytes_from_utf8((const U8*)pv1,
+ char * const pv = (char*)bytes_from_utf8((U8*)pv1,
&cur1, &is_utf8);
if (pv != pv1)
pv1 = tpv = pv;
else {
/* sv2 is the UTF-8 one,
* if is equal it must be downgrade-able */
- char *pv = (char *)bytes_from_utf8((const U8*)pv2,
+ char * const pv = (char *)bytes_from_utf8((U8*)pv2,
&cur2, &is_utf8);
if (pv != pv2)
pv2 = tpv = pv;
pv2 = SvPV_const(svrecode, cur2);
}
else {
- pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
+ pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2);
}
}
else {
pv1 = SvPV_const(svrecode, cur1);
}
else {
- pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
+ pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1);
}
}
}
sv_pos_u2b(sv,&append,0);
}
} else if (SvUTF8(sv)) {
- SV *tsv = NEWSV(0,0);
+ SV * const tsv = NEWSV(0,0);
sv_gets(tsv, fp, 0);
sv_utf8_upgrade_nomg(tsv);
SvCUR_set(sv,append);
else
{
/*The big, slow, and stupid way. */
-
- /* Any stack-challenged places. */
-#if defined(EPOC)
- /* EPOC: need to work around SDK features. *
- * On WINS: MS VC5 generates calls to _chkstk, *
- * if a "large" stack frame is allocated. *
- * gcc on MARM does not generate calls like these. */
-# define USEHEAPINSTEADOFSTACK
-#endif
-
-#ifdef USEHEAPINSTEADOFSTACK
+#ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
STDCHAR *buf = 0;
- New(0, buf, 8192, STDCHAR);
+ Newx(buf, 8192, STDCHAR);
assert(buf);
#else
STDCHAR buf[8192];
goto screamer2;
}
-#ifdef USEHEAPINSTEADOFSTACK
+#ifdef USE_HEAP_INSTEAD_OF_STACK
Safefree(buf);
#endif
}
Andreas would like keys he put in as utf8 to come back as utf8
*/
STRLEN utf8_len = HEK_LEN(hek);
- U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
- SV *sv = newSVpvn ((char*)as_utf8, utf8_len);
+ const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
+ SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
SvUTF8_on (sv);
Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
that would contain the (wrong) hash value, and might get passed
into an hv routine with a regular hash */
- SV *sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
+ SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
if (HEK_UTF8(hek))
SvUTF8_on (sv);
return sv;
STRLEN tmplen = -len;
is_utf8 = TRUE;
/* See the note in hv.c:hv_fetch() --jhi */
- src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
+ src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
len = tmplen;
}
if (!hash)
continue;
gv = (GV*)HeVAL(entry);
sv = GvSV(gv);
- if (SvTHINKFIRST(sv)) {
- if (!SvREADONLY(sv) && SvROK(sv))
- sv_unref(sv);
- continue;
- }
- SvOK_off(sv);
- if (SvTYPE(sv) >= SVt_PV) {
- SvCUR_set(sv, 0);
- if (SvPVX_const(sv) != Nullch)
- *SvPVX(sv) = '\0';
- SvTAINT(sv);
+ if (sv) {
+ if (SvTHINKFIRST(sv)) {
+ if (!SvREADONLY(sv) && SvROK(sv))
+ sv_unref(sv);
+ /* XXX Is this continue a bug? Why should THINKFIRST
+ exempt us from resetting arrays and hashes? */
+ continue;
+ }
+ SvOK_off(sv);
+ if (SvTYPE(sv) >= SVt_PV) {
+ SvCUR_set(sv, 0);
+ if (SvPVX_const(sv) != Nullch)
+ *SvPVX(sv) = '\0';
+ SvTAINT(sv);
+ }
}
if (GvAV(gv)) {
av_clear(GvAV(gv));
}
if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
+#if defined(VMS)
+ Perl_die(aTHX_ "Can't reset %%ENV on this system");
+#else /* ! VMS */
hv_clear(GvHV(gv));
-#ifndef PERL_MICRO
-#ifdef USE_ENVIRON_ARRAY
- if (gv == PL_envgv
-# ifdef USE_ITHREADS
- && PL_curinterp == aTHX
-# endif
- )
- {
- environ[0] = Nullch;
- }
-#endif
-#endif /* !PERL_MICRO */
+# if defined(USE_ENVIRON_ARRAY)
+ if (gv == PL_envgv)
+ my_clearenv();
+# endif /* USE_ENVIRON_ARRAY */
+#endif /* VMS */
}
}
}
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",
- sv_reftype(sv,0), OP_NAME(PL_op));
+ ref, OP_NAME(PL_op));
else
- Perl_croak(aTHX_ "Can't coerce readonly %s to string",
- sv_reftype(sv,0));
+ Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
}
- if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
+ if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
OP_NAME(PL_op));
- }
- else
- s = sv_2pv_flags(sv, &len, flags);
+ s = sv_2pv_flags(sv, &len, flags);
if (lp)
*lp = len;
sv_unref(sv);
(void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
SvGROW(sv, len + 1);
- Move(s,SvPVX_const(sv),len,char);
+ Move(s,SvPVX(sv),len,char);
SvCUR_set(sv, len);
*SvEND(sv) = '\0';
}
/* The fact that I don't need to downcast to char * everywhere, only in ?:
inside return suggests a const propagation bug in g++. */
if (ob && SvOBJECT(sv)) {
- char *name = HvNAME_get(SvSTASH(sv));
+ char * const name = HvNAME_get(SvSTASH(sv));
return name ? name : (char *) "__ANON__";
}
else {
SvROK_on(rv);
if (classname) {
- HV* stash = gv_stashpv(classname, TRUE);
+ HV* const stash = gv_stashpv(classname, TRUE);
(void)sv_bless(rv, stash);
}
return sv;
void
Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
{
- SV* rv = SvRV(sv);
+ SV const * rv = SvRV(sv);
if (SvWEAKREF(sv)) {
sv_del_backref(sv);
if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
SvREFCNT_dec(rv);
else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
- sv_2mortal(rv); /* Schedule for freeing later */
+ sv_2mortal((SV *)rv); /* Schedule for freeing later */
}
/*
Perl_sv_untaint(pTHX_ SV *sv)
{
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
- MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
+ MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
if (mg)
mg->mg_len &= ~1;
}
{
char buf[TYPE_CHARS(UV)];
char *ebuf;
- char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
+ char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
sv_setpvn(sv, ptr, ebuf - ptr);
}
{
char buf[TYPE_CHARS(UV)];
char *ebuf;
- char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
+ char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
sv_setpvn(sv, ptr, ebuf - ptr);
SvSETMAGIC(sv);
const char *patend;
STRLEN origlen;
I32 svix = 0;
- static char nullstr[] = "(null)";
+ static const char nullstr[] = "(null)";
SV *argsv = Nullsv;
bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
if (patlen == 2 && pat[0] == '%') {
switch (pat[1]) {
case 's':
- if (args) {
- const char * const s = va_arg(*args, char*);
- sv_catpv(sv, s ? s : nullstr);
- }
- else if (svix < svmax) {
- sv_catsv(sv, *svargs);
- if (DO_UTF8(*svargs))
- SvUTF8_on(sv);
- }
- return;
+ if (args) {
+ const char * const s = va_arg(*args, char*);
+ sv_catpv(sv, s ? s : nullstr);
+ }
+ else if (svix < svmax) {
+ sv_catsv(sv, *svargs);
+ if (DO_UTF8(*svargs))
+ SvUTF8_on(sv);
+ }
+ return;
case '_':
if (args) {
argsv = va_arg(*args, SV*);
#ifndef USE_LONG_DOUBLE
/* special-case "%.<number>[gf]" */
- if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
+ if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
&& (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
unsigned digits = 0;
const char *pp;
if (pp - pat == (int)patlen - 1) {
NV nv;
- if (args)
- nv = (NV)va_arg(*args, double);
- else if (svix < svmax)
+ if (svix < svmax)
nv = SvNV(*svargs);
else
return;
STRLEN have;
STRLEN need;
STRLEN gap;
- const char *dotstr = ".";
+ const char *dotstr = ".";
STRLEN dotstrlen = 1;
I32 efix = 0; /* explicit format parameter index */
I32 ewix = 0; /* explicit width index */
}
if (!asterisk)
+ {
if( *q == '0' )
fill = *q++;
EXPECT_NUMBER(q, width);
+ }
#ifdef CHECK_FORMAT
if ((*q == 'p') && left) {
if (vectorarg) {
if (args)
vecsv = va_arg(*args, SV*);
- else
- vecsv = (evix ? evix <= svmax : svix < svmax) ?
- svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
+ else if (evix) {
+ vecsv = (evix > 0 && evix <= svmax)
+ ? svargs[evix-1] : &PL_sv_undef;
+ } else {
+ vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
+ }
dotstr = SvPV_const(vecsv, dotstrlen);
if (DO_UTF8(vecsv))
is_utf8 = TRUE;
vecstr = (U8*)SvPV_const(vecsv,veclen);
vec_utf8 = DO_UTF8(vecsv);
}
- else if (efix ? efix <= svmax : svix < svmax) {
+ else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
vecsv = svargs[efix ? efix-1 : svix++];
vecstr = (U8*)SvPV_const(vecsv,veclen);
vec_utf8 = DO_UTF8(vecsv);
}
else {
+ vecsv = &PL_sv_undef;
vecstr = (U8*)"";
veclen = 0;
}
if (vectorize)
argsv = vecsv;
- else if (!args)
- argsv = (efix ? efix <= svmax : svix < svmax) ?
- svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
+ else if (!args) {
+ if (efix) {
+ const I32 i = efix-1;
+ argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
+ } else {
+ argsv = (svix >= 0 && svix < svmax)
+ ? svargs[svix++] : &PL_sv_undef;
+ }
+ }
switch (c = *q++) {
#endif
elen = strlen(eptr);
else {
- eptr = nullstr;
+ eptr = (char *)nullstr;
elen = sizeof nullstr - 1;
}
}
if (!veclen)
continue;
if (vec_utf8)
- uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
+ uv = utf8n_to_uvchr((U8 *)vecstr, veclen, &ulen,
UTF8_ALLOW_ANYUV);
else {
uv = *vecstr;
if (!veclen)
continue;
if (vec_utf8)
- uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
+ uv = utf8n_to_uvchr((U8 *)vecstr, veclen, &ulen,
UTF8_ALLOW_ANYUV);
else {
uv = *vecstr;
*--ptr = '0';
break;
case 2:
+ if (!uv)
+ alt = FALSE;
do {
dig = uv & 1;
*--ptr = '0' + dig;
if (PL_efloatsize < need) {
Safefree(PL_efloatbuf);
PL_efloatsize = need + 20; /* more fudge */
- New(906, PL_efloatbuf, PL_efloatsize, char);
+ Newx(PL_efloatbuf, PL_efloatsize, char);
PL_efloatbuf[0] = '\0';
}
default:
unknown:
- if (!args && ckWARN(WARN_PRINTF) &&
- (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
+ if (!args
+ && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
+ && ckWARN(WARN_PRINTF))
+ {
SV *msg = sv_newmortal();
Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
(PL_op->op_type == OP_PRTF) ? "" : "s");
/* calculate width before utf8_upgrade changes it */
have = esignlen + zeros + elen;
+ if (have < zeros)
+ Perl_croak_nocontext(PL_memory_wrap);
if (is_utf8 != has_utf8) {
if (is_utf8) {
need = (have > width ? have : width);
gap = need - have;
+ if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
+ Perl_croak_nocontext(PL_memory_wrap);
SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
p = SvEND(sv);
if (esignlen && fill == '0') {
len = r->offsets[0];
npar = r->nparens+1;
- Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
+ Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
Copy(r->program, ret->program, len+1, regnode);
- New(0, ret->startp, npar, I32);
+ Newx(ret->startp, npar, I32);
Copy(r->startp, ret->startp, npar, I32);
- New(0, ret->endp, npar, I32);
+ Newx(ret->endp, npar, I32);
Copy(r->startp, ret->startp, npar, I32);
- New(0, ret->substrs, 1, struct reg_substr_data);
+ Newx(ret->substrs, 1, struct reg_substr_data);
for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
s->min_offset = r->substrs->data[i].min_offset;
s->max_offset = r->substrs->data[i].max_offset;
const int count = r->data->count;
int i;
- Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
+ Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
char, struct reg_data);
- New(0, d->what, count, U8);
+ Newx(d->what, count, U8);
d->count = count;
for (i = 0; i < count; i++) {
break;
case 'f':
/* This is cheating. */
- New(0, d->data[i], 1, struct regnode_charclass_class);
+ Newx(d->data[i], 1, struct regnode_charclass_class);
StructCopy(r->data->data[i], d->data[i],
struct regnode_charclass_class);
ret->regstclass = (regnode*)d->data[i];
else
ret->data = NULL;
- New(0, ret->offsets, 2*len+1, U32);
+ Newx(ret->offsets, 2*len+1, U32);
Copy(r->offsets, ret->offsets, 2*len+1, U32);
ret->precomp = SAVEPVN(r->precomp, r->prelen);
return ret;
/* create anew and remember what it is */
- Newz(0, ret, 1, GP);
+ Newxz(ret, 1, GP);
ptr_table_store(PL_ptr_table, gp, ret);
/* clone */
for (; mg; mg = mg->mg_moremagic) {
MAGIC *nmg;
- Newz(0, nmg, 1, MAGIC);
+ Newxz(nmg, 1, MAGIC);
if (mgprev)
mgprev->mg_moremagic = nmg;
else
Perl_ptr_table_new(pTHX)
{
PTR_TBL_t *tbl;
- Newz(0, tbl, 1, PTR_TBL_t);
+ Newxz(tbl, 1, PTR_TBL_t);
tbl->tbl_max = 511;
tbl->tbl_items = 0;
- Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
+ Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
return tbl;
}
/* add a new entry to a pointer-mapping table */
void
-Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
+Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldsv, void *newsv)
{
PTR_TBL_ENT_t *tblent, **otblent;
/* XXX this may be pessimal on platforms where pointers aren't good
* hash values e.g. if they grow faster in the most significant
* bits */
- const UV hash = PTR_TABLE_HASH(oldv);
+ const UV hash = PTR_TABLE_HASH(oldsv);
bool empty = 1;
assert(tbl);
otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
- if (tblent->oldval == oldv) {
- tblent->newval = newv;
+ if (tblent->oldval == oldsv) {
+ tblent->newval = newsv;
return;
}
}
tblent = S_new_pte(aTHX);
- tblent->oldval = oldv;
- tblent->newval = newv;
+ tblent->oldval = oldsv;
+ tblent->newval = newsv;
tblent->next = *otblent;
*otblent = tblent;
tbl->tbl_items++;
char *PL_watch_pvx;
#endif
-/* attempt to make everything in the typeglob readonly */
-
-STATIC SV *
-S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
-{
- GV *gv = (GV*)sstr;
- SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
-
- if (GvIO(gv) || GvFORM(gv)) {
- GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
- }
- else if (!GvCV(gv)) {
- GvCV(gv) = (CV*)sv;
- }
- else {
- /* CvPADLISTs cannot be shared */
- if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
- GvUNIQUE_off(gv);
- }
- }
-
- if (!GvUNIQUE(gv)) {
-#if 0
- PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
- HvNAME_get(GvSTASH(gv)), GvNAME(gv));
-#endif
- return Nullsv;
- }
-
- /*
- * write attempts will die with
- * "Modification of a read-only value attempted"
- */
- if (!GvSV(gv)) {
- GvSV(gv) = sv;
- }
- else {
- SvREADONLY_on(GvSV(gv));
- }
-
- if (!GvAV(gv)) {
- GvAV(gv) = (AV*)sv;
- }
- else {
- SvREADONLY_on(GvAV(gv));
- }
-
- if (!GvHV(gv)) {
- GvHV(gv) = (HV*)sv;
- }
- else {
- SvREADONLY_on(GvHV(gv));
- }
-
- return sstr; /* he_dup() will SvREFCNT_inc() */
-}
/* duplicate an SV of any type (including AV, HV etc) */
break;
case SVt_PVGV:
if (GvUNIQUE((GV*)sstr)) {
- SV *share;
- if ((share = gv_share(sstr, param))) {
- del_SV(dstr);
- dstr = share;
- ptr_table_store(PL_ptr_table, sstr, dstr);
-#if 0
- PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
- HvNAME_get(GvSTASH(share)), GvNAME(share));
-#endif
- break;
- }
+ /* Do sharing here. */
}
SvANY(dstr) = new_XPVGV();
SvCUR_set(dstr, SvCUR(sstr));
STRLEN i = 0;
XPVHV *dxhv = (XPVHV*)SvANY(dstr);
XPVHV *sxhv = (XPVHV*)SvANY(sstr);
- New(0, dxhv->xhv_array,
+ Newx(dxhv->xhv_array,
PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
while (i <= sxhv->xhv_max) {
HE *source = HvARRAY(sstr)[i];
return ncxs;
/* create anew and remember what it is */
- Newz(56, ncxs, max + 1, PERL_CONTEXT);
+ Newxz(ncxs, max + 1, PERL_CONTEXT);
ptr_table_store(PL_ptr_table, cxs, ncxs);
while (ix >= 0) {
return nsi;
/* create anew and remember what it is */
- Newz(56, nsi, 1, PERL_SI);
+ Newxz(nsi, 1, PERL_SI);
ptr_table_store(PL_ptr_table, si, nsi);
nsi->si_stack = av_dup_inc(si->si_stack, param);
void (*dptr) (void*);
void (*dxptr) (pTHX_ void*);
- Newz(54, nss, max, ANY);
+ Newxz(nss, max, ANY);
while (ix > 0) {
I32 i = POPINT(ss,ix);
PL_xpvhv_root = NULL;
PL_xpvmg_arenaroot = NULL;
PL_xpvmg_root = NULL;
- PL_xpvgv_arenaroot = NULL;
- PL_xpvgv_root = NULL;
PL_xpvlv_arenaroot = NULL;
PL_xpvlv_root = NULL;
PL_xpvbm_arenaroot = NULL;
/* interpreter atexit processing */
PL_exitlistlen = proto_perl->Iexitlistlen;
if (PL_exitlistlen) {
- New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
+ Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
}
else
PL_bitcount = Nullch; /* reinits on demand */
if (proto_perl->Ipsig_pend) {
- Newz(0, PL_psig_pend, SIG_SIZE, int);
+ Newxz(PL_psig_pend, SIG_SIZE, int);
}
else {
PL_psig_pend = (int*)NULL;
}
if (proto_perl->Ipsig_ptr) {
- Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
- Newz(0, PL_psig_name, SIG_SIZE, SV*);
+ Newxz(PL_psig_ptr, SIG_SIZE, SV*);
+ Newxz(PL_psig_name, SIG_SIZE, SV*);
for (i = 1; i < SIG_SIZE; i++) {
PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
PL_tmps_ix = proto_perl->Ttmps_ix;
PL_tmps_max = proto_perl->Ttmps_max;
PL_tmps_floor = proto_perl->Ttmps_floor;
- Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
+ Newxz(PL_tmps_stack, PL_tmps_max, SV*);
i = 0;
while (i <= PL_tmps_ix) {
PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
/* next PUSHMARK() sets *(PL_markstack_ptr+1) */
i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
- Newz(54, PL_markstack, i, I32);
+ Newxz(PL_markstack, i, I32);
PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
- proto_perl->Tmarkstack);
PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
* NOTE: unlike the others! */
PL_scopestack_ix = proto_perl->Tscopestack_ix;
PL_scopestack_max = proto_perl->Tscopestack_max;
- Newz(54, PL_scopestack, PL_scopestack_max, I32);
+ Newxz(PL_scopestack, PL_scopestack_max, I32);
Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
/* next push_return() sets PL_retstack[PL_retstack_ix]
* NOTE: unlike the others! */
PL_savestack_ix = proto_perl->Tsavestack_ix;
PL_savestack_max = proto_perl->Tsavestack_max;
- /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
+ /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
PL_savestack = ss_dup(proto_perl, param);
}
else {
https://perl5.git.perl.org / perl5.git / blobdiff