/* sv.c
*
- * Copyright (c) 1991-1999, Larry Wall
+ * Copyright (c) 1991-2000, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#endif
static void do_clean_all(pTHXo_ SV *sv);
-
-#ifdef PURIFY
-
-#define new_SV(p) \
- STMT_START { \
- LOCK_SV_MUTEX; \
- (p) = (SV*)safemalloc(sizeof(SV)); \
- reg_add(p); \
- UNLOCK_SV_MUTEX; \
- SvANY(p) = 0; \
- SvREFCNT(p) = 1; \
- SvFLAGS(p) = 0; \
- } STMT_END
-
-#define del_SV(p) \
- STMT_START { \
- LOCK_SV_MUTEX; \
- reg_remove(p); \
- Safefree((char*)(p)); \
- UNLOCK_SV_MUTEX; \
- } STMT_END
-
-static SV **registry;
-static I32 registry_size;
-
-#define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size))
-
-#define REG_REPLACE(sv,a,b) \
- STMT_START { \
- void* p = sv->sv_any; \
- I32 h = REGHASH(sv, registry_size); \
- I32 i = h; \
- while (registry[i] != (a)) { \
- if (++i >= registry_size) \
- i = 0; \
- if (i == h) \
- Perl_die(aTHX_ "SV registry bug"); \
- } \
- registry[i] = (b); \
- } STMT_END
-
-#define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv)
-#define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv)
-
-STATIC void
-S_reg_add(pTHX_ SV *sv)
-{
- if (PL_sv_count >= (registry_size >> 1))
- {
- SV **oldreg = registry;
- I32 oldsize = registry_size;
-
- registry_size = registry_size ? ((registry_size << 2) + 1) : 2037;
- Newz(707, registry, registry_size, SV*);
-
- if (oldreg) {
- I32 i;
-
- for (i = 0; i < oldsize; ++i) {
- SV* oldsv = oldreg[i];
- if (oldsv)
- REG_ADD(oldsv);
- }
- Safefree(oldreg);
- }
- }
-
- REG_ADD(sv);
- ++PL_sv_count;
-}
-
-STATIC void
-S_reg_remove(pTHX_ SV *sv)
-{
- REG_REMOVE(sv);
- --PL_sv_count;
-}
-
-STATIC void
-S_visit(pTHX_ SVFUNC_t f)
-{
- I32 i;
-
- for (i = 0; i < registry_size; ++i) {
- SV* sv = registry[i];
- if (sv && SvTYPE(sv) != SVTYPEMASK)
- (*f)(sv);
- }
-}
-
-void
-Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
-{
- if (!(flags & SVf_FAKE))
- Safefree(ptr);
-}
-
-#else /* ! PURIFY */
-
/*
* "A time to plant, and a time to uproot what was planted..."
*/
}
}
-#endif /* PURIFY */
-
void
Perl_sv_report_used(pTHX)
{
xpvbm->xpv_pv = 0;
}
-#ifdef PURIFY
-#define new_XIV() (void*)safemalloc(sizeof(XPVIV))
-#define del_XIV(p) Safefree((char*)p)
+#ifdef LEAKTEST
+# define my_safemalloc(s) (void*)safexmalloc(717,s)
+# define my_safefree(p) safexfree((char*)p)
#else
-#define new_XIV() (void*)new_xiv()
-#define del_XIV(p) del_xiv((XPVIV*) p)
+# define my_safemalloc(s) (void*)safemalloc(s)
+# define my_safefree(p) safefree((char*)p)
#endif
#ifdef PURIFY
-#define new_XNV() (void*)safemalloc(sizeof(XPVNV))
-#define del_XNV(p) Safefree((char*)p)
-#else
-#define new_XNV() (void*)new_xnv()
-#define del_XNV(p) del_xnv((XPVNV*) p)
-#endif
-#ifdef PURIFY
-#define new_XRV() (void*)safemalloc(sizeof(XRV))
-#define del_XRV(p) Safefree((char*)p)
-#else
-#define new_XRV() (void*)new_xrv()
-#define del_XRV(p) del_xrv((XRV*) p)
-#endif
+#define new_XIV() my_safemalloc(sizeof(XPVIV))
+#define del_XIV(p) my_safefree(p)
-#ifdef PURIFY
-#define new_XPV() (void*)safemalloc(sizeof(XPV))
-#define del_XPV(p) Safefree((char*)p)
-#else
-#define new_XPV() (void*)new_xpv()
-#define del_XPV(p) del_xpv((XPV *)p)
-#endif
+#define new_XNV() my_safemalloc(sizeof(XPVNV))
+#define del_XNV(p) my_safefree(p)
-#ifdef PURIFY
-# define my_safemalloc(s) safemalloc(s)
-# define my_safefree(s) safefree(s)
-#else
-STATIC void*
-S_my_safemalloc(MEM_SIZE size)
-{
- char *p;
- New(717, p, size, char);
- return (void*)p;
-}
-# define my_safefree(s) Safefree(s)
-#endif
+#define new_XRV() my_safemalloc(sizeof(XRV))
+#define del_XRV(p) my_safefree(p)
-#ifdef PURIFY
-#define new_XPVIV() (void*)safemalloc(sizeof(XPVIV))
-#define del_XPVIV(p) Safefree((char*)p)
-#else
-#define new_XPVIV() (void*)new_xpviv()
-#define del_XPVIV(p) del_xpviv((XPVIV *)p)
-#endif
-
-#ifdef PURIFY
-#define new_XPVNV() (void*)safemalloc(sizeof(XPVNV))
-#define del_XPVNV(p) Safefree((char*)p)
-#else
-#define new_XPVNV() (void*)new_xpvnv()
-#define del_XPVNV(p) del_xpvnv((XPVNV *)p)
-#endif
+#define new_XPV() my_safemalloc(sizeof(XPV))
+#define del_XPV(p) my_safefree(p)
+#define new_XPVIV() my_safemalloc(sizeof(XPVIV))
+#define del_XPVIV(p) my_safefree(p)
-#ifdef PURIFY
-#define new_XPVCV() (void*)safemalloc(sizeof(XPVCV))
-#define del_XPVCV(p) Safefree((char*)p)
-#else
-#define new_XPVCV() (void*)new_xpvcv()
-#define del_XPVCV(p) del_xpvcv((XPVCV *)p)
-#endif
+#define new_XPVNV() my_safemalloc(sizeof(XPVNV))
+#define del_XPVNV(p) my_safefree(p)
-#ifdef PURIFY
-#define new_XPVAV() (void*)safemalloc(sizeof(XPVAV))
-#define del_XPVAV(p) Safefree((char*)p)
-#else
-#define new_XPVAV() (void*)new_xpvav()
-#define del_XPVAV(p) del_xpvav((XPVAV *)p)
-#endif
+#define new_XPVCV() my_safemalloc(sizeof(XPVCV))
+#define del_XPVCV(p) my_safefree(p)
-#ifdef PURIFY
-#define new_XPVHV() (void*)safemalloc(sizeof(XPVHV))
-#define del_XPVHV(p) Safefree((char*)p)
-#else
-#define new_XPVHV() (void*)new_xpvhv()
-#define del_XPVHV(p) del_xpvhv((XPVHV *)p)
-#endif
-
-#ifdef PURIFY
-#define new_XPVMG() (void*)safemalloc(sizeof(XPVMG))
-#define del_XPVMG(p) Safefree((char*)p)
-#else
-#define new_XPVMG() (void*)new_xpvmg()
-#define del_XPVMG(p) del_xpvmg((XPVMG *)p)
-#endif
-
-#ifdef PURIFY
-#define new_XPVLV() (void*)safemalloc(sizeof(XPVLV))
-#define del_XPVLV(p) Safefree((char*)p)
-#else
-#define new_XPVLV() (void*)new_xpvlv()
-#define del_XPVLV(p) del_xpvlv((XPVLV *)p)
-#endif
-
-#define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
-#define del_XPVGV(p) my_safefree((char*)p)
+#define new_XPVAV() my_safemalloc(sizeof(XPVAV))
+#define del_XPVAV(p) my_safefree(p)
+
+#define new_XPVHV() my_safemalloc(sizeof(XPVHV))
+#define del_XPVHV(p) my_safefree(p)
-#ifdef PURIFY
-#define new_XPVBM() (void*)safemalloc(sizeof(XPVBM))
-#define del_XPVBM(p) Safefree((char*)p)
-#else
-#define new_XPVBM() (void*)new_xpvbm()
-#define del_XPVBM(p) del_xpvbm((XPVBM *)p)
-#endif
+#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
+#define del_XPVMG(p) my_safefree(p)
+
+#define new_XPVLV() my_safemalloc(sizeof(XPVLV))
+#define del_XPVLV(p) my_safefree(p)
+
+#define new_XPVBM() my_safemalloc(sizeof(XPVBM))
+#define del_XPVBM(p) my_safefree(p)
+
+#else /* !PURIFY */
+
+#define new_XIV() (void*)new_xiv()
+#define del_XIV(p) del_xiv((XPVIV*) p)
+
+#define new_XNV() (void*)new_xnv()
+#define del_XNV(p) del_xnv((XPVNV*) p)
+
+#define new_XRV() (void*)new_xrv()
+#define del_XRV(p) del_xrv((XRV*) p)
+
+#define new_XPV() (void*)new_xpv()
+#define del_XPV(p) del_xpv((XPV *)p)
+
+#define new_XPVIV() (void*)new_xpviv()
+#define del_XPVIV(p) del_xpviv((XPVIV *)p)
+
+#define new_XPVNV() (void*)new_xpvnv()
+#define del_XPVNV(p) del_xpvnv((XPVNV *)p)
+
+#define new_XPVCV() (void*)new_xpvcv()
+#define del_XPVCV(p) del_xpvcv((XPVCV *)p)
+
+#define new_XPVAV() (void*)new_xpvav()
+#define del_XPVAV(p) del_xpvav((XPVAV *)p)
+
+#define new_XPVHV() (void*)new_xpvhv()
+#define del_XPVHV(p) del_xpvhv((XPVHV *)p)
-#define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
-#define del_XPVFM(p) my_safefree((char*)p)
+#define new_XPVMG() (void*)new_xpvmg()
+#define del_XPVMG(p) del_xpvmg((XPVMG *)p)
+
+#define new_XPVLV() (void*)new_xpvlv()
+#define del_XPVLV(p) del_xpvlv((XPVLV *)p)
+
+#define new_XPVBM() (void*)new_xpvbm()
+#define del_XPVBM(p) del_xpvbm((XPVBM *)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)
-#define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
-#define del_XPVIO(p) my_safefree((char*)p)
+#define new_XPVIO() my_safemalloc(sizeof(XPVIO))
+#define del_XPVIO(p) my_safefree(p)
+
+/*
+=for apidoc sv_upgrade
+
+Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
+C<svtype>.
+
+=cut
+*/
bool
Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
return 0;
}
+/*
+=for apidoc sv_grow
+
+Expands the character buffer in the SV. This will use C<sv_unref> and will
+upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
+Use C<SvGROW>.
+
+=cut
+*/
+
char *
Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
{
s = SvPVX(sv);
if (newlen > SvLEN(sv)) { /* need more room? */
if (SvLEN(sv) && s) {
-#if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
+#if defined(MYMALLOC) && !defined(LEAKTEST)
STRLEN l = malloced_size((void*)SvPVX(sv));
if (newlen <= l) {
SvLEN_set(sv, l);
return s;
}
+/*
+=for apidoc sv_setiv
+
+Copies an integer into the given SV. Does not handle 'set' magic. See
+C<sv_setiv_mg>.
+
+=cut
+*/
+
void
Perl_sv_setiv(pTHX_ register SV *sv, IV i)
{
SvTAINT(sv);
}
+/*
+=for apidoc sv_setiv_mg
+
+Like C<sv_setiv>, but also handles 'set' magic.
+
+=cut
+*/
+
void
Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
{
SvSETMAGIC(sv);
}
+/*
+=for apidoc sv_setuv
+
+Copies an unsigned integer into the given SV. Does not handle 'set' magic.
+See C<sv_setuv_mg>.
+
+=cut
+*/
+
void
Perl_sv_setuv(pTHX_ register SV *sv, UV u)
{
SvUVX(sv) = u;
}
+/*
+=for apidoc sv_setuv_mg
+
+Like C<sv_setuv>, but also handles 'set' magic.
+
+=cut
+*/
+
void
Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
{
SvSETMAGIC(sv);
}
+/*
+=for apidoc sv_setnv
+
+Copies a double into the given SV. Does not handle 'set' magic. See
+C<sv_setnv_mg>.
+
+=cut
+*/
+
void
Perl_sv_setnv(pTHX_ register SV *sv, NV num)
{
SvTAINT(sv);
}
+/*
+=for apidoc sv_setnv_mg
+
+Like C<sv_setnv>, but also handles 'set' magic.
+
+=cut
+*/
+
void
Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
{
* with a possible addition of IS_NUMBER_NEG.
*/
+/*
+=for apidoc looks_like_number
+
+Test if an the content of an SV looks like a number (or is a
+number).
+
+=cut
+*/
+
I32
Perl_looks_like_number(pTHX_ SV *sv)
{
* as temporary.
*/
+/*
+=for apidoc sv_setsv
+
+Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
+The source SV may be destroyed if it is mortal. Does not handle 'set'
+magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
+C<sv_setsv_mg>.
+
+=cut
+*/
+
void
Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
{
*SvEND(dstr) = '\0';
(void)SvPOK_only(dstr);
}
- if (SvUTF8(sstr))
+ if (DO_UTF8(sstr))
SvUTF8_on(dstr);
/*SUPPRESS 560*/
if (sflags & SVp_NOK) {
SvTAINT(dstr);
}
+/*
+=for apidoc sv_setsv_mg
+
+Like C<sv_setsv>, but also handles 'set' magic.
+
+=cut
+*/
+
void
Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
{
SvSETMAGIC(dstr);
}
+/*
+=for apidoc sv_setpvn
+
+Copies a string into an SV. The C<len> parameter indicates the number of
+bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
+
+=cut
+*/
+
void
Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
SvTAINT(sv);
}
+/*
+=for apidoc sv_setpvn_mg
+
+Like C<sv_setpvn>, but also handles 'set' magic.
+
+=cut
+*/
+
void
Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
SvSETMAGIC(sv);
}
+/*
+=for apidoc sv_setpv
+
+Copies a string into an SV. The string must be null-terminated. Does not
+handle 'set' magic. See C<sv_setpv_mg>.
+
+=cut
+*/
+
void
Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
{
SvTAINT(sv);
}
+/*
+=for apidoc sv_setpv_mg
+
+Like C<sv_setpv>, but also handles 'set' magic.
+
+=cut
+*/
+
void
Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
{
SvSETMAGIC(sv);
}
+/*
+=for apidoc sv_usepvn
+
+Tells an SV to use C<ptr> to find its string value. Normally the string is
+stored inside the SV but sv_usepvn allows the SV to use an outside string.
+The C<ptr> should point to memory that was allocated by C<malloc>. The
+string length, C<len>, must be supplied. This function will realloc the
+memory pointed to by C<ptr>, so that pointer should not be freed or used by
+the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
+See C<sv_usepvn_mg>.
+
+=cut
+*/
+
void
Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
{
SvTAINT(sv);
}
+/*
+=for apidoc sv_usepvn_mg
+
+Like C<sv_usepvn>, but also handles 'set' magic.
+
+=cut
+*/
+
void
Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
{
sv_unglob(sv);
}
+/*
+=for apidoc sv_chop
+
+Efficient removal of characters from the beginning of the string buffer.
+SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
+the string buffer. The C<ptr> becomes the first character of the adjusted
+string.
+
+=cut
+*/
+
void
Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
SvIVX(sv) += delta;
}
+/*
+=for apidoc sv_catpvn
+
+Concatenates the string onto the end of the string which is in the SV. The
+C<len> indicates number of bytes to copy. Handles 'get' magic, but not
+'set' magic. See C<sv_catpvn_mg>.
+
+=cut
+*/
+
void
Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
Move(ptr,SvPVX(sv)+tlen,len,char);
SvCUR(sv) += len;
*SvEND(sv) = '\0';
- (void)SvPOK_only(sv); /* validate pointer */
+ (void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
}
+/*
+=for apidoc sv_catpvn_mg
+
+Like C<sv_catpvn>, but also handles 'set' magic.
+
+=cut
+*/
+
void
Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
SvSETMAGIC(sv);
}
+/*
+=for apidoc sv_catsv
+
+Concatenates the string from SV C<ssv> onto the end of the string in SV
+C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
+
+=cut
+*/
+
void
Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
{
return;
if (s = SvPV(sstr, len))
sv_catpvn(dstr,s,len);
+ if (SvUTF8(sstr))
+ SvUTF8_on(dstr);
}
+/*
+=for apidoc sv_catsv_mg
+
+Like C<sv_catsv>, but also handles 'set' magic.
+
+=cut
+*/
+
void
Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
{
SvSETMAGIC(dstr);
}
+/*
+=for apidoc sv_catpv
+
+Concatenates the string onto the end of the string which is in the SV.
+Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
+
+=cut
+*/
+
void
Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
{
ptr = SvPVX(sv);
Move(ptr,SvPVX(sv)+tlen,len+1,char);
SvCUR(sv) += len;
- (void)SvPOK_only(sv); /* validate pointer */
+ (void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
}
+/*
+=for apidoc sv_catpv_mg
+
+Like C<sv_catpv>, but also handles 'set' magic.
+
+=cut
+*/
+
void
Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
{
/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
+/*
+=for apidoc sv_magic
+
+Adds magic to an SV.
+
+=cut
+*/
+
void
Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
{
}
}
+/*
+=for apidoc sv_insert
+
+Inserts a string at the specified offset/length within the SV. Similar to
+the Perl substr() function.
+
+=cut
+*/
+
void
Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
{
del_SV(sv);
}
+/*
+=for apidoc sv_len
+
+Returns the length of the string in the SV. See also C<SvCUR>.
+
+=cut
+*/
+
STRLEN
Perl_sv_len(pTHX_ register SV *sv)
{
return;
}
+/*
+=for apidoc sv_eq
+
+Returns a boolean indicating whether the strings in the two SVs are
+identical.
+
+=cut
+*/
+
I32
Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
{
return memEQ(pv1, pv2, cur1);
}
+/*
+=for apidoc sv_cmp
+
+Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
+string in C<sv1> is less than, equal to, or greater than the string in
+C<sv2>.
+
+=cut
+*/
+
I32
Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
{
}
+/*
+=for apidoc sv_inc
+
+Auto-increment of the value in the SV.
+
+=cut
+*/
+
void
Perl_sv_inc(pTHX_ register SV *sv)
{
*d = d[1];
}
+/*
+=for apidoc sv_dec
+
+Auto-decrement of the value in the SV.
+
+=cut
+*/
+
void
Perl_sv_dec(pTHX_ register SV *sv)
{
sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
}
+/*
+=for apidoc sv_mortalcopy
+
+Creates a new SV which is a copy of the original SV. The new SV is marked
+as mortal.
+
+=cut
+*/
+
/* Make a string that will exist for the duration of the expression
* evaluation. Actually, it may have to last longer than that, but
* hopefully we won't free it until it has been assigned to a
return sv;
}
+/*
+=for apidoc sv_newmortal
+
+Creates a new SV which is mortal. The reference count of the SV is set to 1.
+
+=cut
+*/
+
SV *
Perl_sv_newmortal(pTHX)
{
return sv;
}
+/*
+=for apidoc sv_2mortal
+
+Marks an SV as mortal. The SV will be destroyed when the current context
+ends.
+
+=cut
+*/
+
/* same thing without the copying */
SV *
return sv;
}
+/*
+=for apidoc newSVpv
+
+Creates a new SV and copies a string into it. The reference count for the
+SV is set to 1. If C<len> is zero, Perl will compute the length using
+strlen(). For efficiency, consider using C<newSVpvn> instead.
+
+=cut
+*/
+
SV *
Perl_newSVpv(pTHX_ const char *s, STRLEN len)
{
return sv;
}
+/*
+=for apidoc newSVpvn
+
+Creates a new SV and copies a string into it. The reference count for the
+SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
+string. You are responsible for ensuring that the source string is at least
+C<len> bytes long.
+
+=cut
+*/
+
SV *
Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
{
}
#endif
+/*
+=for apidoc newSVpvf
+
+Creates a new SV an initialize it with the string formatted like
+C<sprintf>.
+
+=cut
+*/
+
SV *
Perl_newSVpvf(pTHX_ const char* pat, ...)
{
return sv;
}
+/*
+=for apidoc newSVnv
+
+Creates a new SV and copies a floating point value into it.
+The reference count for the SV is set to 1.
+
+=cut
+*/
+
SV *
Perl_newSVnv(pTHX_ NV n)
{
return sv;
}
+/*
+=for apidoc newSViv
+
+Creates a new SV and copies an integer into it. The reference count for the
+SV is set to 1.
+
+=cut
+*/
+
SV *
Perl_newSViv(pTHX_ IV i)
{
return sv;
}
+/*
+=for apidoc newRV_noinc
+
+Creates an RV wrapper for an SV. The reference count for the original
+SV is B<not> incremented.
+
+=cut
+*/
+
SV *
Perl_newRV_noinc(pTHX_ SV *tmpRef)
{
return sv;
}
+/* newRV_inc is #defined to newRV in sv.h */
SV *
Perl_newRV(pTHX_ SV *tmpRef)
{
return newRV_noinc(SvREFCNT_inc(tmpRef));
}
+/*
+=for apidoc newSVsv
+
+Creates a new SV which is an exact duplicate of the original SV.
+
+=cut
+*/
+
/* make an exact duplicate of old */
SV *
}
}
+/*
+=for apidoc sv_isobject
+
+Returns a boolean indicating whether the SV is an RV pointing to a blessed
+object. If the SV is not an RV, or if the object is not blessed, then this
+will return false.
+
+=cut
+*/
+
int
Perl_sv_isobject(pTHX_ SV *sv)
{
return 1;
}
+/*
+=for apidoc sv_isa
+
+Returns a boolean indicating whether the SV is blessed into the specified
+class. This does not check for subtypes; use C<sv_derived_from> to verify
+an inheritance relationship.
+
+=cut
+*/
+
int
Perl_sv_isa(pTHX_ SV *sv, const char *name)
{
return strEQ(HvNAME(SvSTASH(sv)), name);
}
+/*
+=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.
+
+=cut
+*/
+
SV*
Perl_newSVrv(pTHX_ SV *rv, const char *classname)
{
return sv;
}
+/*
+=for apidoc sv_setref_pv
+
+Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
+argument will be upgraded to an RV. That RV will be modified to point to
+the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
+into the SV. The C<classname> argument indicates the package for the
+blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
+will be returned and will have a reference count of 1.
+
+Do not use with other Perl types such as HV, AV, SV, CV, because those
+objects will become corrupted by the pointer copy process.
+
+Note that C<sv_setref_pvn> copies the string while this copies the pointer.
+
+=cut
+*/
+
SV*
Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
{
return rv;
}
+/*
+=for apidoc sv_setref_iv
+
+Copies an integer into a new SV, optionally blessing the SV. The C<rv>
+argument will be upgraded to an RV. That RV will be modified to point to
+the new SV. The C<classname> argument indicates the package for the
+blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
+will be returned and will have a reference count of 1.
+
+=cut
+*/
+
SV*
Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
{
return rv;
}
+/*
+=for apidoc sv_setref_nv
+
+Copies a double into a new SV, optionally blessing the SV. The C<rv>
+argument will be upgraded to an RV. That RV will be modified to point to
+the new SV. The C<classname> argument indicates the package for the
+blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
+will be returned and will have a reference count of 1.
+
+=cut
+*/
+
SV*
Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
{
return rv;
}
+/*
+=for apidoc sv_setref_pvn
+
+Copies a string into a new SV, optionally blessing the SV. The length of the
+string must be specified with C<n>. The C<rv> argument will be upgraded to
+an RV. That RV will be modified to point to the new SV. The C<classname>
+argument indicates the package for the blessing. Set C<classname> to
+C<Nullch> to avoid the blessing. The new SV will be returned and will have
+a reference count of 1.
+
+Note that C<sv_setref_pv> copies the pointer while this copies the string.
+
+=cut
+*/
+
SV*
Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
{
return rv;
}
+/*
+=for apidoc sv_bless
+
+Blesses an SV into a specified package. The SV must be an RV. The package
+must be designated by its stash (see C<gv_stashpv()>). The reference count
+of the SV is unaffected.
+
+=cut
+*/
+
SV*
Perl_sv_bless(pTHX_ SV *sv, HV *stash)
{
STATIC void
S_sv_unglob(pTHX_ SV *sv)
{
+ void *xpvmg;
+
assert(SvTYPE(sv) == SVt_PVGV);
SvFAKE_off(sv);
if (GvGP(sv))
sv_unmagic(sv, '*');
Safefree(GvNAME(sv));
GvMULTI_off(sv);
+
+ /* need to keep SvANY(sv) in the right arena */
+ xpvmg = new_XPVMG();
+ StructCopy(SvANY(sv), xpvmg, XPVMG);
+ del_XPVGV(SvANY(sv));
+ SvANY(sv) = xpvmg;
+
SvFLAGS(sv) &= ~SVTYPEMASK;
SvFLAGS(sv) |= SVt_PVMG;
}
+/*
+=for apidoc sv_unref
+
+Unsets the RV status of the SV, and decrements the reference count of
+whatever was being referenced by the RV. This can almost be thought of
+as a reversal of C<newSVrv>. See C<SvROK_off>.
+
+=cut
+*/
+
void
Perl_sv_unref(pTHX_ SV *sv)
{
return FALSE;
}
+/*
+=for apidoc sv_setpviv
+
+Copies an integer into the given SV, also updating its string value.
+Does not handle 'set' magic. See C<sv_setpviv_mg>.
+
+=cut
+*/
+
void
Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
{
}
+/*
+=for apidoc sv_setpviv_mg
+
+Like C<sv_setpviv>, but also handles 'set' magic.
+
+=cut
+*/
+
void
Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
{
}
#endif
+/*
+=for apidoc sv_setpvf
+
+Processes its arguments like C<sprintf> and sets an SV to the formatted
+output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
+
+=cut
+*/
+
void
Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
{
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
}
+/*
+=for apidoc sv_setpvf_mg
+
+Like C<sv_setpvf>, but also handles 'set' magic.
+
+=cut
+*/
+
void
Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
{
}
#endif
+/*
+=for apidoc sv_catpvf
+
+Processes its arguments like C<sprintf> and appends the formatted output
+to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
+typically be called after calling this function to handle 'set' magic.
+
+=cut
+*/
+
void
Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
{
sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
}
+/*
+=for apidoc sv_catpvf_mg
+
+Like C<sv_catpvf>, but also handles 'set' magic.
+
+=cut
+*/
+
void
Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
{
SvSETMAGIC(sv);
}
+/*
+=for apidoc sv_vsetpvfn
+
+Works like C<vcatpvfn> but copies the text into the SV instead of
+appending it.
+
+=cut
+*/
+
void
Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
{
sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
}
+/*
+=for apidoc sv_vcatpvfn
+
+Processes its arguments like C<vsprintf> and appends the formatted output
+to an SV. Uses an array of SVs if the C style variable argument list is
+missing (NULL). When running with taint checks enabled, indicates via
+C<maybe_tainted> if results are untrustworthy (often due to the use of
+locales).
+
+=cut
+*/
+
void
Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
{
STRLEN origlen;
I32 svix = 0;
static char nullstr[] = "(null)";
+ SV *argsv;
/* no matter what, this is a string now */
(void)SvPV_force(sv, origlen);
char *s = va_arg(*args, char*);
sv_catpv(sv, s ? s : nullstr);
}
- else if (svix < svmax)
+ else if (svix < svmax) {
sv_catsv(sv, *svargs);
+ if (DO_UTF8(*svargs))
+ SvUTF8_on(sv);
+ }
return;
case '_':
if (args) {
- sv_catsv(sv, va_arg(*args, SV*));
+ argsv = va_arg(*args, SV*);
+ sv_catsv(sv, argsv);
+ if (DO_UTF8(argsv))
+ SvUTF8_on(sv);
return;
}
/* See comment on '_' below */
STRLEN zeros = 0;
bool has_precis = FALSE;
STRLEN precis = 0;
+ bool is_utf = FALSE;
char esignbuf[4];
U8 utf8buf[10];
goto string;
case 'c':
- if (IN_UTF8) {
- if (args)
- uv = va_arg(*args, int);
- else
- uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
-
+ if (args)
+ uv = va_arg(*args, int);
+ else
+ uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+ if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
eptr = (char*)utf8buf;
elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
- goto string;
+ is_utf = TRUE;
+ }
+ else {
+ c = (char)uv;
+ eptr = &c;
+ elen = 1;
}
- if (args)
- c = va_arg(*args, int);
- else
- c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
- eptr = &c;
- elen = 1;
goto string;
case 's':
}
}
else if (svix < svmax) {
- eptr = SvPVx(svargs[svix++], elen);
- if (IN_UTF8) {
+ argsv = svargs[svix++];
+ eptr = SvPVx(argsv, elen);
+ if (DO_UTF8(argsv)) {
if (has_precis && precis < elen) {
I32 p = precis;
- sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
+ sv_pos_u2b(argsv, &p, 0); /* sticks at end */
precis = p;
}
if (width) { /* fudge width (can't fudge elen) */
- width += elen - sv_len_utf8(svargs[svix - 1]);
+ width += elen - sv_len_utf8(argsv);
}
+ is_utf = TRUE;
}
}
goto string;
+ case 'v':
+ if (args)
+ argsv = va_arg(*args, SV*);
+ else if (svix < svmax)
+ argsv = svargs[svix++];
+ {
+ STRLEN len;
+ U8 *str = (U8*)SvPVx(argsv,len);
+ I32 vlen = len*3+1;
+ SV *vsv = NEWSV(73,vlen);
+ I32 ulen;
+ I32 vfree = vlen;
+ U8 *vptr = (U8*)SvPVX(vsv);
+ STRLEN vcur = 0;
+ bool utf = DO_UTF8(argsv);
+
+ if (utf)
+ is_utf = TRUE;
+ while (len) {
+ UV uv;
+
+ if (utf)
+ uv = utf8_to_uv(str, &ulen);
+ else {
+ uv = *str;
+ ulen = 1;
+ }
+ str += ulen;
+ len -= ulen;
+ eptr = ebuf + sizeof ebuf;
+ do {
+ *--eptr = '0' + uv % 10;
+ } while (uv /= 10);
+ elen = (ebuf + sizeof ebuf) - eptr;
+ while (elen >= vfree-1) {
+ STRLEN off = vptr - (U8*)SvPVX(vsv);
+ vfree += vlen;
+ vlen *= 2;
+ SvGROW(vsv, vlen);
+ vptr = (U8*)SvPVX(vsv) + off;
+ }
+ memcpy(vptr, eptr, elen);
+ vptr += elen;
+ *vptr++ = '.';
+ vfree -= elen + 1;
+ vcur += elen + 1;
+ }
+ if (vcur) {
+ vcur--;
+ vptr[-1] = '\0';
+ }
+ SvCUR_set(vsv,vcur);
+ eptr = SvPVX(vsv);
+ elen = vcur;
+ }
+ goto string;
+
case '_':
/*
* The "%_" hack might have to be changed someday,
*/
if (!args)
goto unknown;
- eptr = SvPVx(va_arg(*args, SV*), elen);
+ argsv = va_arg(*args,SV*);
+ eptr = SvPVx(argsv, elen);
+ if (DO_UTF8(argsv))
+ is_utf = TRUE;
string:
if (has_precis && elen > precis)
memset(p, ' ', gap);
p += gap;
}
+ if (is_utf)
+ SvUTF8_on(sv);
*p = '\0';
SvCUR(sv) = p - SvPVX(sv);
}
Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
{
PTR_TBL_ENT_t *tblent;
- UV hash = (UV)sv;
+ UV hash = PTR2UV(sv);
assert(tbl);
tblent = tbl->tbl_ary[hash & tbl->tbl_max];
for (; tblent; tblent = tblent->next) {
/* 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 */
- UV hash = (UV)oldv;
+ UV hash = PTR2UV(oldv);
bool i = 1;
assert(tbl);
continue;
curentp = ary + oldsize;
for (entp = ary, ent = *ary; ent; ent = *entp) {
- if ((newsize & (UV)ent->oldval) != i) {
+ if ((newsize & PTR2UV(ent->oldval)) != i) {
*entp = ent->next;
ent->next = *curentp;
*curentp = ent;
case CXt_EVAL:
ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
- ncx->blk_eval.old_name = SAVEPV(cx->blk_eval.old_name);
+ ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
break;
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
break;
+ case SAVEt_COMPPAD:
+ av = (AV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = av_dup(av);
+ break;
default:
Perl_croak(aTHX_ "panic: ss_dup inconsistency");
}
PL_beginav = av_dup_inc(proto_perl->Ibeginav);
PL_endav = av_dup_inc(proto_perl->Iendav);
- PL_stopav = av_dup_inc(proto_perl->Istopav);
+ PL_checkav = av_dup_inc(proto_perl->Icheckav);
PL_initav = av_dup_inc(proto_perl->Iinitav);
PL_sub_generation = proto_perl->Isub_generation;
projects / p5sagit/p5-mst-13.2.git / blobdiff