/* sv.c
*
- * Copyright (c) 1991-2000, Larry Wall
+ * Copyright (c) 1991-2001, 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.
*
- */
-
-/*
* "I wonder what the Entish is for 'yes' and 'no'," he thought.
+ *
+ *
+ * Manipulation of scalar values (SVs). This file contains the code that
+ * creates, manipulates and destroys SVs. (Opcode-level functions on SVs
+ * can be found in the various pp*.c files.) Note that the basic structure
+ * of an SV is also used to hold the other major Perl data types - AVs,
+ * HVs, GVs, IO etc. Low-level functions on these other types - such as
+ * memory allocation and destruction - are handled within this file, while
+ * higher-level stuff can be found in the individual files av.c, hv.c,
+ * etc.
*/
#include "EXTERN.h"
#define FCALL *f
#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
-static void do_report_used(pTHXo_ SV *sv);
-static void do_clean_objs(pTHXo_ SV *sv);
-#ifndef DISABLE_DESTRUCTOR_KLUDGE
-static void do_clean_named_objs(pTHXo_ SV *sv);
-#endif
-static void do_clean_all(pTHXo_ SV *sv);
+
+/* ============================================================================
+
+=head1 Allocation and deallocation of SVs.
+
+An SV (or AV, HV etc) is in 2 parts: the head and the body. There is only
+one type of head, but around 13 body types. Head and body are each
+separately allocated. Normally, this allocation is done using arenas,
+which are approximately 1K chunks of memory parcelled up into N heads or
+bodies. The first slot in each arena is reserved, and is used to hold a
+link to the next arena. In the case of heads, the unused first slot
+also contains some flags and a note of the number of slots. Snaked through
+each arena chain is a linked list of free items; when this becomes empty,
+an extra arena is allocated and divided up into N items which are threaded
+into the free list.
+
+The following global variables are associated with arenas:
+
+ PL_sv_arenaroot pointer to list of SV arenas
+ PL_sv_root pointer to list of free SV structures
+
+ PL_foo_arenaroot pointer to list of foo arenas,
+ PL_foo_root pointer to list of free foo bodies
+ ... for foo in xiv, xnv, xrv, xpv etc.
+
+Note that some of the larger and more rarely used body types (eg xpvio)
+are not allocated using arenas, but are instead just malloc()/free()ed as
+required. Also, if PURIFY is defined, arenas are abandoned altogether,
+with all items individually malloc()ed. In addition, a few SV heads are
+not allocated from an arena, but are instead directly created as static
+or auto variables, eg PL_sv_undef.
+
+The SV arena serves the secondary purpose of allowing still-live SVs
+to be located and destroyed during final cleanup.
+
+At the lowest level, the macros new_SV() and del_SV() grab and free
+an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
+to return the SV to the free list with error checking.) new_SV() calls
+more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
+SVs in the free list have their SvTYPE field set to all ones.
+
+Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
+that allocate and return individual body types. Normally these are mapped
+to the arena-maniplulating functions new_xiv()/del_xiv() etc, but may be
+instead mapped directly to malloc()/free() if PURIFY is in effect. The
+new/del functions remove from, or add to, the appropriate PL_foo_root
+list, and call more_xiv() etc to add a new arena if the list is empty.
+
+It the time of very final cleanup, sv_free_arenas() is called from
+perl_destruct() to physically free all the arenas allocated since the
+start of the interpreter. Note that this also clears PL_he_arenaroot,
+which is otherwise dealt with in hv.c.
+
+Manipulation of any of the PL_*root pointers is protected by enclosing
+LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
+if threads are enabled.
+
+The function visit() scans the SV arenas list, and calls a specified
+function for each SV it finds which is still live - ie which has an SvTYPE
+other than all 1's, and a non-zero SvREFCNT. visit() is used by the
+following functions (specified as [function that calls visit()] / [function
+called by visit() for each SV]):
+
+ sv_report_used() / do_report_used()
+ dump all remaining SVs (debugging aid)
+
+ sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
+ Attempt to free all objects pointed to by RVs,
+ and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
+ try to do the same for all objects indirectly
+ referenced by typeglobs too. Called once from
+ perl_destruct(), prior to calling sv_clean_all()
+ below.
+
+ sv_clean_all() / do_clean_all()
+ SvREFCNT_dec(sv) each remaining SV, possibly
+ triggering an sv_free(). It also sets the
+ SVf_BREAK flag on the SV to indicate that the
+ refcnt has been artificially lowered, and thus
+ stopping sv_free() from giving spurious warnings
+ about SVs which unexpectedly have a refcnt
+ of zero. called repeatedly from perl_destruct()
+ until there are no SVs left.
+
+=head2 Summary
+
+Private API to rest of sv.c
+
+ new_SV(), del_SV(),
+
+ new_XIV(), del_XIV(),
+ new_XNV(), del_XNV(),
+ etc
+
+Public API:
+
+ sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
+
+
+=cut
+
+============================================================================ */
+
+
/*
* "A time to plant, and a time to uproot what was planted..."
++PL_sv_count; \
} STMT_END
+
+/* new_SV(): return a new, empty SV head */
+
#define new_SV(p) \
STMT_START { \
LOCK_SV_MUTEX; \
SvFLAGS(p) = 0; \
} STMT_END
+
+/* del_SV(): return an empty SV head to the free list */
+
#ifdef DEBUGGING
#define del_SV(p) \
STMT_START { \
LOCK_SV_MUTEX; \
- if (PL_debug & 32768) \
+ if (DEBUG_D_TEST) \
del_sv(p); \
else \
plant_SV(p); \
STATIC void
S_del_sv(pTHX_ SV *p)
{
- if (PL_debug & 32768) {
+ if (DEBUG_D_TEST) {
SV* sva;
SV* sv;
SV* svend;
#endif /* DEBUGGING */
+
+/*
+=for apidoc sv_add_arena
+
+Given a chunk of memory, link it to the head of the list of arenas,
+and split it into a list of free SVs.
+
+=cut
+*/
+
void
Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
{
SvFLAGS(sv) = SVTYPEMASK;
}
+/* make some more SVs by adding another arena */
+
/* sv_mutex must be held while calling more_sv() */
STATIC SV*
S_more_sv(pTHX)
if (PL_nice_chunk) {
sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
PL_nice_chunk = Nullch;
+ PL_nice_chunk_size = 0;
}
else {
char *chunk; /* must use New here to match call to */
return sv;
}
-STATIC void
+/* visit(): call the named function for each non-free in SV the arenas. */
+
+STATIC I32
S_visit(pTHX_ SVFUNC_t f)
{
SV* sva;
SV* sv;
register SV* svend;
+ I32 visited = 0;
for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
svend = &sva[SvREFCNT(sva)];
for (sv = sva + 1; sv < svend; ++sv) {
- if (SvTYPE(sv) != SVTYPEMASK)
+ if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) {
(FCALL)(aTHXo_ sv);
+ ++visited;
+ }
}
}
+ return visited;
+}
+
+/* called by sv_report_used() for each live SV */
+
+static void
+do_report_used(pTHXo_ SV *sv)
+{
+ if (SvTYPE(sv) != SVTYPEMASK) {
+ PerlIO_printf(Perl_debug_log, "****\n");
+ sv_dump(sv);
+ }
}
+/*
+=for apidoc sv_report_used
+
+Dump the contents of all SVs not yet freed. (Debugging aid).
+
+=cut
+*/
+
void
Perl_sv_report_used(pTHX)
{
visit(do_report_used);
}
+/* called by sv_clean_objs() for each live SV */
+
+static void
+do_clean_objs(pTHXo_ SV *sv)
+{
+ SV* rv;
+
+ if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
+ if (SvWEAKREF(sv)) {
+ sv_del_backref(sv);
+ SvWEAKREF_off(sv);
+ SvRV(sv) = 0;
+ } else {
+ SvROK_off(sv);
+ SvRV(sv) = 0;
+ SvREFCNT_dec(rv);
+ }
+ }
+
+ /* XXX Might want to check arrays, etc. */
+}
+
+/* called by sv_clean_objs() for each live SV */
+
+#ifndef DISABLE_DESTRUCTOR_KLUDGE
+static void
+do_clean_named_objs(pTHXo_ SV *sv)
+{
+ if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
+ if ( SvOBJECT(GvSV(sv)) ||
+ (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
+ (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
+ (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
+ (GvCV(sv) && SvOBJECT(GvCV(sv))) )
+ {
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
+ SvREFCNT_dec(sv);
+ }
+ }
+}
+#endif
+
+/*
+=for apidoc sv_clean_objs
+
+Attempt to destroy all objects not yet freed
+
+=cut
+*/
+
void
Perl_sv_clean_objs(pTHX)
{
PL_in_clean_objs = FALSE;
}
-void
+/* called by sv_clean_all() for each live SV */
+
+static void
+do_clean_all(pTHXo_ SV *sv)
+{
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
+ SvFLAGS(sv) |= SVf_BREAK;
+ SvREFCNT_dec(sv);
+}
+
+/*
+=for apidoc sv_clean_all
+
+Decrement the refcnt of each remaining SV, possibly triggering a
+cleanup. This function may have to be called multiple times to free
+SVs which are in complex self-referential heirarchies.
+
+=cut
+*/
+
+I32
Perl_sv_clean_all(pTHX)
{
+ I32 cleaned;
PL_in_clean_all = TRUE;
- visit(do_clean_all);
+ cleaned = visit(do_clean_all);
PL_in_clean_all = FALSE;
+ return cleaned;
}
+/*
+=for apidoc sv_free_arenas
+
+Deallocate the memory used by all arenas. Note that all the individual SV
+heads and bodies within the arenas must already have been freed.
+
+=cut
+*/
+
void
Perl_sv_free_arenas(pTHX)
{
PL_sv_root = 0;
}
+/*
+=for apidoc report_uninit
+
+Print appropriate "Use of uninitialized variable" warning
+
+=cut
+*/
+
void
Perl_report_uninit(pTHX)
{
Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
}
+/* grab a new IV body from the free list, allocating more if necessary */
+
STATIC XPVIV*
S_new_xiv(pTHX)
{
return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
}
+/* return an IV body to the free list */
+
STATIC void
S_del_xiv(pTHX_ XPVIV *p)
{
UNLOCK_SV_MUTEX;
}
+/* allocate another arena's worth of IV bodies */
+
STATIC void
S_more_xiv(pTHX)
{
register IV* xivend;
XPV* ptr;
New(705, ptr, 1008/sizeof(XPV), XPV);
- ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
+ ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
PL_xiv_arenaroot = ptr; /* to keep Purify happy */
xiv = (IV*) ptr;
xivend = &xiv[1008 / sizeof(IV) - 1];
- xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
+ xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
PL_xiv_root = xiv;
while (xiv < xivend) {
*(IV**)xiv = (IV *)(xiv + 1);
*(IV**)xiv = 0;
}
+/* grab a new NV body from the free list, allocating more if necessary */
+
STATIC XPVNV*
S_new_xnv(pTHX)
{
return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
}
+/* return an NV body to the free list */
+
STATIC void
S_del_xnv(pTHX_ XPVNV *p)
{
UNLOCK_SV_MUTEX;
}
+/* allocate another arena's worth of NV bodies */
+
STATIC void
S_more_xnv(pTHX)
{
*(NV**)xnv = 0;
}
+/* grab a new struct xrv from the free list, allocating more if necessary */
+
STATIC XRV*
S_new_xrv(pTHX)
{
return xrv;
}
+/* return a struct xrv to the free list */
+
STATIC void
S_del_xrv(pTHX_ XRV *p)
{
UNLOCK_SV_MUTEX;
}
+/* allocate another arena's worth of struct xrv */
+
STATIC void
S_more_xrv(pTHX)
{
xrv->xrv_rv = 0;
}
+/* grab a new struct xpv from the free list, allocating more if necessary */
+
STATIC XPV*
S_new_xpv(pTHX)
{
return xpv;
}
+/* return a struct xpv to the free list */
+
STATIC void
S_del_xpv(pTHX_ XPV *p)
{
UNLOCK_SV_MUTEX;
}
+/* allocate another arena's worth of struct xpv */
+
STATIC void
S_more_xpv(pTHX)
{
xpv->xpv_pv = 0;
}
+/* grab a new struct xpviv from the free list, allocating more if necessary */
+
STATIC XPVIV*
S_new_xpviv(pTHX)
{
return xpviv;
}
+/* return a struct xpviv to the free list */
+
STATIC void
S_del_xpviv(pTHX_ XPVIV *p)
{
UNLOCK_SV_MUTEX;
}
+/* allocate another arena's worth of struct xpviv */
+
STATIC void
S_more_xpviv(pTHX)
{
xpviv->xpv_pv = 0;
}
+/* grab a new struct xpvnv from the free list, allocating more if necessary */
+
STATIC XPVNV*
S_new_xpvnv(pTHX)
{
return xpvnv;
}
+/* return a struct xpvnv to the free list */
+
STATIC void
S_del_xpvnv(pTHX_ XPVNV *p)
{
UNLOCK_SV_MUTEX;
}
+/* allocate another arena's worth of struct xpvnv */
+
STATIC void
S_more_xpvnv(pTHX)
{
xpvnv->xpv_pv = 0;
}
+/* grab a new struct xpvcv from the free list, allocating more if necessary */
+
STATIC XPVCV*
S_new_xpvcv(pTHX)
{
return xpvcv;
}
+/* return a struct xpvcv to the free list */
+
STATIC void
S_del_xpvcv(pTHX_ XPVCV *p)
{
UNLOCK_SV_MUTEX;
}
+/* allocate another arena's worth of struct xpvcv */
+
STATIC void
S_more_xpvcv(pTHX)
{
xpvcv->xpv_pv = 0;
}
+/* grab a new struct xpvav from the free list, allocating more if necessary */
+
STATIC XPVAV*
S_new_xpvav(pTHX)
{
return xpvav;
}
+/* return a struct xpvav to the free list */
+
STATIC void
S_del_xpvav(pTHX_ XPVAV *p)
{
UNLOCK_SV_MUTEX;
}
+/* allocate another arena's worth of struct xpvav */
+
STATIC void
S_more_xpvav(pTHX)
{
xpvav->xav_array = 0;
}
+/* grab a new struct xpvhv from the free list, allocating more if necessary */
+
STATIC XPVHV*
S_new_xpvhv(pTHX)
{
return xpvhv;
}
+/* return a struct xpvhv to the free list */
+
STATIC void
S_del_xpvhv(pTHX_ XPVHV *p)
{
UNLOCK_SV_MUTEX;
}
+/* allocate another arena's worth of struct xpvhv */
+
STATIC void
S_more_xpvhv(pTHX)
{
xpvhv->xhv_array = 0;
}
+/* grab a new struct xpvmg from the free list, allocating more if necessary */
+
STATIC XPVMG*
S_new_xpvmg(pTHX)
{
return xpvmg;
}
+/* return a struct xpvmg to the free list */
+
STATIC void
S_del_xpvmg(pTHX_ XPVMG *p)
{
UNLOCK_SV_MUTEX;
}
+/* allocate another arena's worth of struct xpvmg */
+
STATIC void
S_more_xpvmg(pTHX)
{
xpvmg->xpv_pv = 0;
}
+/* grab a new struct xpvlv from the free list, allocating more if necessary */
+
STATIC XPVLV*
S_new_xpvlv(pTHX)
{
return xpvlv;
}
+/* return a struct xpvlv to the free list */
+
STATIC void
S_del_xpvlv(pTHX_ XPVLV *p)
{
UNLOCK_SV_MUTEX;
}
+/* allocate another arena's worth of struct xpvlv */
+
STATIC void
S_more_xpvlv(pTHX)
{
xpvlv->xpv_pv = 0;
}
+/* grab a new struct xpvbm from the free list, allocating more if necessary */
+
STATIC XPVBM*
S_new_xpvbm(pTHX)
{
return xpvbm;
}
+/* return a struct xpvbm to the free list */
+
STATIC void
S_del_xpvbm(pTHX_ XPVBM *p)
{
UNLOCK_SV_MUTEX;
}
+/* allocate another arena's worth of struct xpvbm */
+
STATIC void
S_more_xpvbm(pTHX)
{
/*
=for apidoc sv_upgrade
-Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
-C<svtype>.
+Upgrade an SV to a more complex form. Gnenerally adds a new body type to the
+SV, then copies across as much information as possible from the old body.
+You genrally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
=cut
*/
return TRUE;
}
+/*
+=for apidoc sv_backoff
+
+Remove any string offset. You should normally use the C<SvOOK_off> macro
+wrapper instead.
+
+=cut
+*/
+
int
Perl_sv_backoff(pTHX_ register SV *sv)
{
/*
=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>.
+Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
+upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
+Use the C<SvGROW> wrapper instead.
=cut
*/
/*
=for apidoc sv_setiv
-Copies an integer into the given SV. Does not handle 'set' magic. See
-C<sv_setiv_mg>.
+Copies an integer into the given SV, upgrading first if necessary.
+Does not handle 'set' magic. See also C<sv_setiv_mg>.
=cut
*/
case SVt_PVCV:
case SVt_PVFM:
case SVt_PVIO:
- {
- dTHR;
- Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
- PL_op_desc[PL_op->op_type]);
- }
+ Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
+ PL_op_desc[PL_op->op_type]);
}
(void)SvIOK_only(sv); /* validate number */
SvIVX(sv) = i;
/*
=for apidoc sv_setuv
-Copies an unsigned integer into the given SV. Does not handle 'set' magic.
-See C<sv_setuv_mg>.
+Copies an unsigned integer into the given SV, upgrading first if necessary.
+Does not handle 'set' magic. See also C<sv_setuv_mg>.
=cut
*/
void
Perl_sv_setuv(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);
+ return;
+ }
sv_setiv(sv, 0);
SvIsUV_on(sv);
SvUVX(sv) = u;
void
Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
{
- sv_setuv(sv,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);
+ }
SvSETMAGIC(sv);
}
/*
=for apidoc sv_setnv
-Copies a double into the given SV. Does not handle 'set' magic. See
-C<sv_setnv_mg>.
+Copies a double into the given SV, upgrading first if necessary.
+Does not handle 'set' magic. See also C<sv_setnv_mg>.
=cut
*/
case SVt_PVCV:
case SVt_PVFM:
case SVt_PVIO:
- {
- dTHR;
- Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
- PL_op_name[PL_op->op_type]);
- }
+ Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
+ PL_op_name[PL_op->op_type]);
}
SvNVX(sv) = num;
(void)SvNOK_only(sv); /* validate number */
SvSETMAGIC(sv);
}
+/* Print an "isn't numeric" warning, using a cleaned-up,
+ * printable version of the offending string
+ */
+
STATIC void
S_not_a_number(pTHX_ SV *sv)
{
- dTHR;
char tmpbuf[64];
char *d = tmpbuf;
- char *s;
char *limit = tmpbuf + sizeof(tmpbuf) - 8;
/* each *s can expand to 4 chars + "...\0",
i.e. need room for 8 chars */
- for (s = SvPVX(sv); *s && d < limit; s++) {
+ char *s, *end;
+ for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
int ch = *s & 0xFF;
if (ch & 128 && !isPRINT_LC(ch)) {
*d++ = 'M';
*d++ = '\\';
*d++ = '\\';
}
+ else if (ch == '\0') {
+ *d++ = '\\';
+ *d++ = '0';
+ }
else if (isPRINT_LC(ch))
*d++ = ch;
else {
*d++ = toCTRL(ch);
}
}
- if (*s) {
+ if (s < end) {
*d++ = '.';
*d++ = '.';
*d++ = '.';
"Argument \"%s\" isn't numeric", tmpbuf);
}
-/* the number can be converted to integer with atol() or atoll() */
-#define IS_NUMBER_TO_INT_BY_ATOL 0x01
-#define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
-#define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
-#define IS_NUMBER_NEG 0x08 /* not good to cache UV */
-#define IS_NUMBER_INFINITY 0x10 /* this is big */
+/*
+=for apidoc looks_like_number
+
+Test if the content of an SV looks like a number (or is a number).
+C<Inf> and C<Infinity> are treated as numbers (so will not issue a
+non-numeric warning), even if your atof() doesn't grok them.
+
+=cut
+*/
+
+I32
+Perl_looks_like_number(pTHX_ SV *sv)
+{
+ register char *sbegin;
+ STRLEN len;
+
+ if (SvPOK(sv)) {
+ sbegin = SvPVX(sv);
+ len = SvCUR(sv);
+ }
+ else if (SvPOKp(sv))
+ sbegin = SvPV(sv, len);
+ else
+ return 1; /* Historic. Wrong? */
+ return grok_number(sbegin, len, NULL);
+}
/* Actually, ISO C leaves conversion of UV to IV undefined, but
until proven guilty, assume that things are not that bad... */
+/*
+ NV_PRESERVES_UV:
+
+ As 64 bit platforms often have an NV that doesn't preserve all bits of
+ an IV (an assumption perl has been based on to date) it becomes necessary
+ to remove the assumption that the NV always carries enough precision to
+ recreate the IV whenever needed, and that the NV is the canonical form.
+ Instead, IV/UV and NV need to be given equal rights. So as to not lose
+ precision as a side effect of conversion (which would lead to insanity
+ and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
+ 1) to distinguish between IV/UV/NV slots that have cached a valid
+ conversion where precision was lost and IV/UV/NV slots that have a
+ valid conversion which has lost no precision
+ 2) to ensure that if a numeric conversion to one form is requested that
+ would lose precision, the precise conversion (or differently
+ imprecise conversion) is also performed and cached, to prevent
+ requests for different numeric formats on the same SV causing
+ lossy conversion chains. (lossless conversion chains are perfectly
+ acceptable (still))
+
+
+ flags are used:
+ SvIOKp is true if the IV slot contains a valid value
+ SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
+ SvNOKp is true if the NV slot contains a valid value
+ SvNOK is true only if the NV value is accurate
+
+ so
+ while converting from PV to NV, check to see if converting that NV to an
+ IV(or UV) would lose accuracy over a direct conversion from PV to
+ IV(or UV). If it would, cache both conversions, return NV, but mark
+ SV as IOK NOKp (ie not NOK).
+
+ While converting from PV to IV, check to see if converting that IV to an
+ NV would lose accuracy over a direct conversion from PV to NV. If it
+ would, cache both conversions, flag similarly.
+
+ Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
+ correctly because if IV & NV were set NV *always* overruled.
+ Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
+ changes - now IV and NV together means that the two are interchangeable:
+ SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
+
+ The benefit of this is that operations such as pp_add know that if
+ SvIOK is true for both left and right operands, then integer addition
+ can be used instead of floating point (for cases where the result won't
+ overflow). Before, floating point was always used, which could lead to
+ loss of precision compared with integer addition.
+
+ * making IV and NV equal status should make maths accurate on 64 bit
+ platforms
+ * may speed up maths somewhat if pp_add and friends start to use
+ integers when possible instead of fp. (Hopefully the overhead in
+ looking for SvIOK and checking for overflow will not outweigh the
+ fp to integer speedup)
+ * will slow down integer operations (callers of SvIV) on "inaccurate"
+ values, as the change from SvIOK to SvIOKp will cause a call into
+ sv_2iv each time rather than a macro access direct to the IV slot
+ * should speed up number->string conversion on integers as IV is
+ favoured when IV and NV are equally accurate
+
+ ####################################################################
+ You had better be using SvIOK_notUV if you want an IV for arithmetic:
+ SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
+ On the other hand, SvUOK is true iff UV.
+ ####################################################################
+
+ Your mileage will vary depending your CPU's relative fp to integer
+ performance ratio.
+*/
+
+#ifndef NV_PRESERVES_UV
+# define IS_NUMBER_UNDERFLOW_IV 1
+# define IS_NUMBER_UNDERFLOW_UV 2
+# define IS_NUMBER_IV_AND_UV 2
+# define IS_NUMBER_OVERFLOW_IV 4
+# define IS_NUMBER_OVERFLOW_UV 5
+
+/* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
+
+/* For sv_2nv these three cases are "SvNOK and don't bother casting" */
+STATIC int
+S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
+{
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
+ if (SvNVX(sv) < (NV)IV_MIN) {
+ (void)SvIOKp_on(sv);
+ (void)SvNOK_on(sv);
+ SvIVX(sv) = IV_MIN;
+ return IS_NUMBER_UNDERFLOW_IV;
+ }
+ if (SvNVX(sv) > (NV)UV_MAX) {
+ (void)SvIOKp_on(sv);
+ (void)SvNOK_on(sv);
+ SvIsUV_on(sv);
+ SvUVX(sv) = UV_MAX;
+ return IS_NUMBER_OVERFLOW_UV;
+ }
+ (void)SvIOKp_on(sv);
+ (void)SvNOK_on(sv);
+ /* Can't use strtol etc to convert this string. (See truth table in
+ sv_2iv */
+ if (SvNVX(sv) <= (UV)IV_MAX) {
+ SvIVX(sv) = I_V(SvNVX(sv));
+ if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
+ SvIOK_on(sv); /* Integer is precise. NOK, IOK */
+ } else {
+ /* Integer is imprecise. NOK, IOKp */
+ }
+ return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
+ }
+ SvIsUV_on(sv);
+ SvUVX(sv) = U_V(SvNVX(sv));
+ if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
+ if (SvUVX(sv) == UV_MAX) {
+ /* As we know that NVs don't preserve UVs, UV_MAX cannot
+ possibly be preserved by NV. Hence, it must be overflow.
+ NOK, IOKp */
+ return IS_NUMBER_OVERFLOW_UV;
+ }
+ SvIOK_on(sv); /* Integer is precise. NOK, UOK */
+ } else {
+ /* Integer is imprecise. NOK, IOKp */
+ }
+ return IS_NUMBER_OVERFLOW_IV;
+}
+#endif /* !NV_PRESERVES_UV*/
+
+/*
+=for apidoc sv_2iv
+
+Return the integer value of an SV, doing any necessary string conversion,
+magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
+
+=cut
+*/
+
IV
Perl_sv_2iv(pTHX_ register SV *sv)
{
return asIV(sv);
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit();
}
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (SvRV(tmpstr) != SvRV(sv)))
+ (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
return SvIV(tmpstr);
return PTR2IV(SvRV(sv));
}
+ if (SvREADONLY(sv) && SvFAKE(sv)) {
+ sv_force_normal(sv);
+ }
if (SvREADONLY(sv) && !SvOK(sv)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED))
report_uninit();
return 0;
}
}
if (SvNOKp(sv)) {
- /* We can cache the IV/UV value even if it not good enough
- * to reconstruct NV, since the conversion to PV will prefer
- * NV over IV/UV.
- */
+ /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
+ * without also getting a cached IV/UV from it at the same time
+ * (ie PV->NV conversion should detect loss of accuracy and cache
+ * IV or UV at same time to avoid this. NWC */
if (SvTYPE(sv) == SVt_NV)
sv_upgrade(sv, SVt_PVNV);
- (void)SvIOK_on(sv);
- if (SvNVX(sv) < (NV)IV_MAX + 0.5)
+ (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
+ /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
+ certainly cast into the IV range at IV_MAX, whereas the correct
+ answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
+ cases go to UV */
+ if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
SvIVX(sv) = I_V(SvNVX(sv));
+ if (SvNVX(sv) == (NV) SvIVX(sv)
+#ifndef NV_PRESERVES_UV
+ && (((UV)1 << NV_PRESERVES_UV_BITS) >
+ (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
+ /* Don't flag it as "accurately an integer" if the number
+ came from a (by definition imprecise) NV operation, and
+ we're outside the range of NV integer precision */
+#endif
+ ) {
+ SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
+ PTR2UV(sv),
+ SvNVX(sv),
+ SvIVX(sv)));
+
+ } else {
+ /* IV not precise. No need to convert from PV, as NV
+ conversion would already have cached IV if it detected
+ that PV->IV would be better than PV->NV->IV
+ flags already correct - don't set public IOK. */
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
+ PTR2UV(sv),
+ SvNVX(sv),
+ SvIVX(sv)));
+ }
+ /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
+ but the cast (NV)IV_MIN rounds to a the value less (more
+ negative) than IV_MIN which happens to be equal to SvNVX ??
+ Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
+ NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
+ (NV)UVX == NVX are both true, but the values differ. :-(
+ Hopefully for 2s complement IV_MIN is something like
+ 0x8000000000000000 which will be exact. NWC */
+ }
else {
SvUVX(sv) = U_V(SvNVX(sv));
+ if (
+ (SvNVX(sv) == (NV) SvUVX(sv))
+#ifndef NV_PRESERVES_UV
+ /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
+ /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
+ && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
+ /* Don't flag it as "accurately an integer" if the number
+ came from a (by definition imprecise) NV operation, and
+ we're outside the range of NV integer precision */
+#endif
+ )
+ SvIOK_on(sv);
SvIsUV_on(sv);
ret_iv_max:
DEBUG_c(PerlIO_printf(Perl_debug_log,
}
}
else if (SvPOKp(sv) && SvLEN(sv)) {
- I32 numtype = looks_like_number(sv);
-
+ UV value;
+ int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
/* We want to avoid a possible problem when we cache an IV which
may be later translated to an NV, and the resulting NV is not
- the translation of the initial data.
+ the same as the direct translation of the initial string
+ (eg 123.456 can shortcut to the IV 123 with atol(), but we must
+ be careful to ensure that the value with the .456 is around if the
+ NV value is requested in the future).
This means that if we cache such an IV, we need to cache the
NV as well. Moreover, we trade speed for space, and do not
- cache the NV if not needed.
+ cache the NV if we are sure it's not needed.
*/
- if (numtype & IS_NUMBER_NOT_IV) {
- /* May be not an integer. Need to cache NV if we cache IV
- * - otherwise future conversion to NV will be wrong. */
- NV d;
- d = Atof(SvPVX(sv));
-
- if (SvTYPE(sv) < SVt_PVNV)
- sv_upgrade(sv, SVt_PVNV);
- SvNVX(sv) = d;
- (void)SvNOK_on(sv);
+ /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
+ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+ == IS_NUMBER_IN_UV) {
+ /* It's defintately an integer, only upgrade to PVIV */
+ if (SvTYPE(sv) < SVt_PVIV)
+ sv_upgrade(sv, SVt_PVIV);
(void)SvIOK_on(sv);
-#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
- PTR2UV(sv), SvNVX(sv)));
-#else
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
- PTR2UV(sv), SvNVX(sv)));
+ } else if (SvTYPE(sv) < SVt_PVNV)
+ sv_upgrade(sv, SVt_PVNV);
+
+ /* If NV preserves UV then we only use the UV value if we know that
+ we aren't going to call atof() below. If NVs don't preserve UVs
+ then the value returned may have more precision than atof() will
+ return, even though value isn't perfectly accurate. */
+ if ((numtype & (IS_NUMBER_IN_UV
+#ifdef NV_PRESERVES_UV
+ | IS_NUMBER_NOT_INT
#endif
- if (SvNVX(sv) < (NV)IV_MAX + 0.5)
- SvIVX(sv) = I_V(SvNVX(sv));
- else {
- SvUVX(sv) = U_V(SvNVX(sv));
- SvIsUV_on(sv);
- goto ret_iv_max;
+ )) == IS_NUMBER_IN_UV) {
+ /* This won't turn off the public IOK flag if it was set above */
+ (void)SvIOKp_on(sv);
+
+ if (!(numtype & IS_NUMBER_NEG)) {
+ /* positive */;
+ if (value <= (UV)IV_MAX) {
+ SvIVX(sv) = (IV)value;
+ } else {
+ SvUVX(sv) = value;
+ SvIsUV_on(sv);
+ }
+ } else {
+ /* 2s complement assumption */
+ if (value <= (UV)IV_MIN) {
+ SvIVX(sv) = -(IV)value;
+ } else {
+ /* Too negative for an IV. This is a double upgrade, but
+ I'm assuming it will be be rare. */
+ if (SvTYPE(sv) < SVt_PVNV)
+ sv_upgrade(sv, SVt_PVNV);
+ SvNOK_on(sv);
+ SvIOK_off(sv);
+ SvIOKp_on(sv);
+ SvNVX(sv) = -(NV)value;
+ SvIVX(sv) = IV_MIN;
+ }
}
}
- else { /* The NV may be reconstructed from IV - safe to cache IV,
- which may be calculated by atol(). */
- if (SvTYPE(sv) < SVt_PVIV)
- sv_upgrade(sv, SVt_PVIV);
- (void)SvIOK_on(sv);
- SvIVX(sv) = Atol(SvPVX(sv));
+ /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
+ will be in the previous block to set the IV slot, and the next
+ block to set the NV slot. So no else here. */
+
+ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+ != IS_NUMBER_IN_UV) {
+ /* It wasn't an (integer that doesn't overflow the UV). */
+ SvNVX(sv) = Atof(SvPVX(sv));
+
if (! numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
- }
- }
- else {
- dTHR;
+
+#if defined(USE_LONG_DOUBLE)
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
+ PTR2UV(sv), SvNVX(sv)));
+#else
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
+ PTR2UV(sv), SvNVX(sv)));
+#endif
+
+
+#ifdef NV_PRESERVES_UV
+ (void)SvIOKp_on(sv);
+ (void)SvNOK_on(sv);
+ if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
+ SvIVX(sv) = I_V(SvNVX(sv));
+ if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
+ SvIOK_on(sv);
+ } else {
+ /* Integer is imprecise. NOK, IOKp */
+ }
+ /* UV will not work better than IV */
+ } else {
+ if (SvNVX(sv) > (NV)UV_MAX) {
+ SvIsUV_on(sv);
+ /* Integer is inaccurate. NOK, IOKp, is UV */
+ SvUVX(sv) = UV_MAX;
+ SvIsUV_on(sv);
+ } else {
+ SvUVX(sv) = U_V(SvNVX(sv));
+ /* 0xFFFFFFFFFFFFFFFF not an issue in here */
+ if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
+ SvIOK_on(sv);
+ SvIsUV_on(sv);
+ } else {
+ /* Integer is imprecise. NOK, IOKp, is UV */
+ SvIsUV_on(sv);
+ }
+ }
+ goto ret_iv_max;
+ }
+#else /* NV_PRESERVES_UV */
+ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+ == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
+ /* The IV slot will have been set from value returned by
+ grok_number above. The NV slot has just been set using
+ Atof. */
+ SvNOK_on(sv);
+ assert (SvIOKp(sv));
+ } else {
+ if (((UV)1 << NV_PRESERVES_UV_BITS) >
+ U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
+ /* Small enough to preserve all bits. */
+ (void)SvIOKp_on(sv);
+ SvNOK_on(sv);
+ SvIVX(sv) = I_V(SvNVX(sv));
+ if ((NV)(SvIVX(sv)) == SvNVX(sv))
+ SvIOK_on(sv);
+ /* Assumption: first non-preserved integer is < IV_MAX,
+ this NV is in the preserved range, therefore: */
+ if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
+ < (UV)IV_MAX)) {
+ Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
+ }
+ } else {
+ /* IN_UV NOT_INT
+ 0 0 already failed to read UV.
+ 0 1 already failed to read UV.
+ 1 0 you won't get here in this case. IV/UV
+ slot set, public IOK, Atof() unneeded.
+ 1 1 already read UV.
+ so there's no point in sv_2iuv_non_preserve() attempting
+ to use atol, strtol, strtoul etc. */
+ if (sv_2iuv_non_preserve (sv, numtype)
+ >= IS_NUMBER_OVERFLOW_IV)
+ goto ret_iv_max;
+ }
+ }
+#endif /* NV_PRESERVES_UV */
+ }
+ } else {
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
report_uninit();
if (SvTYPE(sv) < SVt_IV)
return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
}
+/*
+=for apidoc sv_2uv
+
+Return the unsigned integer value of an SV, doing any necessary string
+conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
+macros.
+
+=cut
+*/
+
UV
Perl_sv_2uv(pTHX_ register SV *sv)
{
return asUV(sv);
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit();
}
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (SvRV(tmpstr) != SvRV(sv)))
+ (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
return SvUV(tmpstr);
return PTR2UV(SvRV(sv));
}
+ if (SvREADONLY(sv) && SvFAKE(sv)) {
+ sv_force_normal(sv);
+ }
if (SvREADONLY(sv) && !SvOK(sv)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED))
report_uninit();
return 0;
}
}
if (SvNOKp(sv)) {
- /* We can cache the IV/UV value even if it not good enough
- * to reconstruct NV, since the conversion to PV will prefer
- * NV over IV/UV.
- */
+ /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
+ * without also getting a cached IV/UV from it at the same time
+ * (ie PV->NV conversion should detect loss of accuracy and cache
+ * IV or UV at same time to avoid this. */
+ /* IV-over-UV optimisation - choose to cache IV if possible */
+
if (SvTYPE(sv) == SVt_NV)
sv_upgrade(sv, SVt_PVNV);
- (void)SvIOK_on(sv);
- if (SvNVX(sv) >= -0.5) {
- SvIsUV_on(sv);
- SvUVX(sv) = U_V(SvNVX(sv));
+
+ (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
+ if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
+ SvIVX(sv) = I_V(SvNVX(sv));
+ if (SvNVX(sv) == (NV) SvIVX(sv)
+#ifndef NV_PRESERVES_UV
+ && (((UV)1 << NV_PRESERVES_UV_BITS) >
+ (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
+ /* Don't flag it as "accurately an integer" if the number
+ came from a (by definition imprecise) NV operation, and
+ we're outside the range of NV integer precision */
+#endif
+ ) {
+ SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
+ PTR2UV(sv),
+ SvNVX(sv),
+ SvIVX(sv)));
+
+ } else {
+ /* IV not precise. No need to convert from PV, as NV
+ conversion would already have cached IV if it detected
+ that PV->IV would be better than PV->NV->IV
+ flags already correct - don't set public IOK. */
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
+ PTR2UV(sv),
+ SvNVX(sv),
+ SvIVX(sv)));
+ }
+ /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
+ but the cast (NV)IV_MIN rounds to a the value less (more
+ negative) than IV_MIN which happens to be equal to SvNVX ??
+ Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
+ NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
+ (NV)UVX == NVX are both true, but the values differ. :-(
+ Hopefully for 2s complement IV_MIN is something like
+ 0x8000000000000000 which will be exact. NWC */
}
else {
- SvIVX(sv) = I_V(SvNVX(sv));
- ret_zero:
+ SvUVX(sv) = U_V(SvNVX(sv));
+ if (
+ (SvNVX(sv) == (NV) SvUVX(sv))
+#ifndef NV_PRESERVES_UV
+ /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
+ /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
+ && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
+ /* Don't flag it as "accurately an integer" if the number
+ came from a (by definition imprecise) NV operation, and
+ we're outside the range of NV integer precision */
+#endif
+ )
+ SvIOK_on(sv);
+ SvIsUV_on(sv);
DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
+ "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
PTR2UV(sv),
- SvIVX(sv),
- (IV)(UV)SvIVX(sv)));
- return (UV)SvIVX(sv);
+ SvUVX(sv),
+ SvUVX(sv)));
}
}
else if (SvPOKp(sv) && SvLEN(sv)) {
- I32 numtype = looks_like_number(sv);
+ UV value;
+ int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
/* We want to avoid a possible problem when we cache a UV which
may be later translated to an NV, and the resulting NV is not
NV as well. Moreover, we trade speed for space, and do not
cache the NV if not needed.
*/
- if (numtype & IS_NUMBER_NOT_IV) {
- /* May be not an integer. Need to cache NV if we cache IV
- * - otherwise future conversion to NV will be wrong. */
- NV d;
- d = Atof(SvPVX(sv));
-
- if (SvTYPE(sv) < SVt_PVNV)
- sv_upgrade(sv, SVt_PVNV);
- SvNVX(sv) = d;
- (void)SvNOK_on(sv);
+ /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
+ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+ == IS_NUMBER_IN_UV) {
+ /* It's defintately an integer, only upgrade to PVIV */
+ if (SvTYPE(sv) < SVt_PVIV)
+ sv_upgrade(sv, SVt_PVIV);
(void)SvIOK_on(sv);
-#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
- PTR2UV(sv), SvNVX(sv)));
-#else
- DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" 2nv(%g)\n",
- PTR2UV(sv), SvNVX(sv)));
+ } else if (SvTYPE(sv) < SVt_PVNV)
+ sv_upgrade(sv, SVt_PVNV);
+
+ /* If NV preserves UV then we only use the UV value if we know that
+ we aren't going to call atof() below. If NVs don't preserve UVs
+ then the value returned may have more precision than atof() will
+ return, even though it isn't accurate. */
+ if ((numtype & (IS_NUMBER_IN_UV
+#ifdef NV_PRESERVES_UV
+ | IS_NUMBER_NOT_INT
#endif
- if (SvNVX(sv) < -0.5) {
- SvIVX(sv) = I_V(SvNVX(sv));
- goto ret_zero;
+ )) == IS_NUMBER_IN_UV) {
+ /* This won't turn off the public IOK flag if it was set above */
+ (void)SvIOKp_on(sv);
+
+ if (!(numtype & IS_NUMBER_NEG)) {
+ /* positive */;
+ if (value <= (UV)IV_MAX) {
+ SvIVX(sv) = (IV)value;
+ } else {
+ /* it didn't overflow, and it was positive. */
+ SvUVX(sv) = value;
+ SvIsUV_on(sv);
+ }
} else {
- SvUVX(sv) = U_V(SvNVX(sv));
- SvIsUV_on(sv);
+ /* 2s complement assumption */
+ if (value <= (UV)IV_MIN) {
+ SvIVX(sv) = -(IV)value;
+ } else {
+ /* Too negative for an IV. This is a double upgrade, but
+ I'm assuming it will be be rare. */
+ if (SvTYPE(sv) < SVt_PVNV)
+ sv_upgrade(sv, SVt_PVNV);
+ SvNOK_on(sv);
+ SvIOK_off(sv);
+ SvIOKp_on(sv);
+ SvNVX(sv) = -(NV)value;
+ SvIVX(sv) = IV_MIN;
+ }
}
}
- else if (numtype & IS_NUMBER_NEG) {
- /* The NV may be reconstructed from IV - safe to cache IV,
- which may be calculated by atol(). */
- if (SvTYPE(sv) == SVt_PV)
- sv_upgrade(sv, SVt_PVIV);
- (void)SvIOK_on(sv);
- SvIVX(sv) = (IV)Atol(SvPVX(sv));
- }
- else if (numtype) { /* Non-negative */
- /* The NV may be reconstructed from UV - safe to cache UV,
- which may be calculated by strtoul()/atol. */
- if (SvTYPE(sv) == SVt_PV)
- sv_upgrade(sv, SVt_PVIV);
- (void)SvIOK_on(sv);
- (void)SvIsUV_on(sv);
-#ifdef HAS_STRTOUL
- SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
-#else /* no atou(), but we know the number fits into IV... */
- /* The only problem may be if it is negative... */
- SvUVX(sv) = (UV)Atol(SvPVX(sv));
+
+ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+ != IS_NUMBER_IN_UV) {
+ /* It wasn't an integer, or it overflowed the UV. */
+ SvNVX(sv) = Atof(SvPVX(sv));
+
+ if (! numtype && ckWARN(WARN_NUMERIC))
+ not_a_number(sv);
+
+#if defined(USE_LONG_DOUBLE)
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
+ PTR2UV(sv), SvNVX(sv)));
+#else
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
+ PTR2UV(sv), SvNVX(sv)));
#endif
- }
- else { /* Not a number. Cache 0. */
- dTHR;
- if (SvTYPE(sv) < SVt_PVIV)
- sv_upgrade(sv, SVt_PVIV);
- (void)SvIOK_on(sv);
- (void)SvIsUV_on(sv);
- SvUVX(sv) = 0; /* We assume that 0s have the
- same bitmap in IV and UV. */
- if (ckWARN(WARN_NUMERIC))
- not_a_number(sv);
+#ifdef NV_PRESERVES_UV
+ (void)SvIOKp_on(sv);
+ (void)SvNOK_on(sv);
+ if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
+ SvIVX(sv) = I_V(SvNVX(sv));
+ if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
+ SvIOK_on(sv);
+ } else {
+ /* Integer is imprecise. NOK, IOKp */
+ }
+ /* UV will not work better than IV */
+ } else {
+ if (SvNVX(sv) > (NV)UV_MAX) {
+ SvIsUV_on(sv);
+ /* Integer is inaccurate. NOK, IOKp, is UV */
+ SvUVX(sv) = UV_MAX;
+ SvIsUV_on(sv);
+ } else {
+ SvUVX(sv) = U_V(SvNVX(sv));
+ /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
+ NV preservse UV so can do correct comparison. */
+ if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
+ SvIOK_on(sv);
+ SvIsUV_on(sv);
+ } else {
+ /* Integer is imprecise. NOK, IOKp, is UV */
+ SvIsUV_on(sv);
+ }
+ }
+ }
+#else /* NV_PRESERVES_UV */
+ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+ == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
+ /* The UV slot will have been set from value returned by
+ grok_number above. The NV slot has just been set using
+ Atof. */
+ SvNOK_on(sv);
+ assert (SvIOKp(sv));
+ } else {
+ if (((UV)1 << NV_PRESERVES_UV_BITS) >
+ U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
+ /* Small enough to preserve all bits. */
+ (void)SvIOKp_on(sv);
+ SvNOK_on(sv);
+ SvIVX(sv) = I_V(SvNVX(sv));
+ if ((NV)(SvIVX(sv)) == SvNVX(sv))
+ SvIOK_on(sv);
+ /* Assumption: first non-preserved integer is < IV_MAX,
+ this NV is in the preserved range, therefore: */
+ if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
+ < (UV)IV_MAX)) {
+ Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
+ }
+ } else
+ sv_2iuv_non_preserve (sv, numtype);
+ }
+#endif /* NV_PRESERVES_UV */
}
}
else {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit();
}
return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
}
+/*
+=for apidoc sv_2nv
+
+Return the num value of an SV, doing any necessary string or integer
+conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
+macros.
+
+=cut
+*/
+
NV
Perl_sv_2nv(pTHX_ register SV *sv)
{
if (SvNOKp(sv))
return SvNVX(sv);
if (SvPOKp(sv) && SvLEN(sv)) {
- dTHR;
- if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
+ if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
+ !grok_number(SvPVX(sv), SvCUR(sv), NULL))
not_a_number(sv);
return Atof(SvPVX(sv));
}
}
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit();
}
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (SvRV(tmpstr) != SvRV(sv)))
+ (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
return SvNV(tmpstr);
return PTR2NV(SvRV(sv));
}
+ if (SvREADONLY(sv) && SvFAKE(sv)) {
+ sv_force_normal(sv);
+ }
if (SvREADONLY(sv) && !SvOK(sv)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED))
report_uninit();
return 0.0;
sv_upgrade(sv, SVt_PVNV);
else
sv_upgrade(sv, SVt_NV);
-#if defined(USE_LONG_DOUBLE)
+#ifdef USE_LONG_DOUBLE
DEBUG_c({
STORE_NUMERIC_LOCAL_SET_STANDARD();
PerlIO_printf(Perl_debug_log,
}
else if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
- if (SvIOKp(sv) &&
- (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
- {
+ if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
+ SvNOK_on(sv);
+ }
+ else if (SvIOKp(sv)) {
SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
+#ifdef NV_PRESERVES_UV
+ SvNOK_on(sv);
+#else
+ /* Only set the public NV OK flag if this NV preserves the IV */
+ /* Check it's not 0xFFFFFFFFFFFFFFFF */
+ if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
+ : (SvIVX(sv) == I_V(SvNVX(sv))))
+ SvNOK_on(sv);
+ else
+ SvNOKp_on(sv);
+#endif
}
else if (SvPOKp(sv) && SvLEN(sv)) {
- dTHR;
- if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
+ UV value;
+ int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
+ if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
not_a_number(sv);
+#ifdef NV_PRESERVES_UV
+ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+ == IS_NUMBER_IN_UV) {
+ /* It's defintately an integer */
+ SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
+ } else
+ SvNVX(sv) = Atof(SvPVX(sv));
+ SvNOK_on(sv);
+#else
SvNVX(sv) = Atof(SvPVX(sv));
+ /* Only set the public NV OK flag if this NV preserves the value in
+ the PV at least as well as an IV/UV would.
+ Not sure how to do this 100% reliably. */
+ /* if that shift count is out of range then Configure's test is
+ wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
+ UV_BITS */
+ if (((UV)1 << NV_PRESERVES_UV_BITS) >
+ U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
+ SvNOK_on(sv); /* Definitely small enough to preserve all bits */
+ } else if (!(numtype & IS_NUMBER_IN_UV)) {
+ /* Can't use strtol etc to convert this string, so don't try.
+ sv_2iv and sv_2uv will use the NV to convert, not the PV. */
+ SvNOK_on(sv);
+ } else {
+ /* value has been set. It may not be precise. */
+ if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
+ /* 2s complement assumption for (UV)IV_MIN */
+ SvNOK_on(sv); /* Integer is too negative. */
+ } else {
+ SvNOKp_on(sv);
+ SvIOKp_on(sv);
+
+ if (numtype & IS_NUMBER_NEG) {
+ SvIVX(sv) = -(IV)value;
+ } else if (value <= (UV)IV_MAX) {
+ SvIVX(sv) = (IV)value;
+ } else {
+ SvUVX(sv) = value;
+ SvIsUV_on(sv);
+ }
+
+ if (numtype & IS_NUMBER_NOT_INT) {
+ /* I believe that even if the original PV had decimals,
+ they are lost beyond the limit of the FP precision.
+ However, neither is canonical, so both only get p
+ flags. NWC, 2000/11/25 */
+ /* Both already have p flags, so do nothing */
+ } else {
+ NV nv = SvNVX(sv);
+ if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
+ if (SvIVX(sv) == I_V(nv)) {
+ SvNOK_on(sv);
+ SvIOK_on(sv);
+ } else {
+ SvIOK_on(sv);
+ /* It had no "." so it must be integer. */
+ }
+ } else {
+ /* between IV_MAX and NV(UV_MAX).
+ Could be slightly > UV_MAX */
+
+ if (numtype & IS_NUMBER_NOT_INT) {
+ /* UV and NV both imprecise. */
+ } else {
+ UV nv_as_uv = U_V(nv);
+
+ if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
+ SvNOK_on(sv);
+ SvIOK_on(sv);
+ } else {
+ SvIOK_on(sv);
+ }
+ }
+ }
+ }
+ }
+ }
+#endif /* NV_PRESERVES_UV */
}
else {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
report_uninit();
if (SvTYPE(sv) < SVt_NV)
/* Typically the caller expects that sv_any is not NULL now. */
+ /* XXX Ilya implies that this is a bug in callers that assume this
+ and ideally should be fixed. */
sv_upgrade(sv, SVt_NV);
return 0.0;
}
- SvNOK_on(sv);
#if defined(USE_LONG_DOUBLE)
DEBUG_c({
STORE_NUMERIC_LOCAL_SET_STANDARD();
return SvNVX(sv);
}
+/* asIV(): extract an integer from the string value of an SV.
+ * Caller must validate PVX */
+
STATIC IV
S_asIV(pTHX_ SV *sv)
{
- I32 numtype = looks_like_number(sv);
- NV d;
+ UV value;
+ int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
- if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
- return Atol(SvPVX(sv));
+ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+ == IS_NUMBER_IN_UV) {
+ /* It's definitely an integer */
+ if (numtype & IS_NUMBER_NEG) {
+ if (value < (UV)IV_MIN)
+ return -(IV)value;
+ } else {
+ if (value < (UV)IV_MAX)
+ return (IV)value;
+ }
+ }
if (!numtype) {
- dTHR;
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
- d = Atof(SvPVX(sv));
- return I_V(d);
+ return I_V(Atof(SvPVX(sv)));
}
+/* asUV(): extract an unsigned integer from the string value of an SV
+ * Caller must validate PVX */
+
STATIC UV
S_asUV(pTHX_ SV *sv)
{
- I32 numtype = looks_like_number(sv);
+ UV value;
+ int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
-#ifdef HAS_STRTOUL
- if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
- return Strtoul(SvPVX(sv), Null(char**), 10);
-#endif
+ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
+ == IS_NUMBER_IN_UV) {
+ /* It's definitely an integer */
+ if (!(numtype & IS_NUMBER_NEG))
+ return value;
+ }
if (!numtype) {
- dTHR;
if (ckWARN(WARN_NUMERIC))
not_a_number(sv);
}
}
/*
- * Returns a combination of (advisory only - can get false negatives)
- * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
- * IS_NUMBER_NEG
- * 0 if does not look like number.
- *
- * In fact possible values are 0 and
- * IS_NUMBER_TO_INT_BY_ATOL 123
- * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
- * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
- * IS_NUMBER_INFINITY
- * 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).
+=for apidoc sv_2pv_nolen
+Like C<sv_2pv()>, but doesn't return the length too. You should usually
+use the macro wrapper C<SvPV_nolen(sv)> instead.
=cut
*/
-I32
-Perl_looks_like_number(pTHX_ SV *sv)
-{
- register char *s;
- register char *send;
- register char *sbegin;
- register char *nbegin;
- I32 numtype = 0;
- I32 sawinf = 0;
- STRLEN len;
-
- if (SvPOK(sv)) {
- sbegin = SvPVX(sv);
- len = SvCUR(sv);
- }
- else if (SvPOKp(sv))
- sbegin = SvPV(sv, len);
- else
- return 1;
- send = sbegin + len;
-
- s = sbegin;
- while (isSPACE(*s))
- s++;
- if (*s == '-') {
- s++;
- numtype = IS_NUMBER_NEG;
- }
- else if (*s == '+')
- s++;
-
- nbegin = s;
- /*
- * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
- * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
- * (int)atof().
- */
-
- /* next must be digit or the radix separator or beginning of infinity */
- if (isDIGIT(*s)) {
- do {
- s++;
- } while (isDIGIT(*s));
-
- if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
- numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
- else
- numtype |= IS_NUMBER_TO_INT_BY_ATOL;
-
- if (*s == '.'
-#ifdef USE_LOCALE_NUMERIC
- || IS_NUMERIC_RADIX(*s)
-#endif
- ) {
- s++;
- numtype |= IS_NUMBER_NOT_IV;
- while (isDIGIT(*s)) /* optional digits after the radix */
- s++;
- }
- }
- else if (*s == '.'
-#ifdef USE_LOCALE_NUMERIC
- || IS_NUMERIC_RADIX(*s)
-#endif
- ) {
- s++;
- numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
- /* no digits before the radix means we need digits after it */
- if (isDIGIT(*s)) {
- do {
- s++;
- } while (isDIGIT(*s));
- }
- else
- return 0;
- }
- else if (*s == 'I' || *s == 'i') {
- s++; if (*s != 'N' && *s != 'n') return 0;
- s++; if (*s != 'F' && *s != 'f') return 0;
- s++; if (*s == 'I' || *s == 'i') {
- s++; if (*s != 'N' && *s != 'n') return 0;
- s++; if (*s != 'I' && *s != 'i') return 0;
- s++; if (*s != 'T' && *s != 't') return 0;
- s++; if (*s != 'Y' && *s != 'y') return 0;
- }
- sawinf = 1;
- }
- else
- return 0;
-
- if (sawinf)
- numtype = IS_NUMBER_INFINITY;
- else {
- /* we can have an optional exponent part */
- if (*s == 'e' || *s == 'E') {
- numtype &= ~IS_NUMBER_NEG;
- numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
- s++;
- if (*s == '+' || *s == '-')
- s++;
- if (isDIGIT(*s)) {
- do {
- s++;
- } while (isDIGIT(*s));
- }
- else
- return 0;
- }
- }
- while (isSPACE(*s))
- s++;
- if (s >= send)
- return numtype;
- if (len == 10 && memEQ(sbegin, "0 but true", 10))
- return IS_NUMBER_TO_INT_BY_ATOL;
- return 0;
-}
-
char *
Perl_sv_2pv_nolen(pTHX_ register SV *sv)
{
return sv_2pv(sv, &n_a);
}
-/* We assume that buf is at least TYPE_CHARS(UV) long. */
+/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
+ * UV as a string towards the end of buf, and return pointers to start and
+ * end of it.
+ *
+ * We assume that buf is at least TYPE_CHARS(UV) long.
+ */
+
static char *
uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
{
return ptr;
}
+/* For backwards-compatibility only. sv_2pv() is normally #def'ed to
+ * C<sv_2pv_macro()>. See also C<sv_2pv_flags()>.
+ */
+
char *
Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
{
+ return sv_2pv_flags(sv, lp, SV_GMAGIC);
+}
+
+/*
+=for apidoc sv_2pv_flags
+
+Returns pointer to the string value of an SV, and sets *lp to its length.
+If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
+if necessary.
+Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
+usually end up here too.
+
+=cut
+*/
+
+char *
+Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
+{
register char *s;
int olderrno;
SV *tsv;
return "";
}
if (SvGMAGICAL(sv)) {
- mg_get(sv);
+ if (flags & SV_GMAGIC)
+ mg_get(sv);
if (SvPOKp(sv)) {
*lp = SvCUR(sv);
return SvPVX(sv);
}
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit();
}
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
- (SvRV(tmpstr) != SvRV(sv)))
+ (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
return SvPV(tmpstr,*lp);
sv = (SV*)SvRV(sv);
if (!sv)
(SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
== (SVs_OBJECT|SVs_RMG))
&& strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
- && (mg = mg_find(sv, 'r'))) {
- dTHR;
+ && (mg = mg_find(sv, PERL_MAGIC_qr))) {
regexp *re = (regexp *)mg->mg_obj;
if (!mg->mg_ptr) {
return s;
}
if (SvREADONLY(sv) && !SvOK(sv)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED))
report_uninit();
*lp = 0;
return "";
}
}
- if (SvNOKp(sv)) { /* See note in sv_2uv() */
- /* XXXX 64-bit? IV may have better precision... */
- /* I tried changing this to be 64-bit-aware and
- * the t/op/numconvert.t became very, very, angry.
- * --jhi Sep 1999 */
+ if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
+ /* I'm assuming that if both IV and NV are equally valid then
+ converting the IV is going to be more efficient */
+ U32 isIOK = SvIOK(sv);
+ U32 isUIOK = SvIsUV(sv);
+ char buf[TYPE_CHARS(UV)];
+ char *ebuf, *ptr;
+
+ if (SvTYPE(sv) < SVt_PVIV)
+ sv_upgrade(sv, SVt_PVIV);
+ if (isUIOK)
+ ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
+ else
+ ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
+ SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
+ Move(ptr,SvPVX(sv),ebuf - ptr,char);
+ SvCUR_set(sv, ebuf - ptr);
+ s = SvEND(sv);
+ *s = '\0';
+ if (isIOK)
+ SvIOK_on(sv);
+ else
+ SvIOKp_on(sv);
+ if (isUIOK)
+ SvIsUV_on(sv);
+ }
+ else if (SvNOKp(sv)) {
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
/* The +20 is pure guesswork. Configure test needed. --jhi */
*--s = '\0';
#endif
}
- else if (SvIOKp(sv)) {
- U32 isIOK = SvIOK(sv);
- U32 isUIOK = SvIsUV(sv);
- char buf[TYPE_CHARS(UV)];
- char *ebuf, *ptr;
-
- if (SvTYPE(sv) < SVt_PVIV)
- sv_upgrade(sv, SVt_PVIV);
- if (isUIOK)
- ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
- else
- ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
- SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
- Move(ptr,SvPVX(sv),ebuf - ptr,char);
- SvCUR_set(sv, ebuf - ptr);
- s = SvEND(sv);
- *s = '\0';
- if (isIOK)
- SvIOK_on(sv);
- else
- SvIOKp_on(sv);
- if (isUIOK)
- SvIsUV_on(sv);
- SvPOK_on(sv);
- }
else {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED)
&& !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- {
report_uninit();
- }
*lp = 0;
if (SvTYPE(sv) < SVt_PV)
/* Typically the caller expects that sv_any is not NULL now. */
}
}
+/*
+=for apidoc sv_2pvbyte_nolen
+
+Return a pointer to the byte-encoded representation of the SV.
+May cause the SV to be downgraded from UTF8 as a side-effect.
+
+Usually accessed via the C<SvPVbyte_nolen> macro.
+
+=cut
+*/
+
char *
Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
{
return sv_2pvbyte(sv, &n_a);
}
+/*
+=for apidoc sv_2pvbyte
+
+Return a pointer to the byte-encoded representation of the SV, and set *lp
+to its length. May cause the SV to be downgraded from UTF8 as a
+side-effect.
+
+Usually accessed via the C<SvPVbyte> macro.
+
+=cut
+*/
+
char *
Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
{
- return sv_2pv(sv,lp);
+ sv_utf8_downgrade(sv,0);
+ return SvPV(sv,*lp);
}
+/*
+=for apidoc sv_2pvutf8_nolen
+
+Return a pointer to the UTF8-encoded representation of the SV.
+May cause the SV to be upgraded to UTF8 as a side-effect.
+
+Usually accessed via the C<SvPVutf8_nolen> macro.
+
+=cut
+*/
+
char *
Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
{
return sv_2pvutf8(sv, &n_a);
}
+/*
+=for apidoc sv_2pvutf8
+
+Return a pointer to the UTF8-encoded representation of the SV, and set *lp
+to its length. May cause the SV to be upgraded to UTF8 as a side-effect.
+
+Usually accessed via the C<SvPVutf8> macro.
+
+=cut
+*/
+
char *
Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
{
sv_utf8_upgrade(sv);
- return sv_2pv(sv,lp);
+ return SvPV(sv,*lp);
}
-/* This function is only called on magical items */
+/*
+=for apidoc sv_2bool
+
+This function is only called on magical items, and is only used by
+sv_true() or its macro equivalent.
+
+=cut
+*/
+
bool
Perl_sv_2bool(pTHX_ register SV *sv)
{
if (!SvOK(sv))
return 0;
if (SvROK(sv)) {
- dTHR;
SV* tmpsv;
if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
- (SvRV(tmpsv) != SvRV(sv)))
+ (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
return SvTRUE(tmpsv);
return SvRV(sv) != 0;
}
=for apidoc sv_utf8_upgrade
Convert the PV of an SV to its UTF8-encoded form.
+Forces the SV to string form if it is not already.
+Always sets the SvUTF8 flag to avoid future validity checks even
+if all the bytes have hibit clear.
=cut
*/
-void
+STRLEN
Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
{
- char *s, *t;
- bool hibit;
+ return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
+}
- if (!sv || !SvPOK(sv) || SvUTF8(sv))
- return;
+/*
+=for apidoc sv_utf8_upgrade_flags
+
+Convert the PV of an SV to its UTF8-encoded form.
+Forces the SV to string form if it is not already.
+Always sets the SvUTF8 flag to avoid future validity checks even
+if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
+will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
+C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
+
+=cut
+*/
+
+STRLEN
+Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
+{
+ U8 *s, *t, *e;
+ int hibit = 0;
+
+ if (!sv)
+ return 0;
+
+ if (!SvPOK(sv)) {
+ STRLEN len = 0;
+ (void) sv_2pv_flags(sv,&len, flags);
+ if (!SvPOK(sv))
+ return len;
+ }
+
+ if (SvUTF8(sv))
+ return SvCUR(sv);
+
+ if (SvREADONLY(sv) && SvFAKE(sv)) {
+ sv_force_normal(sv);
+ }
/* This function could be much more efficient if we had a FLAG in SVs
* to signal if there are any hibit chars in the PV.
+ * Given that there isn't make loop fast as possible
*/
- for (s = t = SvPVX(sv), hibit = FALSE; t < SvEND(sv) && !hibit; t++)
- if (*t & 0x80)
- hibit = TRUE;
-
+ s = (U8 *) SvPVX(sv);
+ e = (U8 *) SvEND(sv);
+ t = s;
+ while (t < e) {
+ U8 ch = *t++;
+ if ((hibit = !NATIVE_IS_INVARIANT(ch)))
+ break;
+ }
if (hibit) {
- STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
+ STRLEN len;
+
+ len = SvCUR(sv) + 1; /* Plus the \0 */
SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
SvCUR(sv) = len - 1;
+ if (SvLEN(sv) != 0)
+ Safefree(s); /* No longer using what was there before. */
SvLEN(sv) = len; /* No longer know the real size. */
- SvUTF8_on(sv);
- Safefree(s); /* No longer using what was there before. */
}
+ /* Mark as UTF-8 even if no hibit - saves scanning loop */
+ SvUTF8_on(sv);
+ return SvCUR(sv);
}
/*
Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
{
if (SvPOK(sv) && SvUTF8(sv)) {
- char *c = SvPVX(sv);
- STRLEN len = SvCUR(sv) + 1; /* include trailing NUL */
- if (!utf8_to_bytes((U8*)c, &len)) {
- if (fail_ok)
- return FALSE;
- else
- Perl_croak(aTHX_ "big byte");
+ if (SvCUR(sv)) {
+ U8 *s;
+ STRLEN len;
+
+ if (SvREADONLY(sv) && SvFAKE(sv))
+ sv_force_normal(sv);
+ s = (U8 *) SvPV(sv, len);
+ if (!utf8_to_bytes(s, &len)) {
+ if (fail_ok)
+ return FALSE;
+#ifdef USE_BYTES_DOWNGRADES
+ else if (IN_BYTES) {
+ U8 *d = s;
+ U8 *e = (U8 *) SvEND(sv);
+ int first = 1;
+ while (s < e) {
+ UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
+ if (first && ch > 255) {
+ if (PL_op)
+ Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
+ PL_op_desc[PL_op->op_type]);
+ else
+ Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
+ first = 0;
+ }
+ *d++ = ch;
+ s += len;
+ }
+ *d = '\0';
+ len = (d - (U8 *) SvPVX(sv));
+ }
+#endif
+ else {
+ if (PL_op)
+ Perl_croak(aTHX_ "Wide character in %s",
+ PL_op_desc[PL_op->op_type]);
+ else
+ Perl_croak(aTHX_ "Wide character");
+ }
+ }
+ SvCUR(sv) = len;
}
- SvCUR(sv) = len - 1;
- SvUTF8_off(sv);
}
+ SvUTF8_off(sv);
return TRUE;
}
=for apidoc sv_utf8_encode
Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
-flag so that it looks like bytes again. Nothing calls this.
+flag so that it looks like octets again. Used as a building block
+for encode_utf8 in Encode.xs
=cut
*/
void
Perl_sv_utf8_encode(pTHX_ register SV *sv)
{
- sv_utf8_upgrade(sv);
+ (void) sv_utf8_upgrade(sv);
SvUTF8_off(sv);
}
+/*
+=for apidoc sv_utf8_decode
+
+Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
+turn off SvUTF8 if needed so that we see characters. Used as a building block
+for decode_utf8 in Encode.xs
+
+=cut
+*/
+
bool
Perl_sv_utf8_decode(pTHX_ register SV *sv)
{
if (SvPOK(sv)) {
- char *c;
- bool has_utf = FALSE;
- if (!sv_utf8_downgrade(sv, TRUE))
+ U8 *c;
+ U8 *e;
+
+ /* The octets may have got themselves encoded - get them back as
+ * bytes
+ */
+ if (!sv_utf8_downgrade(sv, TRUE))
return FALSE;
/* it is actually just a matter of turning the utf8 flag on, but
* we want to make sure everything inside is valid utf8 first.
*/
- c = SvPVX(sv);
- if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
+ c = (U8 *) SvPVX(sv);
+ if (!is_utf8_string(c, SvCUR(sv)+1))
return FALSE;
-
- while (c < SvEND(sv)) {
- if (*c++ & 0x80) {
+ e = (U8 *) SvEND(sv);
+ while (c < e) {
+ U8 ch = *c++;
+ if (!UTF8_IS_INVARIANT(ch)) {
SvUTF8_on(sv);
break;
}
return TRUE;
}
-
-/* Note: sv_setsv() should not be called with a source string that needs
- * to be reused, since it may destroy the source string if it is marked
- * 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>.
+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, so don't use this
+function if the source SV needs to be reused. Does not handle 'set' magic.
+Loosely speaking, it performs a copy-by-value, obliterating any previous
+content of the destination.
+
+You probably want to use one of the assortment of wrappers, such as
+C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
+C<SvSetMagicSV_nosteal>.
+
=cut
*/
+/* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
+ for binary compatibility only
+*/
void
Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
{
- dTHR;
+ sv_setsv_flags(dstr, sstr, SV_GMAGIC);
+}
+
+/*
+=for apidoc sv_setsv_flags
+
+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, so don't use this
+function if the source SV needs to be reused. Does not handle 'set' magic.
+Loosely speaking, it performs a copy-by-value, obliterating any previous
+content of the destination.
+If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
+C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
+implemented in terms of this function.
+
+You probably want to use one of the assortment of wrappers, such as
+C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
+C<SvSetMagicSV_nosteal>.
+
+This is the primary function for copying scalars, and most other
+copy-ish functions and macros use this underneath.
+
+=cut
+*/
+
+void
+Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
+{
register U32 sflags;
register int dtype;
register int stype;
SvIVX(dstr) = SvIVX(sstr);
if (SvIsUV(sstr))
SvIsUV_on(dstr);
- SvTAINT(dstr);
+ if (SvTAINTED(sstr))
+ SvTAINT(dstr);
return;
}
goto undef_sstr;
}
SvNVX(dstr) = SvNVX(sstr);
(void)SvNOK_only(dstr);
- SvTAINT(dstr);
+ if (SvTAINTED(sstr))
+ SvTAINT(dstr);
return;
}
goto undef_sstr;
char *name = GvNAME(sstr);
STRLEN len = GvNAMELEN(sstr);
sv_upgrade(dstr, SVt_PVGV);
- sv_magic(dstr, dstr, '*', Nullch, 0);
+ sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
GvNAME(dstr) = savepvn(name, len);
GvNAMELEN(dstr) = len;
&& GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
GvNAME(dstr));
+
+#ifdef GV_SHARED_CHECK
+ if (GvSHARED((GV*)dstr)) {
+ Perl_croak(aTHX_ PL_no_modify);
+ }
+#endif
+
(void)SvOK_off(dstr);
GvINTRO_off(dstr); /* one-shot flag */
gp_free((GV*)dstr);
GvGP(dstr) = gp_ref(GvGP(sstr));
- SvTAINT(dstr);
+ if (SvTAINTED(sstr))
+ SvTAINT(dstr);
if (GvIMPORTED(dstr) != GVf_IMPORTED
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
{
/* FALL THROUGH */
default:
- if (SvGMAGICAL(sstr)) {
+ if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
mg_get(sstr);
if (SvTYPE(sstr) != stype) {
stype = SvTYPE(sstr);
SV *dref = 0;
int intro = GvINTRO(dstr);
+#ifdef GV_SHARED_CHECK
+ if (GvSHARED((GV*)dstr)) {
+ Perl_croak(aTHX_ PL_no_modify);
+ }
+#endif
+
if (intro) {
- GP *gp;
- gp_free((GV*)dstr);
GvINTRO_off(dstr); /* one-shot flag */
- Newz(602,gp, 1, GP);
- GvGP(dstr) = gp_ref(gp);
- GvSV(dstr) = NEWSV(72,0);
GvLINE(dstr) = CopLINE(PL_curcop);
GvEGV(dstr) = (GV*)dstr;
}
if (!GvCVGEN((GV*)dstr) &&
(CvROOT(cv) || CvXSUB(cv)))
{
- SV *const_sv = cv_const_sv(cv);
- bool const_changed = TRUE;
- if(const_sv)
- const_changed = sv_cmp(const_sv,
- op_const_sv(CvSTART((CV*)sref),
- (CV*)sref));
/* ahem, death to those who redefine
* active sort subs */
if (PL_curstackinfo->si_type == PERLSI_SORT &&
Perl_croak(aTHX_
"Can't redefine active sort subroutine %s",
GvENAME((GV*)dstr));
- if ((const_changed && const_sv) || ckWARN(WARN_REDEFINE))
- Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
- "Constant subroutine %s redefined"
- : "Subroutine %s redefined",
- GvENAME((GV*)dstr));
+ /* Redefining a sub - warning is mandatory if
+ it was a const and its value changed. */
+ if (ckWARN(WARN_REDEFINE)
+ || (CvCONST(cv)
+ && (!CvCONST((CV*)sref)
+ || sv_cmp(cv_const_sv(cv),
+ cv_const_sv((CV*)sref)))))
+ {
+ Perl_warner(aTHX_ WARN_REDEFINE,
+ CvCONST(cv)
+ ? "Constant subroutine %s redefined"
+ : "Subroutine %s redefined",
+ GvENAME((GV*)dstr));
+ }
}
cv_ckproto(cv, (GV*)dstr,
SvPOK(sref) ? SvPVX(sref) : Nullch);
SvREFCNT_dec(dref);
if (intro)
SAVEFREESV(sref);
- SvTAINT(dstr);
+ if (SvTAINTED(sstr))
+ SvTAINT(dstr);
return;
}
if (SvPVX(dstr)) {
SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
SvROK_on(dstr);
if (sflags & SVp_NOK) {
- SvNOK_on(dstr);
+ SvNOKp_on(dstr);
+ /* Only set the public OK flag if the source has public OK. */
+ if (sflags & SVf_NOK)
+ SvFLAGS(dstr) |= SVf_NOK;
SvNVX(dstr) = SvNVX(sstr);
}
if (sflags & SVp_IOK) {
- (void)SvIOK_on(dstr);
- SvIVX(dstr) = SvIVX(sstr);
+ (void)SvIOKp_on(dstr);
+ if (sflags & SVf_IOK)
+ SvFLAGS(dstr) |= SVf_IOK;
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
+ SvIVX(dstr) = SvIVX(sstr);
}
if (SvAMAGIC(sstr)) {
SvAMAGIC_on(dstr);
if (SvTEMP(sstr) && /* slated for free anyway? */
SvREFCNT(sstr) == 1 && /* and no other references to it? */
!(sflags & SVf_OOK) && /* and not involved in OOK hack? */
- SvLEN(sstr)) /* and really is a string */
+ SvLEN(sstr) && /* and really is a string */
+ /* and won't be needed again, potentially */
+ !(PL_op && PL_op->op_type == OP_AASSIGN))
{
if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
if (SvOOK(dstr)) {
SvCUR_set(dstr, SvCUR(sstr));
SvTEMP_off(dstr);
- (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
+ (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
SvPV_set(sstr, Nullch);
SvLEN_set(sstr, 0);
SvCUR_set(sstr, 0);
SvTEMP_off(sstr);
}
- else { /* have to copy actual string */
+ else { /* have to copy actual string */
STRLEN len = SvCUR(sstr);
- SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
+ SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
Move(SvPVX(sstr),SvPVX(dstr),len,char);
SvCUR_set(dstr, len);
*SvEND(dstr) = '\0';
(void)SvPOK_only(dstr);
}
- if ((sflags & SVf_UTF8) && !IN_BYTE)
+ if (sflags & SVf_UTF8)
SvUTF8_on(dstr);
/*SUPPRESS 560*/
if (sflags & SVp_NOK) {
- SvNOK_on(dstr);
+ SvNOKp_on(dstr);
+ if (sflags & SVf_NOK)
+ SvFLAGS(dstr) |= SVf_NOK;
SvNVX(dstr) = SvNVX(sstr);
}
if (sflags & SVp_IOK) {
- (void)SvIOK_on(dstr);
- SvIVX(dstr) = SvIVX(sstr);
+ (void)SvIOKp_on(dstr);
+ if (sflags & SVf_IOK)
+ SvFLAGS(dstr) |= SVf_IOK;
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
- }
- }
- else if (sflags & SVp_NOK) {
- SvNVX(dstr) = SvNVX(sstr);
- (void)SvNOK_only(dstr);
- if (sflags & SVf_IOK) {
- (void)SvIOK_on(dstr);
SvIVX(dstr) = SvIVX(sstr);
- /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
- if (sflags & SVf_IVisUV)
- SvIsUV_on(dstr);
}
}
else if (sflags & SVp_IOK) {
- (void)SvIOK_only(dstr);
- SvIVX(dstr) = SvIVX(sstr);
+ if (sflags & SVf_IOK)
+ (void)SvIOK_only(dstr);
+ else {
+ (void)SvOK_off(dstr);
+ (void)SvIOKp_on(dstr);
+ }
+ /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
+ SvIVX(dstr) = SvIVX(sstr);
+ if (sflags & SVp_NOK) {
+ if (sflags & SVf_NOK)
+ (void)SvNOK_on(dstr);
+ else
+ (void)SvNOKp_on(dstr);
+ SvNVX(dstr) = SvNVX(sstr);
+ }
+ }
+ else if (sflags & SVp_NOK) {
+ if (sflags & SVf_NOK)
+ (void)SvNOK_only(dstr);
+ else {
+ (void)SvOK_off(dstr);
+ SvNOKp_on(dstr);
+ }
+ SvNVX(dstr) = SvNVX(sstr);
}
else {
if (dtype == SVt_PVGV) {
else
(void)SvOK_off(dstr);
}
- SvTAINT(dstr);
+ if (SvTAINTED(sstr))
+ SvTAINT(dstr);
}
/*
Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
register char *dptr;
- assert(len >= 0); /* STRLEN is probably unsigned, so this may
- elicit a warning, but it won't hurt. */
+
SV_CHECK_THINKFIRST(sv);
if (!ptr) {
(void)SvOK_off(sv);
return;
}
+ else {
+ /* len is STRLEN which is unsigned, need to copy to signed */
+ IV iv = len;
+ if (iv < 0)
+ Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
+ }
(void)SvUPGRADE(sv, SVt_PV);
SvGROW(sv, len + 1);
Move(ptr,dptr,len,char);
dptr[len] = '\0';
SvCUR_set(sv, len);
- (void)SvPOK_only(sv); /* validate pointer */
+ (void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
}
SvGROW(sv, len + 1);
Move(ptr,SvPVX(sv),len+1,char);
SvCUR_set(sv, len);
- (void)SvPOK_only(sv); /* validate pointer */
+ (void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
}
SvCUR_set(sv, len);
SvLEN_set(sv, len+1);
*SvEND(sv) = '\0';
- (void)SvPOK_only(sv); /* validate pointer */
+ (void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
}
SvSETMAGIC(sv);
}
+/*
+=for apidoc sv_force_normal_flags
+
+Undo various types of fakery on an SV: if the PV is a shared string, make
+a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
+an xpvmg. The C<flags> parameter gets passed to C<sv_unref_flags()>
+when unrefing. C<sv_force_normal> calls this function with flags set to 0.
+
+=cut
+*/
+
void
-Perl_sv_force_normal(pTHX_ register SV *sv)
+Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
{
if (SvREADONLY(sv)) {
- dTHR;
if (SvFAKE(sv)) {
char *pvx = SvPVX(sv);
STRLEN len = SvCUR(sv);
*SvEND(sv) = '\0';
SvFAKE_off(sv);
SvREADONLY_off(sv);
- unsharepvn(pvx,len,hash);
+ unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
}
else if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
}
if (SvROK(sv))
- sv_unref(sv);
+ sv_unref_flags(sv, flags);
else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
sv_unglob(sv);
}
/*
+=for apidoc sv_force_normal
+
+Undo various types of fakery on an SV: if the PV is a shared string, make
+a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
+an xpvmg. See also C<sv_force_normal_flags>.
+
+=cut
+*/
+
+void
+Perl_sv_force_normal(pTHX_ register SV *sv)
+{
+ sv_force_normal_flags(sv, 0);
+}
+
+/*
=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.
+string. Uses the "OOK hack".
=cut
*/
void
-Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
-
-
+Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
{
register STRLEN 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>.
+C<len> indicates number of bytes to copy. If the SV has the UTF8
+status set, then the bytes appended should be valid UTF8.
+Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
=cut
*/
+/* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
+ for binary compatibility only
+*/
void
-Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
+Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
{
- STRLEN tlen;
- char *junk;
+ sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
+}
- junk = SvPV_force(sv, tlen);
- SvGROW(sv, tlen + len + 1);
- if (ptr == junk)
- ptr = SvPVX(sv);
- Move(ptr,SvPVX(sv)+tlen,len,char);
- SvCUR(sv) += len;
- *SvEND(sv) = '\0';
- (void)SvPOK_only_UTF8(sv); /* validate pointer */
- SvTAINT(sv);
+/*
+=for apidoc sv_catpvn_flags
+
+Concatenates the string onto the end of the string which is in the SV. The
+C<len> indicates number of bytes to copy. If the SV has the UTF8
+status set, then the bytes appended should be valid UTF8.
+If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
+appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
+in terms of this function.
+
+=cut
+*/
+
+void
+Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
+{
+ STRLEN dlen;
+ char *dstr;
+
+ dstr = SvPV_force_flags(dsv, dlen, flags);
+ SvGROW(dsv, dlen + slen + 1);
+ if (sstr == dstr)
+ sstr = SvPVX(dsv);
+ Move(sstr, SvPVX(dsv) + dlen, slen, char);
+ SvCUR(dsv) += slen;
+ *SvEND(dsv) = '\0';
+ (void)SvPOK_only_UTF8(dsv); /* validate pointer */
+ SvTAINT(dsv);
}
/*
/*
=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>.
+Concatenates the string from SV C<ssv> onto the end of the string in
+SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
+not 'set' magic. See C<sv_catsv_mg>.
-=cut
-*/
+=cut */
+/* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
+ for binary compatibility only
+*/
void
Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
{
- char *s;
- STRLEN len;
- if (!sstr)
+ sv_catsv_flags(dstr, sstr, SV_GMAGIC);
+}
+
+/*
+=for apidoc sv_catsv_flags
+
+Concatenates the string from SV C<ssv> onto the end of the string in
+SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
+bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
+and C<sv_catsv_nomg> are implemented in terms of this function.
+
+=cut */
+
+void
+Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
+{
+ char *spv;
+ STRLEN slen;
+ if (!ssv)
return;
- if ((s = SvPV(sstr, len))) {
- if (DO_UTF8(sstr)) {
- sv_utf8_upgrade(dstr);
- sv_catpvn(dstr,s,len);
- SvUTF8_on(dstr);
+ if ((spv = SvPV(ssv, slen))) {
+ bool sutf8 = DO_UTF8(ssv);
+ bool dutf8;
+
+ if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
+ mg_get(dsv);
+ dutf8 = DO_UTF8(dsv);
+
+ if (dutf8 != sutf8) {
+ if (dutf8) {
+ /* Not modifying source SV, so taking a temporary copy. */
+ SV* csv = sv_2mortal(newSVpvn(spv, slen));
+
+ sv_utf8_upgrade(csv);
+ spv = SvPV(csv, slen);
+ }
+ else
+ sv_utf8_upgrade_nomg(dsv);
}
- else
- sv_catpvn(dstr,s,len);
+ sv_catpvn_nomg(dsv, spv, slen);
}
}
*/
void
-Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
+Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
{
- sv_catsv(dstr,sstr);
- SvSETMAGIC(dstr);
+ sv_catsv(dsv,ssv);
+ SvSETMAGIC(dsv);
}
/*
=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>.
+If the SV has the UTF8 status set, then the bytes appended should be
+valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
-=cut
-*/
+=cut */
void
Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
SvSETMAGIC(sv);
}
+/*
+=for apidoc newSV
+
+Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
+with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
+macro.
+
+=cut
+*/
+
SV *
Perl_newSV(pTHX_ STRLEN len)
{
return sv;
}
-/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
-
/*
=for apidoc sv_magic
-Adds magic to an SV.
+Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
+then adds a new magic item of type C<how> to the head of the magic list.
+
+C<name> is assumed to contain an C<SV*> if C<(name && namelen == HEf_SVKEY)>
=cut
*/
MAGIC* mg;
if (SvREADONLY(sv)) {
- dTHR;
- if (PL_curcop != &PL_compiling && !strchr("gBf", how))
+ if (PL_curcop != &PL_compiling
+ && how != PERL_MAGIC_regex_global
+ && how != PERL_MAGIC_bm
+ && how != PERL_MAGIC_fm
+ && how != PERL_MAGIC_sv
+ )
+ {
Perl_croak(aTHX_ PL_no_modify);
+ }
}
- if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
+ if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
- if (how == 't')
+ if (how == PERL_MAGIC_taint)
mg->mg_len |= 1;
return;
}
}
Newz(702,mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(sv);
-
SvMAGIC(sv) = mg;
- if (!obj || obj == sv || how == '#' || how == 'r')
+
+ /* Some magic sontains a reference loop, where the sv and object refer to
+ each other. To prevent a avoid a reference loop that would prevent such
+ objects being freed, we look for such loops and if we find one we avoid
+ incrementing the object refcount. */
+ if (!obj || obj == sv ||
+ how == PERL_MAGIC_arylen ||
+ how == PERL_MAGIC_qr ||
+ (SvTYPE(obj) == SVt_PVGV &&
+ (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
+ GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
+ GvFORM(obj) == (CV*)sv)))
+ {
mg->mg_obj = obj;
+ }
else {
- dTHR;
mg->mg_obj = SvREFCNT_inc(obj);
mg->mg_flags |= MGf_REFCOUNTED;
}
mg->mg_type = how;
mg->mg_len = namlen;
- if (name)
+ if (name) {
if (namlen >= 0)
mg->mg_ptr = savepvn(name, namlen);
else if (namlen == HEf_SVKEY)
mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
+ }
switch (how) {
- case 0:
+ case PERL_MAGIC_sv:
mg->mg_virtual = &PL_vtbl_sv;
break;
- case 'A':
+ case PERL_MAGIC_overload:
mg->mg_virtual = &PL_vtbl_amagic;
break;
- case 'a':
+ case PERL_MAGIC_overload_elem:
mg->mg_virtual = &PL_vtbl_amagicelem;
break;
- case 'c':
- mg->mg_virtual = 0;
+ case PERL_MAGIC_overload_table:
+ mg->mg_virtual = &PL_vtbl_ovrld;
break;
- case 'B':
+ case PERL_MAGIC_bm:
mg->mg_virtual = &PL_vtbl_bm;
break;
- case 'D':
+ case PERL_MAGIC_regdata:
mg->mg_virtual = &PL_vtbl_regdata;
break;
- case 'd':
+ case PERL_MAGIC_regdatum:
mg->mg_virtual = &PL_vtbl_regdatum;
break;
- case 'E':
+ case PERL_MAGIC_env:
mg->mg_virtual = &PL_vtbl_env;
break;
- case 'f':
+ case PERL_MAGIC_fm:
mg->mg_virtual = &PL_vtbl_fm;
break;
- case 'e':
+ case PERL_MAGIC_envelem:
mg->mg_virtual = &PL_vtbl_envelem;
break;
- case 'g':
+ case PERL_MAGIC_regex_global:
mg->mg_virtual = &PL_vtbl_mglob;
break;
- case 'I':
+ case PERL_MAGIC_isa:
mg->mg_virtual = &PL_vtbl_isa;
break;
- case 'i':
+ case PERL_MAGIC_isaelem:
mg->mg_virtual = &PL_vtbl_isaelem;
break;
- case 'k':
+ case PERL_MAGIC_nkeys:
mg->mg_virtual = &PL_vtbl_nkeys;
break;
- case 'L':
+ case PERL_MAGIC_dbfile:
SvRMAGICAL_on(sv);
mg->mg_virtual = 0;
break;
- case 'l':
+ case PERL_MAGIC_dbline:
mg->mg_virtual = &PL_vtbl_dbline;
break;
#ifdef USE_THREADS
- case 'm':
+ case PERL_MAGIC_mutex:
mg->mg_virtual = &PL_vtbl_mutex;
break;
#endif /* USE_THREADS */
#ifdef USE_LOCALE_COLLATE
- case 'o':
+ case PERL_MAGIC_collxfrm:
mg->mg_virtual = &PL_vtbl_collxfrm;
break;
#endif /* USE_LOCALE_COLLATE */
- case 'P':
+ case PERL_MAGIC_tied:
mg->mg_virtual = &PL_vtbl_pack;
break;
- case 'p':
- case 'q':
+ case PERL_MAGIC_tiedelem:
+ case PERL_MAGIC_tiedscalar:
mg->mg_virtual = &PL_vtbl_packelem;
break;
- case 'r':
+ case PERL_MAGIC_qr:
mg->mg_virtual = &PL_vtbl_regexp;
break;
- case 'S':
+ case PERL_MAGIC_sig:
mg->mg_virtual = &PL_vtbl_sig;
break;
- case 's':
+ case PERL_MAGIC_sigelem:
mg->mg_virtual = &PL_vtbl_sigelem;
break;
- case 't':
+ case PERL_MAGIC_taint:
mg->mg_virtual = &PL_vtbl_taint;
mg->mg_len = 1;
break;
- case 'U':
+ case PERL_MAGIC_uvar:
mg->mg_virtual = &PL_vtbl_uvar;
break;
- case 'v':
+ case PERL_MAGIC_vec:
mg->mg_virtual = &PL_vtbl_vec;
break;
- case 'x':
+ case PERL_MAGIC_substr:
mg->mg_virtual = &PL_vtbl_substr;
break;
- case 'y':
+ case PERL_MAGIC_defelem:
mg->mg_virtual = &PL_vtbl_defelem;
break;
- case '*':
+ case PERL_MAGIC_glob:
mg->mg_virtual = &PL_vtbl_glob;
break;
- case '#':
+ case PERL_MAGIC_arylen:
mg->mg_virtual = &PL_vtbl_arylen;
break;
- case '.':
+ case PERL_MAGIC_pos:
mg->mg_virtual = &PL_vtbl_pos;
break;
- case '<':
+ case PERL_MAGIC_backref:
mg->mg_virtual = &PL_vtbl_backref;
break;
- case '~': /* Reserved for use by extensions not perl internals. */
+ case PERL_MAGIC_ext:
+ /* Reserved for use by extensions not perl internals. */
/* 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. */
SvRMAGICAL_on(sv);
break;
default:
- Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
+ Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
}
mg_magical(sv);
if (SvGMAGICAL(sv))
/*
=for apidoc sv_unmagic
-Removes magic from an SV.
+Removes all magic of type C<type> from an SV.
=cut
*/
*mgp = mg->mg_moremagic;
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
- if (mg->mg_ptr && mg->mg_type != 'g')
+ if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
if (mg->mg_len >= 0)
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
SvREFCNT_dec((SV*)mg->mg_ptr);
+ }
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
}
if (!SvMAGIC(sv)) {
SvMAGICAL_off(sv);
- SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
}
return 0;
/*
=for apidoc sv_rvweaken
-Weaken a reference.
+Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
+referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
+push a back-reference to this RV onto the array of backreferences
+associated with that magic.
=cut
*/
if (!SvROK(sv))
Perl_croak(aTHX_ "Can't weaken a nonreference");
else if (SvWEAKREF(sv)) {
- dTHR;
if (ckWARN(WARN_MISC))
Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
return sv;
return sv;
}
+/* Give tsv backref magic if it hasn't already got it, then push a
+ * back-reference to sv onto the array associated with the backref magic.
+ */
+
STATIC void
S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
{
AV *av;
MAGIC *mg;
- if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
+ if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
av = (AV*)mg->mg_obj;
else {
av = newAV();
- sv_magic(tsv, (SV*)av, '<', NULL, 0);
+ sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
SvREFCNT_dec(av); /* for sv_magic */
}
av_push(av,sv);
}
+/* delete a back-reference to ourselves from the backref magic associated
+ * with the SV we point to.
+ */
+
STATIC void
S_sv_del_backref(pTHX_ SV *sv)
{
I32 i;
SV *tsv = SvRV(sv);
MAGIC *mg;
- if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
+ if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
Perl_croak(aTHX_ "panic: del_backref");
av = (AV *)mg->mg_obj;
svp = AvARRAY(av);
=for apidoc sv_replace
Make the first argument a copy of the second, then delete the original.
+The target SV physically takes over ownership of the body of the source SV
+and inherits its flags; however, the target keeps any magic it owns,
+and any magic in the source is discarded.
+Note that this a rather specialist SV copying operation; most of the
+time you'll want to use C<sv_setsv> or one of its many macro front-ends.
=cut
*/
void
Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
{
- dTHR;
U32 refcnt = SvREFCNT(sv);
SV_CHECK_THINKFIRST(sv);
if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
/*
=for apidoc sv_clear
-Clear an SV, making it empty. Does not free the memory used by the SV
-itself.
+Clear an SV: call any destructors, free up any memory used by the body,
+and free the body itself. The SV's head is I<not> freed, although
+its type is set to all 1's so that it won't inadvertently be assumed
+to be live during global destruction etc.
+This function should only be called when REFCNT is zero. Most of the time
+you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
+instead.
=cut
*/
assert(SvREFCNT(sv) == 0);
if (SvOBJECT(sv)) {
- dTHR;
if (PL_defstash) { /* Still have a symbol table? */
- djSP;
- GV* destructor;
+ dSP;
+ CV* destructor;
SV tmpref;
Zero(&tmpref, 1, SV);
SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
SvREFCNT(&tmpref) = 1;
- do {
+ do {
stash = SvSTASH(sv);
- destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
+ destructor = StashHANDLER(stash,DESTROY);
if (destructor) {
ENTER;
PUSHSTACKi(PERLSI_DESTROY);
PUSHMARK(SP);
PUSHs(&tmpref);
PUTBACK;
- call_sv((SV*)GvCV(destructor),
- G_DISCARD|G_EVAL|G_KEEPERR);
+ call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
SvREFCNT(sv)--;
POPSTACK;
SPAGAIN;
--PL_sv_objcount; /* XXX Might want something more general */
}
}
- if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
- mg_free(sv);
+ if (SvTYPE(sv) >= SVt_PVMG) {
+ if (SvMAGIC(sv))
+ mg_free(sv);
+ if (SvFLAGS(sv) & SVpad_TYPED)
+ SvREFCNT_dec(SvSTASH(sv));
+ }
stash = NULL;
switch (SvTYPE(sv)) {
case SVt_PVIO:
else if (SvPVX(sv) && SvLEN(sv))
Safefree(SvPVX(sv));
else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
- unsharepvn(SvPVX(sv),SvCUR(sv),SvUVX(sv));
+ unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
SvFAKE_off(sv);
}
break;
SvFLAGS(sv) |= SVTYPEMASK;
}
+/*
+=for apidoc sv_newref
+
+Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
+instead.
+
+=cut
+*/
+
SV *
Perl_sv_newref(pTHX_ SV *sv)
{
/*
=for apidoc sv_free
-Free the memory used by an SV.
+Decrement an SV's reference count, and if it drops to zero, call
+C<sv_clear> to invoke destructors and free up any memory used by
+the body; finally, deallocate the SV's head itself.
+Normally called via a wrapper macro C<SvREFCNT_dec>.
=cut
*/
void
Perl_sv_free(pTHX_ SV *sv)
{
- dTHR;
int refcount_is_zero;
if (!sv)
return;
if (SvREFCNT(sv) == 0) {
if (SvFLAGS(sv) & SVf_BREAK)
+ /* this SV's refcnt has been artificially decremented to
+ * trigger cleanup */
return;
if (PL_in_clean_all) /* All is fair */
return;
/*
=for apidoc sv_len
-Returns the length of the string in the SV. See also C<SvCUR>.
+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.
=cut
*/
=for apidoc sv_len_utf8
Returns the number of characters in the string in an SV, counting wide
-UTF8 bytes as a single character.
+UTF8 bytes as a single character. Handles magic and type coercion.
=cut
*/
STRLEN
Perl_sv_len_utf8(pTHX_ register SV *sv)
{
- U8 *s;
- U8 *send;
- STRLEN len;
-
if (!sv)
return 0;
-#ifdef NOTYET
if (SvGMAGICAL(sv))
- len = mg_length(sv);
+ return mg_length(sv);
else
-#endif
- s = (U8*)SvPV(sv, len);
- send = s + len;
- len = 0;
- while (s < send) {
- s += UTF8SKIP(s);
- len++;
+ {
+ STRLEN len;
+ U8 *s = (U8*)SvPV(sv, len);
+
+ return Perl_utf8_length(aTHX_ s, s + len);
}
- return len;
}
+/*
+=for apidoc sv_pos_u2b
+
+Converts the value pointed to by offsetp from a count of UTF8 chars from
+the start of the string, to a count of the equivalent number of bytes; if
+lenp is non-zero, it does the same to lenp, but this time starting from
+the offset, rather than from the start of the string. Handles magic and
+type coercion.
+
+=cut
+*/
+
void
Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
{
return;
}
+/*
+=for apidoc sv_pos_b2u
+
+Converts the value pointed to by offsetp from a count of bytes from the
+start of the string, to a count of the equivalent number of UTF8 chars.
+Handles magic and type coercion.
+
+=cut
+*/
+
void
Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
{
s = (U8*)SvPV(sv, len);
if (len < *offsetp)
- Perl_croak(aTHX_ "panic: bad byte offset");
+ Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
send = s + *offsetp;
len = 0;
while (s < send) {
- s += UTF8SKIP(s);
- ++len;
- }
- if (s != send) {
- dTHR;
- if (ckWARN_d(WARN_UTF8))
- Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
- --len;
+ STRLEN n;
+ /* Call utf8n_to_uvchr() to validate the sequence */
+ utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
+ if (n > 0) {
+ s += n;
+ len++;
+ }
+ else
+ break;
}
*offsetp = len;
return;
=for apidoc sv_eq
Returns a boolean indicating whether the strings in the two SVs are
-identical.
+identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
+coerce its args to strings if necessary.
=cut
*/
char *pv2;
STRLEN cur2;
I32 eq = 0;
- bool pv1tmp = FALSE;
- bool pv2tmp = FALSE;
+ char *tpv = Nullch;
if (!sv1) {
pv1 = "";
pv2 = SvPV(sv2, cur2);
/* do not utf8ize the comparands as a side-effect */
- if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE && 0) {
+ if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
+ bool is_utf8 = TRUE;
+ /* UTF-8ness differs */
+ if (PL_hints & HINT_UTF8_DISTINCT)
+ return FALSE;
+
if (SvUTF8(sv1)) {
- pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
- pv2tmp = TRUE;
+ /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
+ char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
+ if (pv != pv1)
+ pv1 = tpv = pv;
}
else {
- pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
- pv1tmp = TRUE;
+ /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
+ char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
+ if (pv != pv2)
+ pv2 = tpv = pv;
+ }
+ if (is_utf8) {
+ /* Downgrade not possible - cannot be eq */
+ return FALSE;
}
}
if (cur1 == cur2)
eq = memEQ(pv1, pv2, cur1);
- if (pv1tmp)
- Safefree(pv1);
- if (pv2tmp)
- Safefree(pv2);
+ if (tpv != Nullch)
+ Safefree(tpv);
return eq;
}
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>.
+C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
+coerce its args to strings if necessary. See also C<sv_cmp_locale>.
=cut
*/
pv2 = SvPV(sv2, cur2);
/* do not utf8ize the comparands as a side-effect */
- if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
+ if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
+ if (PL_hints & HINT_UTF8_DISTINCT)
+ return SvUTF8(sv1) ? 1 : -1;
+
if (SvUTF8(sv1)) {
pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
pv2tmp = TRUE;
/*
=for apidoc sv_cmp_locale
-Compares the strings in two SVs in a locale-aware manner. See
-L</sv_cmp_locale>
+Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
+'use bytes' aware, handles get magic, and will coerce its args to strings
+if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
=cut
*/
return sv_cmp(sv1, sv2);
}
+
#ifdef USE_LOCALE_COLLATE
+
/*
- * Any scalar variable may carry an 'o' magic that contains the
- * scalar data of the variable transformed to such a format that
- * a normal memory comparison can be used to compare the data
- * according to the locale settings.
- */
+=for apidoc sv_collxfrm
+
+Add Collate Transform magic to an SV if it doesn't already have it.
+
+Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
+scalar data of the variable, but transformed to such a format that a normal
+memory comparison can be used to compare the data according to the locale
+settings.
+
+=cut
+*/
+
char *
Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
{
MAGIC *mg;
- mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
+ mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
char *s, *xf;
STRLEN len, xlen;
return xf + sizeof(PL_collation_ix);
}
if (! mg) {
- sv_magic(sv, 0, 'o', 0, 0);
- mg = mg_find(sv, 'o');
+ sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
+ mg = mg_find(sv, PERL_MAGIC_collxfrm);
assert(mg);
}
mg->mg_ptr = xf;
char *
Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
{
- dTHR;
char *rsptr;
STRLEN rslen;
register STDCHAR rslast;
register STDCHAR *bp;
register I32 cnt;
- I32 i;
+ I32 i = 0;
SV_CHECK_THINKFIRST(sv);
(void)SvUPGRADE(sv, SVt_PV);
#endif
SvCUR_set(sv, bytesread);
buffer[bytesread] = '\0';
+ if (PerlIO_isutf8(fp))
+ SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
return(SvCUR(sv) ? SvPVX(sv) : Nullch);
}
else if (RsPARA(PL_rs)) {
rsptr = "\n\n";
rslen = 2;
}
- else
- rsptr = SvPV(PL_rs, rslen);
+ else {
+ /* Get $/ i.e. PL_rs into same encoding as stream wants */
+ if (PerlIO_isutf8(fp)) {
+ rsptr = SvPVutf8(PL_rs, rslen);
+ }
+ else {
+ if (SvUTF8(PL_rs)) {
+ if (!sv_utf8_downgrade(PL_rs, TRUE)) {
+ Perl_croak(aTHX_ "Wide character in $/");
+ }
+ }
+ rsptr = SvPV(PL_rs, rslen);
+ }
+ }
+
rslast = rslen ? rsptr[rslen - 1] : '\0';
if (RsPARA(PL_rs)) { /* have to do this both before and after */
}
}
+ if (PerlIO_isutf8(fp))
+ SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
+
return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
}
-
/*
=for apidoc sv_inc
-Auto-increment of the value in the SV.
+Auto-increment of the value in the SV, doing string to numeric conversion
+if necessary. Handles 'get' magic.
=cut
*/
mg_get(sv);
if (SvTHINKFIRST(sv)) {
if (SvREADONLY(sv)) {
- dTHR;
if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
}
}
}
flags = SvFLAGS(sv);
- if (flags & SVp_NOK) {
- (void)SvNOK_only(sv);
- SvNVX(sv) += 1.0;
- return;
- }
- if (flags & SVp_IOK) {
+ if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
+ /* It's (privately or publicly) a float, but not tested as an
+ integer, so test it to see. */
+ (void) SvIV(sv);
+ flags = SvFLAGS(sv);
+ }
+ if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
+ /* It's publicly an integer, or privately an integer-not-float */
+ oops_its_int:
if (SvIsUV(sv)) {
if (SvUVX(sv) == UV_MAX)
sv_setnv(sv, (NV)UV_MAX + 1.0);
++SvUVX(sv);
} else {
if (SvIVX(sv) == IV_MAX)
- sv_setnv(sv, (NV)IV_MAX + 1.0);
+ sv_setuv(sv, (UV)IV_MAX + 1);
else {
(void)SvIOK_only(sv);
++SvIVX(sv);
}
return;
}
- if (!(flags & SVp_POK) || !*SvPVX(sv)) {
- if ((flags & SVTYPEMASK) < SVt_PVNV)
- sv_upgrade(sv, SVt_NV);
- SvNVX(sv) = 1.0;
+ if (flags & SVp_NOK) {
(void)SvNOK_only(sv);
+ SvNVX(sv) += 1.0;
+ return;
+ }
+
+ if (!(flags & SVp_POK) || !*SvPVX(sv)) {
+ if ((flags & SVTYPEMASK) < SVt_PVIV)
+ sv_upgrade(sv, SVt_IV);
+ (void)SvIOK_only(sv);
+ SvIVX(sv) = 1;
return;
}
d = SvPVX(sv);
while (isALPHA(*d)) d++;
while (isDIGIT(*d)) d++;
if (*d) {
- sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
+#ifdef PERL_PRESERVE_IVUV
+ /* Got to punt this an an integer if needs be, but we don't issue
+ warnings. Probably ought to make the sv_iv_please() that does
+ the conversion if possible, and silently. */
+ int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
+ if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
+ /* Need to try really hard to see if it's an integer.
+ 9.22337203685478e+18 is an integer.
+ but "9.22337203685478e+18" + 0 is UV=9223372036854779904
+ so $a="9.22337203685478e+18"; $a+0; $a++
+ needs to be the same as $a="9.22337203685478e+18"; $a++
+ or we go insane. */
+
+ (void) sv_2iv(sv);
+ if (SvIOK(sv))
+ goto oops_its_int;
+
+ /* sv_2iv *should* have made this an NV */
+ if (flags & SVp_NOK) {
+ (void)SvNOK_only(sv);
+ SvNVX(sv) += 1.0;
+ return;
+ }
+ /* I don't think we can get here. Maybe I should assert this
+ And if we do get here I suspect that sv_setnv will croak. NWC
+ Fall through. */
+#if defined(USE_LONG_DOUBLE)
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
+ SvPVX(sv), SvIVX(sv), SvNVX(sv)));
+#else
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
+ SvPVX(sv), SvIVX(sv), SvNVX(sv)));
+#endif
+ }
+#endif /* PERL_PRESERVE_IVUV */
+ sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
return;
}
d--;
/*
=for apidoc sv_dec
-Auto-decrement of the value in the SV.
+Auto-decrement of the value in the SV, doing string to numeric conversion
+if necessary. Handles 'get' magic.
=cut
*/
mg_get(sv);
if (SvTHINKFIRST(sv)) {
if (SvREADONLY(sv)) {
- dTHR;
if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
}
sv_setiv(sv, i);
}
}
+ /* Unlike sv_inc we don't have to worry about string-never-numbers
+ and keeping them magic. But we mustn't warn on punting */
flags = SvFLAGS(sv);
- if (flags & SVp_NOK) {
- SvNVX(sv) -= 1.0;
- (void)SvNOK_only(sv);
- return;
- }
- if (flags & SVp_IOK) {
+ if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
+ /* It's publicly an integer, or privately an integer-not-float */
+ oops_its_int:
if (SvIsUV(sv)) {
if (SvUVX(sv) == 0) {
(void)SvIOK_only(sv);
}
return;
}
+ if (flags & SVp_NOK) {
+ SvNVX(sv) -= 1.0;
+ (void)SvNOK_only(sv);
+ return;
+ }
if (!(flags & SVp_POK)) {
if ((flags & SVTYPEMASK) < SVt_PVNV)
sv_upgrade(sv, SVt_NV);
(void)SvNOK_only(sv);
return;
}
+#ifdef PERL_PRESERVE_IVUV
+ {
+ int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
+ if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
+ /* Need to try really hard to see if it's an integer.
+ 9.22337203685478e+18 is an integer.
+ but "9.22337203685478e+18" + 0 is UV=9223372036854779904
+ so $a="9.22337203685478e+18"; $a+0; $a--
+ needs to be the same as $a="9.22337203685478e+18"; $a--
+ or we go insane. */
+
+ (void) sv_2iv(sv);
+ if (SvIOK(sv))
+ goto oops_its_int;
+
+ /* sv_2iv *should* have made this an NV */
+ if (flags & SVp_NOK) {
+ (void)SvNOK_only(sv);
+ SvNVX(sv) -= 1.0;
+ return;
+ }
+ /* I don't think we can get here. Maybe I should assert this
+ And if we do get here I suspect that sv_setnv will croak. NWC
+ Fall through. */
+#if defined(USE_LONG_DOUBLE)
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
+ SvPVX(sv), SvIVX(sv), SvNVX(sv)));
+#else
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
+ SvPVX(sv), SvIVX(sv), SvNVX(sv)));
+#endif
+ }
+ }
+#endif /* PERL_PRESERVE_IVUV */
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.
+Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
+The new SV is marked as mortal. It will be destroyed when the current
+context ends. See also C<sv_newmortal> and C<sv_2mortal>.
=cut
*/
SV *
Perl_sv_mortalcopy(pTHX_ SV *oldstr)
{
- dTHR;
register SV *sv;
new_SV(sv);
/*
=for apidoc sv_newmortal
-Creates a new SV which is mortal. The reference count of the SV is set to 1.
+Creates a new null SV which is mortal. The reference count of the SV is
+set to 1. It will be destroyed when the current context ends. See
+also C<sv_mortalcopy> and C<sv_2mortal>.
=cut
*/
SV *
Perl_sv_newmortal(pTHX)
{
- dTHR;
register SV *sv;
new_SV(sv);
/*
=for apidoc sv_2mortal
-Marks an SV as mortal. The SV will be destroyed when the current context
-ends.
+Marks an existing SV as mortal. The SV will be destroyed when the current
+context ends. See also C<sv_newmortal> and C<sv_mortalcopy>.
=cut
*/
-/* same thing without the copying */
-
SV *
Perl_sv_2mortal(pTHX_ register SV *sv)
{
- dTHR;
if (!sv)
return sv;
if (SvREADONLY(sv) && SvIMMORTAL(sv))
/*
=for apidoc newSVpvn_share
-Creates a new SV and populates it with a string from
-the string table. Turns on READONLY and FAKE.
-The idea here is that as string table is used for shared hash
-keys these strings will have SvPVX == HeKEY and hash lookup
-will avoid string compare.
+Creates a new SV with its SvPVX pointing to a shared string in the string
+table. If the string does not already exist in the table, it is created
+first. Turns on READONLY and FAKE. The string's hash is stored in the UV
+slot of the SV; if the C<hash> parameter is non-zero, that value is used;
+otherwise the hash is computed. The idea here is that as the string table
+is used for shared hash keys these strings will have SvPVX == HeKEY and
+hash lookup will avoid string compare.
=cut
*/
SV *
-Perl_newSVpvn_share(pTHX_ const char *src, STRLEN len, U32 hash)
+Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
{
register SV *sv;
+ bool is_utf8 = FALSE;
+ if (len < 0) {
+ len = -len;
+ is_utf8 = TRUE;
+ }
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
+ STRLEN tmplen = len;
+ /* See the note in hv.c:hv_fetch() --jhi */
+ src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
+ len = tmplen;
+ }
if (!hash)
PERL_HASH(hash, src, len);
new_SV(sv);
sv_upgrade(sv, SVt_PVIV);
- SvPVX(sv) = sharepvn(src, len, hash);
+ SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
SvCUR(sv) = len;
SvUVX(sv) = hash;
SvLEN(sv) = 0;
SvREADONLY_on(sv);
SvFAKE_on(sv);
SvPOK_on(sv);
+ if (is_utf8)
+ SvUTF8_on(sv);
return sv;
}
+
#if defined(PERL_IMPLICIT_CONTEXT)
+
+/* pTHX_ magic can't cope with varargs, so this is a no-context
+ * version of the main function, (which may itself be aliased to us).
+ * Don't access this version directly.
+ */
+
SV *
Perl_newSVpvf_nocontext(const char* pat, ...)
{
/*
=for apidoc newSVpvf
-Creates a new SV an initialize it with the string formatted like
+Creates a new SV and initializes it with the string formatted like
C<sprintf>.
=cut
return sv;
}
+/* backend for newSVpvf() and newSVpvf_nocontext() */
+
SV *
Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
{
SV *
Perl_newRV_noinc(pTHX_ SV *tmpRef)
{
- dTHR;
register SV *sv;
new_SV(sv);
return sv;
}
-/* newRV_inc is #defined to newRV in sv.h */
+/* newRV_inc is the offical function name to use now.
+ * newRV_inc is in fact #defined to newRV in sv.h
+ */
+
SV *
Perl_newRV(pTHX_ SV *tmpRef)
{
=for apidoc newSVsv
Creates a new SV which is an exact duplicate of the original SV.
+(Uses C<sv_setsv>).
=cut
*/
-/* make an exact duplicate of old */
-
SV *
Perl_newSVsv(pTHX_ register SV *old)
{
- dTHR;
register SV *sv;
if (!old)
return sv;
}
+/*
+=for apidoc sv_reset
+
+Underlying implementation for the C<reset> Perl function.
+Note that the perl-level function is vaguely deprecated.
+
+=cut
+*/
+
void
Perl_sv_reset(pTHX_ register char *s, HV *stash)
{
}
if (GvHV(gv) && !HvNAME(GvHV(gv))) {
hv_clear(GvHV(gv));
-#if !defined( VMS) && !defined(EPOC) /* VMS has no environ array */
+#ifdef USE_ENVIRON_ARRAY
if (gv == PL_envgv)
environ[0] = Nullch;
#endif
}
}
+/*
+=for apidoc sv_2io
+
+Using various gambits, try to get an IO from an SV: the IO slot if its a
+GV; or the recursive result if we're an RV; or the IO slot of the symbol
+named after the PV if we're a string.
+
+=cut
+*/
+
IO*
Perl_sv_2io(pTHX_ SV *sv)
{
return io;
}
+/*
+=for apidoc sv_2cv
+
+Using various gambits, try to get a CV from an SV; in addition, try if
+possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
+
+=cut
+*/
+
CV *
Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
{
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvROK(sv)) {
- dTHR;
SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
tryAMAGICunDEREF(to_cv);
=for apidoc sv_true
Returns true if the SV has a true value by Perl's rules.
+Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
+instead use an in-line version.
=cut
*/
I32
Perl_sv_true(pTHX_ register SV *sv)
{
- dTHR;
if (!sv)
return 0;
if (SvPOK(sv)) {
}
}
+/*
+=for apidoc sv_iv
+
+A private implementation of the C<SvIVx> macro for compilers which can't
+cope with complex macro expressions. Always use the macro instead.
+
+=cut
+*/
+
IV
Perl_sv_iv(pTHX_ register SV *sv)
{
return sv_2iv(sv);
}
+/*
+=for apidoc sv_uv
+
+A private implementation of the C<SvUVx> macro for compilers which can't
+cope with complex macro expressions. Always use the macro instead.
+
+=cut
+*/
+
UV
Perl_sv_uv(pTHX_ register SV *sv)
{
return sv_2uv(sv);
}
+/*
+=for apidoc sv_nv
+
+A private implementation of the C<SvNVx> macro for compilers which can't
+cope with complex macro expressions. Always use the macro instead.
+
+=cut
+*/
+
NV
Perl_sv_nv(pTHX_ register SV *sv)
{
return sv_2nv(sv);
}
+/*
+=for apidoc sv_pv
+
+A private implementation of the C<SvPV_nolen> macro for compilers which can't
+cope with complex macro expressions. Always use the macro instead.
+
+=cut
+*/
+
char *
Perl_sv_pv(pTHX_ SV *sv)
{
return sv_2pv(sv, &n_a);
}
+/*
+=for apidoc sv_pvn
+
+A private implementation of the C<SvPV> macro for compilers which can't
+cope with complex macro expressions. Always use the macro instead.
+
+=cut
+*/
+
char *
Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
{
=for apidoc sv_pvn_force
Get a sensible string out of the SV somehow.
+A private implementation of the C<SvPV_force> macro for compilers which
+can't cope with complex macro expressions. Always use the macro instead.
=cut
*/
char *
Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
{
+ return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
+}
+
+/*
+=for apidoc sv_pvn_force_flags
+
+Get a sensible string out of the SV somehow.
+If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
+appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
+implemented in terms of this function.
+You normally want to use the various wrapper macros instead: see
+C<SvPV_force> and C<SvPV_force_nomg>
+
+=cut
+*/
+
+char *
+Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
+{
char *s;
if (SvTHINKFIRST(sv) && !SvROK(sv))
}
else {
if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
- dTHR;
Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
PL_op_name[PL_op->op_type]);
}
else
- s = sv_2pv(sv, lp);
+ s = sv_2pv_flags(sv, lp, flags);
if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
STRLEN len = *lp;
return SvPVX(sv);
}
+/*
+=for apidoc sv_pvbyte
+
+A private implementation of the C<SvPVbyte_nolen> macro for compilers
+which can't cope with complex macro expressions. Always use the macro
+instead.
+
+=cut
+*/
+
char *
Perl_sv_pvbyte(pTHX_ SV *sv)
{
+ sv_utf8_downgrade(sv,0);
return sv_pv(sv);
}
+/*
+=for apidoc sv_pvbyten
+
+A private implementation of the C<SvPVbyte> macro for compilers
+which can't cope with complex macro expressions. Always use the macro
+instead.
+
+=cut
+*/
+
char *
Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
{
+ sv_utf8_downgrade(sv,0);
return sv_pvn(sv,lp);
}
+/*
+=for apidoc sv_pvbyten_force
+
+A private implementation of the C<SvPVbytex_force> macro for compilers
+which can't cope with complex macro expressions. Always use the macro
+instead.
+
+=cut
+*/
+
char *
Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
{
+ sv_utf8_downgrade(sv,0);
return sv_pvn_force(sv,lp);
}
+/*
+=for apidoc sv_pvutf8
+
+A private implementation of the C<SvPVutf8_nolen> macro for compilers
+which can't cope with complex macro expressions. Always use the macro
+instead.
+
+=cut
+*/
+
char *
Perl_sv_pvutf8(pTHX_ SV *sv)
{
return sv_pv(sv);
}
+/*
+=for apidoc sv_pvutf8n
+
+A private implementation of the C<SvPVutf8> macro for compilers
+which can't cope with complex macro expressions. Always use the macro
+instead.
+
+=cut
+*/
+
char *
Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
{
/*
=for apidoc sv_pvutf8n_force
-Get a sensible UTF8-encoded string out of the SV somehow. See
-L</sv_pvn_force>.
+A private implementation of the C<SvPVutf8_force> macro for compilers
+which can't cope with complex macro expressions. Always use the macro
+instead.
=cut
*/
SV*
Perl_newSVrv(pTHX_ SV *rv, const char *classname)
{
- dTHR;
SV *sv;
new_SV(sv);
}
/*
+=for apidoc sv_setref_uv
+
+Copies an unsigned 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_uv(pTHX_ SV *rv, const char *classname, UV uv)
+{
+ sv_setuv(newSVrv(rv,classname), uv);
+ return rv;
+}
+
+/*
=for apidoc sv_setref_nv
Copies a double into a new SV, optionally blessing the SV. The C<rv>
SV*
Perl_sv_bless(pTHX_ SV *sv, HV *stash)
{
- dTHR;
SV *tmpRef;
if (!SvROK(sv))
Perl_croak(aTHX_ "Can't bless non-reference value");
return sv;
}
+/* Downgrades a PVGV to a PVMG.
+ *
+ * XXX This function doesn't actually appear to be used anywhere
+ * DAPM 15-Jun-01
+ */
+
STATIC void
S_sv_unglob(pTHX_ SV *sv)
{
SvREFCNT_dec(GvSTASH(sv));
GvSTASH(sv) = Nullhv;
}
- sv_unmagic(sv, '*');
+ sv_unmagic(sv, PERL_MAGIC_glob);
Safefree(GvNAME(sv));
GvMULTI_off(sv);
}
/*
-=for apidoc sv_unref
+=for apidoc sv_unref_flags
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>.
+as a reversal of C<newSVrv>. The C<cflags> argument can contain
+C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
+(otherwise the decrementing is conditional on the reference count being
+different from one or the reference being a readonly SV).
+See C<SvROK_off>.
=cut
*/
void
-Perl_sv_unref(pTHX_ SV *sv)
+Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
{
SV* rv = SvRV(sv);
}
SvRV(sv) = 0;
SvROK_off(sv);
- if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
+ if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
SvREFCNT_dec(rv);
- else
+ else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
sv_2mortal(rv); /* Schedule for freeing later */
}
+/*
+=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>. This is C<sv_unref_flags> with the C<flag>
+being zero. See C<SvROK_off>.
+
+=cut
+*/
+
+void
+Perl_sv_unref(pTHX_ SV *sv)
+{
+ sv_unref_flags(sv, 0);
+}
+
+/*
+=for apidoc sv_taint
+
+Taint an SV. Use C<SvTAINTED_on> instead.
+=cut
+*/
+
void
Perl_sv_taint(pTHX_ SV *sv)
{
- sv_magic((sv), Nullsv, 't', Nullch, 0);
+ sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
}
+/*
+=for apidoc sv_untaint
+
+Untaint an SV. Use C<SvTAINTED_off> instead.
+=cut
+*/
+
void
Perl_sv_untaint(pTHX_ SV *sv)
{
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
- MAGIC *mg = mg_find(sv, 't');
+ MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
if (mg)
mg->mg_len &= ~1;
}
}
+/*
+=for apidoc sv_tainted
+
+Test an SV for taintedness. Use C<SvTAINTED> instead.
+=cut
+*/
+
bool
Perl_sv_tainted(pTHX_ SV *sv)
{
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
- MAGIC *mg = mg_find(sv, 't');
+ MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
return TRUE;
}
sv_setpvn(sv, ptr, ebuf - ptr);
}
-
/*
=for apidoc sv_setpviv_mg
}
#if defined(PERL_IMPLICIT_CONTEXT)
+
+/* pTHX_ magic can't cope with varargs, so this is a no-context
+ * version of the main function, (which may itself be aliased to us).
+ * Don't access this version directly.
+ */
+
void
Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
{
va_end(args);
}
+/* pTHX_ magic can't cope with varargs, so this is a no-context
+ * version of the main function, (which may itself be aliased to us).
+ * Don't access this version directly.
+ */
void
Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
va_end(args);
}
+/* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
+
void
Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
{
va_end(args);
}
+/* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
+
void
Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
{
}
#if defined(PERL_IMPLICIT_CONTEXT)
+
+/* pTHX_ magic can't cope with varargs, so this is a no-context
+ * version of the main function, (which may itself be aliased to us).
+ * Don't access this version directly.
+ */
+
void
Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
{
va_end(args);
}
+/* pTHX_ magic can't cope with varargs, so this is a no-context
+ * version of the main function, (which may itself be aliased to us).
+ * Don't access this version directly.
+ */
+
void
Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
{
/*
=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.
+Processes its arguments like C<sprintf> and appends the formatted
+output to an SV. If the appended data contains "wide" characters
+(including, but not limited to, SVs with a UTF-8 PV formatted with %s,
+and characters >255 formatted with %c), the original SV might get
+upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
+C<SvSETMAGIC()> must typically be called after calling this function
+to handle 'set' magic.
-=cut
-*/
+=cut */
void
Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
va_end(args);
}
+/* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
+
void
Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
{
va_end(args);
}
+/* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
+
void
Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
{
Works like C<vcatpvfn> but copies the text into the SV instead of
appending it.
+Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
+
=cut
*/
sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
}
+/* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
+
+STATIC I32
+S_expect_number(pTHX_ char** pattern)
+{
+ I32 var = 0;
+ switch (**pattern) {
+ case '1': case '2': case '3':
+ case '4': case '5': case '6':
+ case '7': case '8': case '9':
+ while (isDIGIT(**pattern))
+ var = var * 10 + (*(*pattern)++ - '0');
+ }
+ return var;
+}
+#define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
+
/*
=for apidoc sv_vcatpvfn
C<maybe_tainted> if results are untrustworthy (often due to the use of
locales).
+Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
+
=cut
*/
void
Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
{
- dTHR;
char *p;
char *q;
char *patend;
STRLEN origlen;
I32 svix = 0;
static char nullstr[] = "(null)";
- SV *argsv;
+ SV *argsv = Nullsv;
/* no matter what, this is a string now */
(void)SvPV_force(sv, origlen);
bool alt = FALSE;
bool left = FALSE;
bool vectorize = FALSE;
- bool utf = FALSE;
+ bool vectorarg = FALSE;
+ bool vec_utf = FALSE;
char fill = ' ';
char plus = 0;
char intsize = 0;
bool has_precis = FALSE;
STRLEN precis = 0;
bool is_utf = FALSE;
-
+
char esignbuf[4];
- U8 utf8buf[UTF8_MAXLEN];
+ U8 utf8buf[UTF8_MAXLEN+1];
STRLEN esignlen = 0;
char *eptr = Nullch;
STRLEN veclen = 0;
char c;
int i;
- unsigned base;
+ unsigned base = 0;
IV iv;
UV uv;
NV nv;
STRLEN gap;
char *dotstr = ".";
STRLEN dotstrlen = 1;
+ I32 efix = 0; /* explicit format parameter index */
+ I32 ewix = 0; /* explicit width index */
+ I32 epix = 0; /* explicit precision index */
+ I32 evix = 0; /* explicit vector index */
+ bool asterisk = FALSE;
+ /* echo everything up to the next format specification */
for (q = p; q < patend && *q != '%'; ++q) ;
if (q > p) {
sv_catpvn(sv, p, q - p);
if (q++ >= patend)
break;
+/*
+ We allow format specification elements in this order:
+ \d+\$ explicit format parameter index
+ [-+ 0#]+ flags
+ \*?(\d+\$)?v vector with optional (optionally specified) arg
+ \d+|\*(\d+\$)? width using optional (optionally specified) arg
+ \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
+ [hlqLV] size
+ [%bcdefginopsux_DFOUX] format (mandatory)
+*/
+ if (EXPECT_NUMBER(q, width)) {
+ if (*q == '$') {
+ ++q;
+ efix = width;
+ } else {
+ goto gotwidth;
+ }
+ }
+
/* FLAGS */
while (*q) {
q++;
continue;
- case '*': /* printf("%*vX",":",$ipv6addr) */
- if (q[1] != 'v')
- break;
- q++;
- if (args)
- vecsv = va_arg(*args, SV*);
- else if (svix < svmax)
- vecsv = svargs[svix++];
- else
- continue;
- dotstr = SvPVx(vecsv,dotstrlen);
- if (DO_UTF8(vecsv))
- is_utf = TRUE;
- /* FALL THROUGH */
-
- case 'v':
- vectorize = TRUE;
- q++;
- continue;
-
default:
break;
}
break;
}
- /* WIDTH */
+ tryasterisk:
+ if (*q == '*') {
+ q++;
+ if (EXPECT_NUMBER(q, ewix))
+ if (*q++ != '$')
+ goto unknown;
+ asterisk = TRUE;
+ }
+ if (*q == 'v') {
+ q++;
+ if (vectorize)
+ goto unknown;
+ if ((vectorarg = asterisk)) {
+ evix = ewix;
+ ewix = 0;
+ asterisk = FALSE;
+ }
+ vectorize = TRUE;
+ goto tryasterisk;
+ }
+
+ if (!asterisk)
+ EXPECT_NUMBER(q, width);
- switch (*q) {
- case '1': case '2': case '3':
- case '4': case '5': case '6':
- case '7': case '8': case '9':
- width = 0;
- while (isDIGIT(*q))
- width = width * 10 + (*q++ - '0');
- break;
+ if (vectorize) {
+ if (vectorarg) {
+ if (args)
+ vecsv = va_arg(*args, SV*);
+ else
+ vecsv = (evix ? evix <= svmax : svix < svmax) ?
+ svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
+ dotstr = SvPVx(vecsv, dotstrlen);
+ if (DO_UTF8(vecsv))
+ is_utf = TRUE;
+ }
+ if (args) {
+ vecsv = va_arg(*args, SV*);
+ vecstr = (U8*)SvPVx(vecsv,veclen);
+ vec_utf = DO_UTF8(vecsv);
+ }
+ else if (efix ? efix <= svmax : svix < svmax) {
+ vecsv = svargs[efix ? efix-1 : svix++];
+ vecstr = (U8*)SvPVx(vecsv,veclen);
+ vec_utf = DO_UTF8(vecsv);
+ }
+ else {
+ vecstr = (U8*)"";
+ veclen = 0;
+ }
+ }
- case '*':
+ if (asterisk) {
if (args)
i = va_arg(*args, int);
else
- i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+ i = (ewix ? ewix <= svmax : svix < svmax) ?
+ SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
left |= (i < 0);
width = (i < 0) ? -i : i;
- q++;
- break;
}
+ gotwidth:
/* PRECISION */
if (*q == '.') {
q++;
if (*q == '*') {
+ q++;
+ if (EXPECT_NUMBER(q, epix) && *q++ != '$')
+ goto unknown;
if (args)
i = va_arg(*args, int);
else
- i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+ i = (ewix ? ewix <= svmax : svix < svmax)
+ ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
precis = (i < 0) ? 0 : i;
- q++;
}
else {
precis = 0;
has_precis = TRUE;
}
- if (vectorize) {
- if (args) {
- vecsv = va_arg(*args, SV*);
- vecstr = (U8*)SvPVx(vecsv,veclen);
- utf = DO_UTF8(vecsv);
- }
- else if (svix < svmax) {
- vecsv = svargs[svix++];
- vecstr = (U8*)SvPVx(vecsv,veclen);
- utf = DO_UTF8(vecsv);
- }
- else {
- vecstr = (U8*)"";
- veclen = 0;
- }
- }
-
/* SIZE */
switch (*q) {
/* CONVERSION */
+ if (*q == '%') {
+ eptr = q++;
+ elen = 1;
+ goto string;
+ }
+
+ if (!args)
+ argsv = (efix ? efix <= svmax : svix < svmax) ?
+ svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
+
switch (c = *q++) {
/* STRINGS */
- case '%':
- eptr = q - 1;
- elen = 1;
- goto string;
-
case 'c':
- if (args)
- uv = va_arg(*args, int);
- else
- uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
- if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
+ uv = args ? va_arg(*args, int) : SvIVx(argsv);
+ if ((uv > 255 ||
+ (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
+ && !IN_BYTES) {
eptr = (char*)utf8buf;
- elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
+ elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
is_utf = TRUE;
}
else {
elen = sizeof nullstr - 1;
}
}
- else if (svix < svmax) {
- argsv = svargs[svix++];
+ else {
eptr = SvPVx(argsv, elen);
if (DO_UTF8(argsv)) {
if (has_precis && precis < elen) {
*/
if (!args)
goto unknown;
- argsv = va_arg(*args,SV*);
+ argsv = va_arg(*args, SV*);
eptr = SvPVx(argsv, elen);
if (DO_UTF8(argsv))
is_utf = TRUE;
case 'p':
if (alt)
goto unknown;
- if (args)
- uv = PTR2UV(va_arg(*args, void*));
- else
- uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
+ uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
base = 16;
goto integer;
case 'd':
case 'i':
if (vectorize) {
- I32 ulen;
- if (!veclen) {
- vectorize = FALSE;
- break;
- }
- if (utf)
- iv = (IV)utf8_to_uv_chk(vecstr, &ulen, 0);
+ STRLEN ulen;
+ if (!veclen)
+ continue;
+ if (vec_utf)
+ iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
else {
iv = *vecstr;
ulen = 1;
}
}
else {
- iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+ iv = SvIVx(argsv);
switch (intsize) {
case 'h': iv = (short)iv; break;
default: break;
uns_integer:
if (vectorize) {
- I32 ulen;
+ STRLEN ulen;
vector:
- if (!veclen) {
- vectorize = FALSE;
- break;
- }
- if (utf)
- uv = utf8_to_uv_chk(vecstr, &ulen, 0);
+ if (!veclen)
+ continue;
+ if (vec_utf)
+ uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
else {
uv = *vecstr;
ulen = 1;
}
}
else {
- uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
+ uv = SvUVx(argsv);
switch (intsize) {
case 'h': uv = (unsigned short)uv; break;
default: break;
/* This is evil, but floating point is even more evil */
vectorize = FALSE;
- if (args)
- nv = va_arg(*args, NV);
- else
- nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
+ nv = args ? va_arg(*args, NV) : SvNVx(argsv);
need = 0;
if (c != 'e' && c != 'E') {
*--eptr = '#';
*--eptr = '%';
- {
- STORE_NUMERIC_STANDARD_SET_LOCAL();
-#ifdef USE_LOCALE_NUMERIC
- if (!was_standard && maybe_tainted)
- *maybe_tainted = TRUE;
-#endif
- (void)sprintf(PL_efloatbuf, eptr, nv);
- RESTORE_NUMERIC_STANDARD();
- }
+ /* No taint. Otherwise we are in the strange situation
+ * where printf() taints but print($float) doesn't.
+ * --jhi */
+ (void)sprintf(PL_efloatbuf, eptr, nv);
eptr = PL_efloatbuf;
elen = strlen(PL_efloatbuf);
#endif
}
}
- else if (svix < svmax)
- sv_setuv_mg(svargs[svix++], (UV)i);
+ else
+ sv_setuv_mg(argsv, (UV)i);
continue; /* not "break" */
/* UNKNOWN */
/* ... right here, because formatting flags should not apply */
SvGROW(sv, SvCUR(sv) + elen + 1);
p = SvEND(sv);
- memcpy(p, eptr, elen);
+ Copy(eptr, p, elen, char);
p += elen;
*p = '\0';
SvCUR(sv) = p - SvPVX(sv);
*p++ = '0';
}
if (elen) {
- memcpy(p, eptr, elen);
+ Copy(eptr, p, elen, char);
p += elen;
}
if (gap && left) {
}
if (vectorize) {
if (veclen) {
- memcpy(p, dotstr, dotstrlen);
+ Copy(dotstr, p, dotstrlen, char);
p += dotstrlen;
}
else
}
}
+/* =========================================================================
+
+=head1 Cloning an interpreter
+
+All the macros and functions in this section are for the private use of
+the main function, perl_clone().
+
+The foo_dup() functions make an exact copy of an existing foo thinngy.
+During the course of a cloning, a hash table is used to map old addresses
+to new addresses. The table is created and manipulated with the
+ptr_table_* functions.
+
+=cut
+
+============================================================================*/
+
+
#if defined(USE_ITHREADS)
#if defined(USE_THREADS)
#endif
-#define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
-#define av_dup(s) (AV*)sv_dup((SV*)s)
-#define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
-#define hv_dup(s) (HV*)sv_dup((SV*)s)
-#define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
-#define cv_dup(s) (CV*)sv_dup((SV*)s)
-#define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
-#define io_dup(s) (IO*)sv_dup((SV*)s)
-#define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
-#define gv_dup(s) (GV*)sv_dup((SV*)s)
-#define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
+#define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
+#define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
+#define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
+#define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
+#define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
+#define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
+#define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
+#define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
+#define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
+#define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
+#define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
#define SAVEPV(p) (p ? savepv(p) : Nullch)
#define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
+
+
+
+/* duplicate a regexp */
REGEXP *
Perl_re_dup(pTHX_ REGEXP *r)
return ReREFCNT_inc(r);
}
+/* duplicate a file handle */
+
PerlIO *
Perl_fp_dup(pTHX_ PerlIO *fp, char type)
{
return ret;
/* create anew and remember what it is */
- ret = PerlIO_fdupopen(fp);
+ ret = PerlIO_fdupopen(aTHX_ fp);
ptr_table_store(PL_ptr_table, fp, ret);
return ret;
}
+/* duplicate a directory handle */
+
DIR *
Perl_dirp_dup(pTHX_ DIR *dp)
{
return dp;
}
+/* duplictate a typeglob */
+
GP *
-Perl_gp_dup(pTHX_ GP *gp)
+Perl_gp_dup(pTHX_ GP *gp, clone_params* param)
{
GP *ret;
if (!gp)
/* clone */
ret->gp_refcnt = 0; /* must be before any other dups! */
- ret->gp_sv = sv_dup_inc(gp->gp_sv);
- ret->gp_io = io_dup_inc(gp->gp_io);
- ret->gp_form = cv_dup_inc(gp->gp_form);
- ret->gp_av = av_dup_inc(gp->gp_av);
- ret->gp_hv = hv_dup_inc(gp->gp_hv);
- ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
- ret->gp_cv = cv_dup_inc(gp->gp_cv);
+ ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
+ ret->gp_io = io_dup_inc(gp->gp_io, param);
+ ret->gp_form = cv_dup_inc(gp->gp_form, param);
+ ret->gp_av = av_dup_inc(gp->gp_av, param);
+ ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
+ ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
+ ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
ret->gp_cvgen = gp->gp_cvgen;
ret->gp_flags = gp->gp_flags;
ret->gp_line = gp->gp_line;
return ret;
}
+/* duplicate a chain of magic */
+
MAGIC *
-Perl_mg_dup(pTHX_ MAGIC *mg)
+Perl_mg_dup(pTHX_ MAGIC *mg, clone_params* param)
{
- MAGIC *mgret = (MAGIC*)NULL;
- MAGIC *mgprev;
+ MAGIC *mgprev = (MAGIC*)NULL;
+ MAGIC *mgret;
if (!mg)
return (MAGIC*)NULL;
/* look for it in the table first */
for (; mg; mg = mg->mg_moremagic) {
MAGIC *nmg;
Newz(0, nmg, 1, MAGIC);
- if (!mgret)
- mgret = nmg;
- else
+ if (mgprev)
mgprev->mg_moremagic = nmg;
+ else
+ mgret = nmg;
nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
nmg->mg_private = mg->mg_private;
nmg->mg_type = mg->mg_type;
nmg->mg_flags = mg->mg_flags;
- if (mg->mg_type == 'r') {
+ if (mg->mg_type == PERL_MAGIC_qr) {
nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
}
else {
nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
- ? sv_dup_inc(mg->mg_obj)
- : sv_dup(mg->mg_obj);
+ ? sv_dup_inc(mg->mg_obj, param)
+ : sv_dup(mg->mg_obj, param);
}
nmg->mg_len = mg->mg_len;
nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
- if (mg->mg_ptr && mg->mg_type != 'g') {
+ if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
if (mg->mg_len >= 0) {
nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
- if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
+ if (mg->mg_type == PERL_MAGIC_overload_table &&
+ AMT_AMAGIC((AMT*)mg->mg_ptr))
+ {
AMT *amtp = (AMT*)mg->mg_ptr;
AMT *namtp = (AMT*)nmg->mg_ptr;
I32 i;
for (i = 1; i < NofAMmeth; i++) {
- namtp->table[i] = cv_dup_inc(amtp->table[i]);
+ namtp->table[i] = cv_dup_inc(amtp->table[i], param);
}
}
}
else if (mg->mg_len == HEf_SVKEY)
- nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
+ nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
}
mgprev = nmg;
}
return mgret;
}
+/* create a new pointer-mapping table */
+
PTR_TBL_t *
Perl_ptr_table_new(pTHX)
{
return tbl;
}
+/* map an existing pointer using a table */
+
void *
Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
{
return (void*)NULL;
}
+/* add a new entry to a pointer-mapping table */
+
void
Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
{
ptr_table_split(tbl);
}
+/* double the hash bucket size of an existing ptr table */
+
void
Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
{
}
}
+/* remove all the entries from a ptr table */
+
+void
+Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
+{
+ register PTR_TBL_ENT_t **array;
+ register PTR_TBL_ENT_t *entry;
+ register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
+ UV riter = 0;
+ UV max;
+
+ if (!tbl || !tbl->tbl_items) {
+ return;
+ }
+
+ array = tbl->tbl_ary;
+ entry = array[0];
+ max = tbl->tbl_max;
+
+ for (;;) {
+ if (entry) {
+ oentry = entry;
+ entry = entry->next;
+ Safefree(oentry);
+ }
+ if (!entry) {
+ if (++riter > max) {
+ break;
+ }
+ entry = array[riter];
+ }
+ }
+
+ tbl->tbl_items = 0;
+}
+
+/* clear and free a ptr table */
+
+void
+Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
+{
+ if (!tbl) {
+ return;
+ }
+ ptr_table_clear(tbl);
+ Safefree(tbl->tbl_ary);
+ Safefree(tbl);
+}
+
#ifdef DEBUGGING
char *PL_watch_pvx;
#endif
+/* attempt to make everything in the typeglob readonly */
+
+STATIC SV *
+S_gv_share(pTHX_ SV *sstr)
+{
+ GV *gv = (GV*)sstr;
+ SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
+
+ if (GvIO(gv) || GvFORM(gv)) {
+ GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
+ }
+ else if (!GvCV(gv)) {
+ GvCV(gv) = (CV*)sv;
+ }
+ else {
+ /* CvPADLISTs cannot be shared */
+ if (!CvXSUB(GvCV(gv))) {
+ GvSHARED_off(gv);
+ }
+ }
+
+ if (!GvSHARED(gv)) {
+#if 0
+ PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
+ HvNAME(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(GvAV(gv));
+ }
+
+ return sstr; /* he_dup() will SvREFCNT_inc() */
+}
+
+/* duplicate an SV of any type (including AV, HV etc) */
+
SV *
-Perl_sv_dup(pTHX_ SV *sstr)
+Perl_sv_dup(pTHX_ SV *sstr, clone_params* param)
{
SV *dstr;
break;
case SVt_RV:
SvANY(dstr) = new_XRV();
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvRV(sstr) && SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
break;
case SVt_PV:
SvANY(dstr) = new_XPV();
SvCUR(dstr) = SvCUR(sstr);
SvLEN(dstr) = SvLEN(sstr);
if (SvROK(sstr))
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
if (SvROK(sstr))
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
if (SvROK(sstr))
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
+ SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
+ SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
+ SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
+ SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
+ SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
+ SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
LvTARGLEN(dstr) = LvTARGLEN(sstr);
- LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
+ LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
LvTYPE(dstr) = LvTYPE(sstr);
break;
case SVt_PVGV:
+ if (GvSHARED((GV*)sstr)) {
+ SV *share;
+ if ((share = gv_share(sstr))) {
+ del_SV(dstr);
+ dstr = share;
+#if 0
+ PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
+ HvNAME(GvSTASH(share)), GvNAME(share));
+#endif
+ break;
+ }
+ }
SvANY(dstr) = new_XPVGV();
SvCUR(dstr) = SvCUR(sstr);
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
+ SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
+ SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
GvNAMELEN(dstr) = GvNAMELEN(sstr);
GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
- GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
+ GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
GvFLAGS(dstr) = GvFLAGS(sstr);
- GvGP(dstr) = gp_dup(GvGP(sstr));
+ GvGP(dstr) = gp_dup(GvGP(sstr), param);
(void)GpREFCNT_inc(GvGP(dstr));
break;
case SVt_PVIO:
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
+ SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
+ SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
- SvRV(dstr) = sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
- IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
+ IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
- IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
+ IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
- IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
+ IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
IoTYPE(dstr) = IoTYPE(sstr);
IoFLAGS(dstr) = IoFLAGS(sstr);
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
- AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
+ SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
+ SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
+ AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
if (AvARRAY((AV*)sstr)) {
SV **dst_ary, **src_ary;
AvALLOC((AV*)dstr) = dst_ary;
if (AvREAL((AV*)sstr)) {
while (items-- > 0)
- *dst_ary++ = sv_dup_inc(*src_ary++);
+ *dst_ary++ = sv_dup_inc(*src_ary++, param);
}
else {
while (items-- > 0)
- *dst_ary++ = sv_dup(*src_ary++);
+ *dst_ary++ = sv_dup(*src_ary++, param);
}
items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
while (items-- > 0) {
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
+ SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
+ SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
if (HvARRAY((HV*)sstr)) {
STRLEN i = 0;
PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
while (i <= sxhv->xhv_max) {
((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
- !!HvSHAREKEYS(sstr));
+ !!HvSHAREKEYS(sstr), param);
++i;
}
- dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
+ dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr), param);
}
else {
SvPVX(dstr) = Nullch;
}
HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
+ /* Record stashes for possible cloning in Perl_clone_using(). */
+ if(HvNAME((HV*)dstr))
+ av_push(param->stashes, dstr);
break;
case SVt_PVFM:
SvANY(dstr) = new_XPVFM();
/* NOTREACHED */
case SVt_PVCV:
SvANY(dstr) = new_XPVCV();
-dup_pvcv:
+ dup_pvcv:
SvCUR(dstr) = SvCUR(sstr);
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
+ SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
+ SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
- CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
+ CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
CvSTART(dstr) = CvSTART(sstr);
CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
CvXSUB(dstr) = CvXSUB(sstr);
CvXSUBANY(dstr) = CvXSUBANY(sstr);
- CvGV(dstr) = gv_dup_inc(CvGV(sstr));
- CvDEPTH(dstr) = CvDEPTH(sstr);
+ CvGV(dstr) = gv_dup(CvGV(sstr), param);
+ if (param->flags & CLONEf_COPY_STACKS) {
+ CvDEPTH(dstr) = CvDEPTH(sstr);
+ } else {
+ CvDEPTH(dstr) = 0;
+ }
if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
/* XXX padlists are real, but pretend to be not */
AvREAL_on(CvPADLIST(sstr));
- CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
+ CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
AvREAL_off(CvPADLIST(sstr));
AvREAL_off(CvPADLIST(dstr));
}
else
- CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
- CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
+ CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
+ if (!CvANON(sstr) || CvCLONED(sstr))
+ CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
+ else
+ CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param);
CvFLAGS(dstr) = CvFLAGS(sstr);
break;
default:
++PL_sv_objcount;
return dstr;
-}
+ }
+
+/* duplicate a context */
PERL_CONTEXT *
-Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
+Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, clone_params* param)
{
PERL_CONTEXT *ncxs;
switch (CxTYPE(cx)) {
case CXt_SUB:
ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
- ? cv_dup_inc(cx->blk_sub.cv)
- : cv_dup(cx->blk_sub.cv));
+ ? cv_dup_inc(cx->blk_sub.cv, param)
+ : cv_dup(cx->blk_sub.cv,param));
ncx->blk_sub.argarray = (cx->blk_sub.hasargs
- ? av_dup_inc(cx->blk_sub.argarray)
+ ? av_dup_inc(cx->blk_sub.argarray, param)
: Nullav);
- ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
+ ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
ncx->blk_sub.lval = cx->blk_sub.lval;
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_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
+ ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);;
ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
- ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
+ ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
break;
case CXt_LOOP:
ncx->blk_loop.label = cx->blk_loop.label;
ncx->blk_loop.last_op = cx->blk_loop.last_op;
ncx->blk_loop.iterdata = (CxPADLOOP(cx)
? cx->blk_loop.iterdata
- : gv_dup((GV*)cx->blk_loop.iterdata));
+ : gv_dup((GV*)cx->blk_loop.iterdata, param));
ncx->blk_loop.oldcurpad
= (SV**)ptr_table_fetch(PL_ptr_table,
cx->blk_loop.oldcurpad);
- ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
- ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
- ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
+ ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
+ ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
+ ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
ncx->blk_loop.iterix = cx->blk_loop.iterix;
ncx->blk_loop.itermax = cx->blk_loop.itermax;
break;
case CXt_FORMAT:
- ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
- ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
- ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
+ ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
+ ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
+ ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
break;
case CXt_BLOCK:
return ncxs;
}
+/* duplicate a stack info structure */
+
PERL_SI *
-Perl_si_dup(pTHX_ PERL_SI *si)
+Perl_si_dup(pTHX_ PERL_SI *si, clone_params* param)
{
PERL_SI *nsi;
Newz(56, nsi, 1, PERL_SI);
ptr_table_store(PL_ptr_table, si, nsi);
- nsi->si_stack = av_dup_inc(si->si_stack);
+ nsi->si_stack = av_dup_inc(si->si_stack, param);
nsi->si_cxix = si->si_cxix;
nsi->si_cxmax = si->si_cxmax;
- nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
+ nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
nsi->si_type = si->si_type;
- nsi->si_prev = si_dup(si->si_prev);
- nsi->si_next = si_dup(si->si_next);
+ nsi->si_prev = si_dup(si->si_prev, param);
+ nsi->si_next = si_dup(si->si_next, param);
nsi->si_markoff = si->si_markoff;
return nsi;
#define pv_dup(p) SAVEPV(p)
#define svp_dup_inc(p,pp) any_dup(p,pp)
+/* map any object to the new equivent - either something in the
+ * ptr table, or something in the interpreter structure
+ */
+
void *
Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
{
return ret;
}
+/* duplicate the save stack */
+
ANY *
-Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
+Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, clone_params* param)
{
ANY *ss = proto_perl->Tsavestack;
I32 ix = proto_perl->Tsavestack_ix;
switch (i) {
case SAVEt_ITEM: /* normal string */
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
break;
case SAVEt_SV: /* scalar reference */
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup_inc(gv);
+ TOPPTR(nss,ix) = gv_dup_inc(gv, param);
break;
case SAVEt_GENERIC_PVREF: /* generic char* */
c = (char*)POPPTR(ss,ix);
case SAVEt_GENERIC_SVREF: /* generic sv */
case SAVEt_SVREF: /* scalar reference */
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
break;
case SAVEt_AV: /* array reference */
av = (AV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = av_dup_inc(av);
+ TOPPTR(nss,ix) = av_dup_inc(av, param);
gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup(gv);
+ TOPPTR(nss,ix) = gv_dup(gv, param);
break;
case SAVEt_HV: /* hash reference */
hv = (HV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = hv_dup_inc(hv);
+ TOPPTR(nss,ix) = hv_dup_inc(hv, param);
gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup(gv);
+ TOPPTR(nss,ix) = gv_dup(gv, param);
break;
case SAVEt_INT: /* int reference */
ptr = POPPTR(ss,ix);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup(sv);
+ TOPPTR(nss,ix) = sv_dup(sv, param);
break;
case SAVEt_VPTR: /* random* reference */
ptr = POPPTR(ss,ix);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
hv = (HV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = hv_dup(hv);
+ TOPPTR(nss,ix) = hv_dup(hv, param);
break;
case SAVEt_APTR: /* AV* reference */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
av = (AV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = av_dup(av);
+ TOPPTR(nss,ix) = av_dup(av, param);
break;
case SAVEt_NSTAB:
gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup(gv);
+ TOPPTR(nss,ix) = gv_dup(gv, param);
break;
case SAVEt_GP: /* scalar reference */
gp = (GP*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gp = gp_dup(gp);
+ TOPPTR(nss,ix) = gp = gp_dup(gp, param);
(void)GpREFCNT_inc(gp);
gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup_inc(c);
+ TOPPTR(nss,ix) = gv_dup_inc(c, param);
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup(c);
iv = POPIV(ss,ix);
TOPIV(nss,ix) = iv;
break;
case SAVEt_FREESV:
+ case SAVEt_MORTALIZESV:
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
break;
case SAVEt_FREEOP:
ptr = POPPTR(ss,ix);
break;
case SAVEt_DELETE:
hv = (HV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = hv_dup_inc(hv);
+ TOPPTR(nss,ix) = hv_dup_inc(hv, param);
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup_inc(c);
i = POPINT(ss,ix);
break;
case SAVEt_AELEM: /* array element */
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
av = (AV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = av_dup_inc(av);
+ TOPPTR(nss,ix) = av_dup_inc(av, param);
break;
case SAVEt_HELEM: /* hash element */
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
hv = (HV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = hv_dup_inc(hv);
+ TOPPTR(nss,ix) = hv_dup_inc(hv, param);
break;
case SAVEt_OP:
ptr = POPPTR(ss,ix);
break;
case SAVEt_COMPPAD:
av = (AV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = av_dup(av);
+ TOPPTR(nss,ix) = av_dup(av, param);
+ break;
+ case SAVEt_PADSV:
+ longval = (long)POPLONG(ss,ix);
+ TOPLONG(nss,ix) = longval;
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ sv = (SV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup(sv, param);
break;
default:
Perl_croak(aTHX_ "panic: ss_dup inconsistency");
#include "XSUB.h"
#endif
+/*
+=for apidoc perl_clone
+
+Create and return a new interpreter by cloning the current one.
+
+=cut
+*/
+
+/* XXX the above needs expanding by someone who actually understands it ! */
+
PerlInterpreter *
perl_clone(PerlInterpreter *proto_perl, UV flags)
{
* their pointers copied. */
IV i;
+ clone_params* param = (clone_params*) malloc(sizeof(clone_params));
+ param->flags = flags;
+
+
+
# ifdef PERL_OBJECT
CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
ipD, ipS, ipP);
PL_scopestack = 0;
PL_savestack = 0;
PL_retstack = 0;
+ PL_sig_pending = 0;
# else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
# endif /* DEBUGGING */
# endif /* PERL_OBJECT */
#else /* !PERL_IMPLICIT_SYS */
IV i;
+ clone_params* param = (clone_params*) malloc(sizeof(clone_params));
PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
+ param->flags = flags;
PERL_SET_THX(my_perl);
+
+
# ifdef DEBUGGING
memset(my_perl, 0xab, sizeof(PerlInterpreter));
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
PL_retstack = 0;
+ PL_sig_pending = 0;
# else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
# endif /* DEBUGGING */
PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
if (!specialWARN(PL_compiling.cop_warnings))
- PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
+ PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
+ if (!specialCopIO(PL_compiling.cop_io))
+ PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
/* pseudo environmental stuff */
while (i-- > 0) {
PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
}
- PL_envgv = gv_dup(proto_perl->Ienvgv);
- PL_incgv = gv_dup(proto_perl->Iincgv);
- PL_hintgv = gv_dup(proto_perl->Ihintgv);
+
+
+ param->stashes = newAV(); /* Setup array of objects to call clone on */
+
+
+ PL_envgv = gv_dup(proto_perl->Ienvgv, param);
+ PL_incgv = gv_dup(proto_perl->Iincgv, param);
+ PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
- PL_diehook = sv_dup_inc(proto_perl->Idiehook);
- PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
+ PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
+ PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
/* switches */
PL_minus_c = proto_perl->Iminus_c;
- PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
+ PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
PL_localpatches = proto_perl->Ilocalpatches;
PL_splitstr = proto_perl->Isplitstr;
PL_preprocess = proto_perl->Ipreprocess;
PL_sawampersand = proto_perl->Isawampersand;
PL_unsafe = proto_perl->Iunsafe;
PL_inplace = SAVEPV(proto_perl->Iinplace);
- PL_e_script = sv_dup_inc(proto_perl->Ie_script);
+ PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
PL_perldb = proto_perl->Iperldb;
PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
/* magical thingies */
/* XXX time(&PL_basetime) when asked for? */
PL_basetime = proto_perl->Ibasetime;
- PL_formfeed = sv_dup(proto_perl->Iformfeed);
+ PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
PL_maxsysfd = proto_perl->Imaxsysfd;
PL_multiline = proto_perl->Imultiline;
#endif
/* shortcuts to various I/O objects */
- PL_stdingv = gv_dup(proto_perl->Istdingv);
- PL_stderrgv = gv_dup(proto_perl->Istderrgv);
- PL_defgv = gv_dup(proto_perl->Idefgv);
- PL_argvgv = gv_dup(proto_perl->Iargvgv);
- PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
- PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
+ PL_stdingv = gv_dup(proto_perl->Istdingv, param);
+ PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
+ PL_defgv = gv_dup(proto_perl->Idefgv, param);
+ PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
+ PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
+ PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
/* shortcuts to regexp stuff */
- PL_replgv = gv_dup(proto_perl->Ireplgv);
+ PL_replgv = gv_dup(proto_perl->Ireplgv, param);
/* shortcuts to misc objects */
- PL_errgv = gv_dup(proto_perl->Ierrgv);
+ PL_errgv = gv_dup(proto_perl->Ierrgv, param);
/* shortcuts to debugging objects */
- PL_DBgv = gv_dup(proto_perl->IDBgv);
- PL_DBline = gv_dup(proto_perl->IDBline);
- PL_DBsub = gv_dup(proto_perl->IDBsub);
- PL_DBsingle = sv_dup(proto_perl->IDBsingle);
- PL_DBtrace = sv_dup(proto_perl->IDBtrace);
- PL_DBsignal = sv_dup(proto_perl->IDBsignal);
- PL_lineary = av_dup(proto_perl->Ilineary);
- PL_dbargs = av_dup(proto_perl->Idbargs);
+ PL_DBgv = gv_dup(proto_perl->IDBgv, param);
+ PL_DBline = gv_dup(proto_perl->IDBline, param);
+ PL_DBsub = gv_dup(proto_perl->IDBsub, param);
+ PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
+ PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
+ PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
+ PL_lineary = av_dup(proto_perl->Ilineary, param);
+ PL_dbargs = av_dup(proto_perl->Idbargs, param);
/* symbol tables */
- PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
- PL_curstash = hv_dup(proto_perl->Tcurstash);
- PL_debstash = hv_dup(proto_perl->Idebstash);
- PL_globalstash = hv_dup(proto_perl->Iglobalstash);
- PL_curstname = sv_dup_inc(proto_perl->Icurstname);
-
- PL_beginav = av_dup_inc(proto_perl->Ibeginav);
- PL_endav = av_dup_inc(proto_perl->Iendav);
- PL_checkav = av_dup_inc(proto_perl->Icheckav);
- PL_initav = av_dup_inc(proto_perl->Iinitav);
+ PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
+ PL_curstash = hv_dup(proto_perl->Tcurstash, param);
+ PL_nullstash = hv_dup(proto_perl->Inullstash, param);
+ PL_debstash = hv_dup(proto_perl->Idebstash, param);
+ PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
+ PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
+
+ PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
+ PL_endav = av_dup_inc(proto_perl->Iendav, param);
+ PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
+ PL_initav = av_dup_inc(proto_perl->Iinitav, param);
PL_sub_generation = proto_perl->Isub_generation;
PL_forkprocess = proto_perl->Iforkprocess;
/* subprocess state */
- PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
+ PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
/* internal state */
PL_tainting = proto_perl->Itainting;
PL_op_mask = Nullch;
/* current interpreter roots */
- PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
+ PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
PL_main_start = proto_perl->Imain_start;
PL_eval_root = proto_perl->Ieval_root;
PL_Cmd = Nullch;
PL_gensym = proto_perl->Igensym;
PL_preambled = proto_perl->Ipreambled;
- PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
+ PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
PL_laststatval = proto_perl->Ilaststatval;
PL_laststype = proto_perl->Ilaststype;
PL_mess_sv = Nullsv;
- PL_orslen = proto_perl->Iorslen;
- PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
+ PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
PL_ofmt = SAVEPV(proto_perl->Iofmt);
/* interpreter atexit processing */
}
else
PL_exitlist = (PerlExitListEntry*)NULL;
- PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
+ PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
PL_profiledata = NULL;
PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
/* PL_rsfp_filters entries have fake IoDIRP() */
- PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
+ PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
- PL_compcv = cv_dup(proto_perl->Icompcv);
- PL_comppad = av_dup(proto_perl->Icomppad);
- PL_comppad_name = av_dup(proto_perl->Icomppad_name);
+ PL_compcv = cv_dup(proto_perl->Icompcv, param);
+ PL_comppad = av_dup(proto_perl->Icomppad, param);
+ PL_comppad_name = av_dup(proto_perl->Icomppad_name, param);
PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
/* more statics moved here */
PL_generation = proto_perl->Igeneration;
- PL_DBcv = cv_dup(proto_perl->IDBcv);
+ PL_DBcv = cv_dup(proto_perl->IDBcv, param);
PL_in_clean_objs = proto_perl->Iin_clean_objs;
PL_in_clean_all = proto_perl->Iin_clean_all;
PL_lex_formbrack = proto_perl->Ilex_formbrack;
PL_lex_dojoin = proto_perl->Ilex_dojoin;
PL_lex_starts = proto_perl->Ilex_starts;
- PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
- PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
+ PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
+ PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
PL_lex_op = proto_perl->Ilex_op;
PL_lex_inpat = proto_perl->Ilex_inpat;
PL_lex_inwhat = proto_perl->Ilex_inwhat;
Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
PL_nexttoke = proto_perl->Inexttoke;
- PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
+ PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
PL_error_count = proto_perl->Ierror_count;
PL_subline = proto_perl->Isubline;
- PL_subname = sv_dup_inc(proto_perl->Isubname);
+ PL_subname = sv_dup_inc(proto_perl->Isubname, param);
PL_min_intro_pending = proto_perl->Imin_intro_pending;
PL_max_intro_pending = proto_perl->Imax_intro_pending;
PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
PL_last_lop_op = proto_perl->Ilast_lop_op;
PL_in_my = proto_perl->Iin_my;
- PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
+ PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
#ifdef FCRYPT
PL_cryptseen = proto_perl->Icryptseen;
#endif
PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
PL_numeric_standard = proto_perl->Inumeric_standard;
PL_numeric_local = proto_perl->Inumeric_local;
- PL_numeric_radix = proto_perl->Inumeric_radix;
+ PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
#endif /* !USE_LOCALE_NUMERIC */
/* utf8 character classes */
- PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
- PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
- PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
- PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
- PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
- PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
- PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
- PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
- PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
- PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
- PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
- PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
- PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
- PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
- PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
- PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
- PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
+ PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
+ PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
+ PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
+ PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
+ PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
+ PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
+ PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
+ PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
+ PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
+ PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
+ PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
+ PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
+ PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
+ PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, 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);
/* swatch cache */
PL_last_swash_hv = Nullhv; /* reinits on demand */
PL_uudmap['M'] = 0; /* reinits on demand */
PL_bitcount = Nullch; /* reinits on demand */
+ if (proto_perl->Ipsig_pend) {
+ Newz(0, PL_psig_pend, SIG_SIZE, int);
+ }
+ else {
+ PL_psig_pend = (int*)NULL;
+ }
+
if (proto_perl->Ipsig_ptr) {
- int sig_num[] = { SIG_NUM };
- Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
- Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
- for (i = 1; PL_sig_name[i]; i++) {
- PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
- PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
+ Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
+ Newz(0, 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);
}
}
else {
/* thrdvar.h stuff */
- if (flags & 1) {
+ if (flags & CLONEf_COPY_STACKS) {
/* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
PL_tmps_ix = proto_perl->Ttmps_ix;
PL_tmps_max = proto_perl->Ttmps_max;
Newz(50, 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]);
+ PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
++i;
}
Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
/* NOTE: si_dup() looks at PL_markstack */
- PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
+ PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
/* PL_curstack = PL_curstackinfo->si_stack; */
- PL_curstack = av_dup(proto_perl->Tcurstack);
- PL_mainstack = av_dup(proto_perl->Tmainstack);
+ PL_curstack = av_dup(proto_perl->Tcurstack, param);
+ PL_mainstack = av_dup(proto_perl->Tmainstack, param);
/* next PUSHs() etc. set *(PL_stack_sp+1) */
PL_stack_base = AvARRAY(PL_curstack);
PL_savestack_ix = proto_perl->Tsavestack_ix;
PL_savestack_max = proto_perl->Tsavestack_max;
/*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
- PL_savestack = ss_dup(proto_perl);
+ PL_savestack = ss_dup(proto_perl, param);
}
else {
init_stacks();
PL_statbuf = proto_perl->Tstatbuf;
PL_statcache = proto_perl->Tstatcache;
- PL_statgv = gv_dup(proto_perl->Tstatgv);
- PL_statname = sv_dup_inc(proto_perl->Tstatname);
+ PL_statgv = gv_dup(proto_perl->Tstatgv, param);
+ PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
#ifdef HAS_TIMES
PL_timesbuf = proto_perl->Ttimesbuf;
#endif
PL_tainted = proto_perl->Ttainted;
PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
- PL_nrs = sv_dup_inc(proto_perl->Tnrs);
- PL_rs = sv_dup_inc(proto_perl->Trs);
- PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
- PL_ofslen = proto_perl->Tofslen;
- PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
- PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
+ PL_nrs = sv_dup_inc(proto_perl->Tnrs, param);
+ PL_rs = sv_dup_inc(proto_perl->Trs, param);
+ PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
+ PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
+ PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
- PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
- PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
- PL_formtarget = sv_dup(proto_perl->Tformtarget);
+ PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
+ PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
+ PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
PL_restartop = proto_perl->Trestartop;
PL_in_eval = proto_perl->Tin_eval;
#ifdef PERL_FLEXIBLE_EXCEPTIONS
PL_protect = proto_perl->Tprotect;
#endif
- PL_errors = sv_dup_inc(proto_perl->Terrors);
+ PL_errors = sv_dup_inc(proto_perl->Terrors, param);
PL_av_fetch_sv = Nullsv;
PL_hv_fetch_sv = Nullsv;
Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
PL_dumpindent = proto_perl->Tdumpindent;
PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
- PL_sortstash = hv_dup(proto_perl->Tsortstash);
- PL_firstgv = gv_dup(proto_perl->Tfirstgv);
- PL_secondgv = gv_dup(proto_perl->Tsecondgv);
+ PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
+ PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
+ PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
PL_sortcxix = proto_perl->Tsortcxix;
PL_efloatbuf = Nullch; /* reinits on demand */
PL_efloatsize = 0; /* reinits on demand */
PL_regendp = (I32*)NULL;
PL_reglastparen = (U32*)NULL;
PL_regtill = Nullch;
- PL_regprev = '\n';
PL_reg_start_tmp = (char**)NULL;
PL_reg_start_tmpl = 0;
PL_regdata = (struct reg_data*)NULL;
PL_reginterp_cnt = 0;
PL_reg_starttry = 0;
+ if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
+ ptr_table_free(PL_ptr_table);
+ PL_ptr_table = NULL;
+ }
+
+ /* Call the ->CLONE method, if it exists, for each of the stashes
+ identified by sv_dup() above.
+ */
+ while(av_len(param->stashes) != -1) {
+ HV* stash = (HV*) av_shift(param->stashes);
+ GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
+ if (cloner && GvCV(cloner)) {
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ XPUSHs(newSVpv(HvNAME(stash), 0));
+ PUTBACK;
+ call_sv((SV*)GvCV(cloner), G_DISCARD);
+ FREETMPS;
+ LEAVE;
+ }
+ }
+
#ifdef PERL_OBJECT
return (PerlInterpreter*)pPerl;
#else
#endif /* USE_ITHREADS */
-static void
-do_report_used(pTHXo_ SV *sv)
-{
- if (SvTYPE(sv) != SVTYPEMASK) {
- PerlIO_printf(Perl_debug_log, "****\n");
- sv_dump(sv);
- }
-}
-
-static void
-do_clean_objs(pTHXo_ SV *sv)
-{
- SV* rv;
-
- if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
- DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
- if (SvWEAKREF(sv)) {
- sv_del_backref(sv);
- SvWEAKREF_off(sv);
- SvRV(sv) = 0;
- } else {
- SvROK_off(sv);
- SvRV(sv) = 0;
- SvREFCNT_dec(rv);
- }
- }
- /* XXX Might want to check arrays, etc. */
-}
-#ifndef DISABLE_DESTRUCTOR_KLUDGE
-static void
-do_clean_named_objs(pTHXo_ SV *sv)
-{
- if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
- if ( SvOBJECT(GvSV(sv)) ||
- (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
- (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
- (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
- (GvCV(sv) && SvOBJECT(GvCV(sv))) )
- {
- DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
- SvREFCNT_dec(sv);
- }
- }
-}
-#endif
-static void
-do_clean_all(pTHXo_ SV *sv)
-{
- DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
- SvFLAGS(sv) |= SVf_BREAK;
- SvREFCNT_dec(sv);
-}
projects / p5sagit/p5-mst-13.2.git / blobdiff