/* 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)
{
#define new_XPVHV() my_safemalloc(sizeof(XPVHV))
#define del_XPVHV(p) my_safefree(p)
-
+
#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
#define del_XPVMG(p) my_safefree(p)
#define new_XPVHV() (void*)new_xpvhv()
#define del_XPVHV(p) del_xpvhv((XPVHV *)p)
-
+
#define new_XPVMG() (void*)new_xpvmg()
#define del_XPVMG(p) del_xpvmg((XPVMG *)p)
#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
#define del_XPVGV(p) my_safefree(p)
-
+
#define new_XPVFM() my_safemalloc(sizeof(XPVFM))
#define del_XPVFM(p) my_safefree(p)
-
+
#define new_XPVIO() my_safemalloc(sizeof(XPVIO))
#define del_XPVIO(p) my_safefree(p)
/*
=for apidoc sv_upgrade
-Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
-C<svtype>.
+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
*/
MAGIC* magic;
HV* stash;
+ if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
+ sv_force_normal(sv);
+ }
+
if (SvTYPE(sv) == mt)
return TRUE;
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 (SvTHINKFIRST(sv)) {
if (SvROK(sv)) {
SV* tmpstr;
- if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
+ if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
+ (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,
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
"0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
PTR2UV(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 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 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
+ )) == 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;
+ }
+ }
+ }
+ /* 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);
+
+#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" 2nv(%g)\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
PTR2UV(sv), SvNVX(sv)));
#endif
- if (SvNVX(sv) < (NV)IV_MAX + 0.5)
+
+
+#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));
- else {
- SvUVX(sv) = U_V(SvNVX(sv));
- SvIsUV_on(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 (numtype) {
- /* 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) = Atol(SvPVX(sv));
- }
- else { /* Not a number. Cache 0. */
- dTHR;
-
- if (SvTYPE(sv) < SVt_PVIV)
- sv_upgrade(sv, SVt_PVIV);
- (void)SvIOK_on(sv);
- SvIVX(sv) = 0;
- if (ckWARN(WARN_NUMERIC))
- not_a_number(sv);
- }
- }
- else {
- dTHR;
+ } 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 (SvTHINKFIRST(sv)) {
if (SvROK(sv)) {
SV* tmpstr;
- if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
+ if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
+ (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:
- DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
+ 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(%"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
the translation of the initial data.
-
+
This means that if we cache such a UV, we need to cache the
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 (SvIOKp(sv)) {
- if (SvIsUV(sv))
+ if (SvIsUV(sv))
return (NV)SvUVX(sv);
else
return (NV)SvIVX(sv);
}
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit();
}
if (SvTHINKFIRST(sv)) {
if (SvROK(sv)) {
SV* tmpstr;
- if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
+ if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
+ (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({
- RESTORE_NUMERIC_STANDARD();
+ STORE_NUMERIC_LOCAL_SET_STANDARD();
PerlIO_printf(Perl_debug_log,
"0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
PTR2UV(sv), SvNVX(sv));
});
#else
DEBUG_c({
- RESTORE_NUMERIC_STANDARD();
+ STORE_NUMERIC_LOCAL_SET_STANDARD();
PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
}
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({
- RESTORE_NUMERIC_STANDARD();
+ STORE_NUMERIC_LOCAL_SET_STANDARD();
PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
#else
DEBUG_c({
- RESTORE_NUMERIC_STANDARD();
+ STORE_NUMERIC_LOCAL_SET_STANDARD();
PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
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 (SvIOKp(sv)) {
- if (SvIsUV(sv))
+ if (SvIsUV(sv))
(void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
else
(void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
}
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
- dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
report_uninit();
}
if (SvTHINKFIRST(sv)) {
if (SvROK(sv)) {
SV* tmpstr;
- if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
+ if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
+ (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
return SvPV(tmpstr,*lp);
sv = (SV*)SvRV(sv);
if (!sv)
switch (SvTYPE(sv)) {
case SVt_PVMG:
if ( ((SvFLAGS(sv) &
- (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
+ (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 for to be 64-bit-aware and
- * the t/op/numconvert.t became very, very, angry.
- * --jhi Sep 1999 */
- if (SvTYPE(sv) < SVt_PVNV)
- sv_upgrade(sv, SVt_PVNV);
- SvGROW(sv, 28);
- s = SvPVX(sv);
- olderrno = errno; /* some Xenix systems wipe out errno here */
-#ifdef apollo
- if (SvNVX(sv) == 0.0)
- (void)strcpy(s,"0");
- else
-#endif /*apollo*/
- {
- Gconvert(SvNVX(sv), NV_DIG, 0, s);
- }
- errno = olderrno;
-#ifdef FIXNEGATIVEZERO
- if (*s == '-' && s[1] == '0' && !s[2])
- strcpy(s,"0");
-#endif
- while (*s) s++;
-#ifdef hcx
- if (s[-1] == '.')
- *--s = '\0';
-#endif
- }
- else if (SvIOKp(sv)) {
+ 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)];
SvIOKp_on(sv);
if (isUIOK)
SvIsUV_on(sv);
- SvPOK_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 */
+ SvGROW(sv, NV_DIG + 20);
+ s = SvPVX(sv);
+ olderrno = errno; /* some Xenix systems wipe out errno here */
+#ifdef apollo
+ if (SvNVX(sv) == 0.0)
+ (void)strcpy(s,"0");
+ else
+#endif /*apollo*/
+ {
+ Gconvert(SvNVX(sv), NV_DIG, 0, s);
+ }
+ errno = olderrno;
+#ifdef FIXNEGATIVEZERO
+ if (*s == '-' && s[1] == '0' && !s[2])
+ strcpy(s,"0");
+#endif
+ while (*s) s++;
+#ifdef hcx
+ if (s[-1] == '.')
+ *--s = '\0';
+#endif
}
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_)))
+ if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
+ (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)
{
- int hicount;
- char *c;
+ return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
+}
- if (!sv || !SvPOK(sv) || SvUTF8(sv))
- return;
+/*
+=for apidoc sv_utf8_upgrade_flags
- /* This function could be much more efficient if we had a FLAG
- * to signal if there are any hibit chars in the string
- */
- hicount = 0;
- for (c = SvPVX(sv); c < SvEND(sv); c++) {
- if (*c & 0x80)
- hicount++;
+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 (hicount) {
- char *src, *dst;
- SvGROW(sv, SvCUR(sv) + hicount + 1);
+ if (SvUTF8(sv))
+ return SvCUR(sv);
- src = SvEND(sv) - 1;
- SvCUR_set(sv, SvCUR(sv) + hicount);
- dst = SvEND(sv) - 1;
+ if (SvREADONLY(sv) && SvFAKE(sv)) {
+ sv_force_normal(sv);
+ }
- while (src < dst) {
- if (*src & 0x80) {
- dst--;
- uv_to_utf8((U8*)dst, (U8)*src--);
- dst--;
- }
- else {
- *dst-- = *src--;
- }
- }
+ /* 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
+ */
+ 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;
- SvUTF8_on(sv);
+ 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. */
}
+ /* 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);
- char *first_hi = 0;
- /* need to figure out if this is possible at all first */
- while (c < SvEND(sv)) {
- if (*c & 0x80) {
- I32 len;
- UV uv = utf8_to_uv((U8*)c, &len);
- if (uv >= 256) {
- if (fail_ok)
- return FALSE;
- else {
- /* XXX might want to make a callback here instead */
- Perl_croak(aTHX_ "Big byte");
- }
- }
- if (!first_hi)
- first_hi = c;
- c += len;
- }
- else {
- c++;
- }
- }
-
- if (first_hi) {
- char *src = first_hi;
- char *dst = first_hi;
- while (src < SvEND(sv)) {
- if (*src & 0x80) {
- I32 len;
- U8 u = (U8)utf8_to_uv((U8*)src, &len);
- *dst++ = u;
- src += len;
- }
- else {
- *dst++ = *src++;
- }
- }
- SvCUR_set(sv, dst - SvPVX(sv));
- }
- SvUTF8_off(sv);
+ 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;
+ }
}
+ 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);
- while (c < SvEND(sv)) {
- if (*c & 0x80) {
- I32 len;
- (void)utf8_to_uv((U8*)c, &len);
- if (len == 1) {
- /* bad utf8 */
- return FALSE;
- }
- c += len;
- has_utf = TRUE;
- }
- else {
- c++;
- }
+ c = (U8 *) SvPVX(sv);
+ if (!is_utf8_string(c, SvCUR(sv)+1))
+ return FALSE;
+ e = (U8 *) SvEND(sv);
+ while (c < e) {
+ U8 ch = *c++;
+ if (!UTF8_IS_INVARIANT(ch)) {
+ SvUTF8_on(sv);
+ break;
+ }
}
-
- if (has_utf)
- SvUTF8_on(sv);
}
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 &&
PL_sortcop == CvSTART(cv))
- Perl_croak(aTHX_
+ 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? */
+ !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
+ 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);
}
=for apidoc sv_usepvn
Tells an SV to use C<ptr> to find its string value. Normally the string is
-stored inside the SV but sv_usepvn allows the SV to use an outside string.
+stored inside the SV but sv_usepvn allows the SV to use an outside string.
The C<ptr> should point to memory that was allocated by C<malloc>. The
string length, C<len>, must be supplied. This function will realloc the
memory pointed to by C<ptr>, so that pointer should not be freed or used by
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 (PL_curcop != &PL_compiling)
+ if (SvFAKE(sv)) {
+ char *pvx = SvPVX(sv);
+ STRLEN len = SvCUR(sv);
+ U32 hash = SvUVX(sv);
+ SvGROW(sv, len + 1);
+ Move(pvx,SvPVX(sv),len,char);
+ *SvEND(sv) = '\0';
+ SvFAKE_off(sv);
+ SvREADONLY_off(sv);
+ 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.
+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)
{
register SV *sv;
-
+
new_SV(sv);
if (len) {
sv_upgrade(sv, SVt_PV);
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
*/
Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
{
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;
tsv = SvRV(sv);
sv_add_backref(tsv, sv);
SvWEAKREF_on(sv);
- SvREFCNT_dec(tsv);
+ SvREFCNT_dec(tsv);
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);
}
-STATIC void
+/* 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)
{
AV *av;
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);
register char *bigend;
register I32 i;
STRLEN curlen;
-
+
if (!bigstr)
Perl_croak(aTHX_ "Can't modify non-existent substring");
=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),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
+ SvFAKE_off(sv);
+ }
break;
/*
case SVt_NV:
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
*/
{
STRLEN cur1, cur2;
char *pv1, *pv2;
- I32 cmp;
+ I32 cmp;
bool pv1tmp = FALSE;
bool pv2tmp = FALSE;
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 */
/* See if we know enough about I/O mechanism to cheat it ! */
/* This used to be #ifdef test - it is made run-time test for ease
- of abstracting out stdio interface. One call should be cheap
+ of abstracting out stdio interface. One call should be cheap
enough here - and may even be a macro allowing compile
time optimization.
*/
"Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
+ PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
for (;;) {
screamer:
}
}
else {
- Copy(ptr, bp, cnt, char); /* this | eat */
- bp += cnt; /* screams | dust */
+ Copy(ptr, bp, cnt, char); /* this | eat */
+ bp += cnt; /* screams | dust */
ptr += cnt; /* louder | sed :-) */
cnt = 0;
}
PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
+ PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
- /* This used to call 'filbuf' in stdio form, but as that behaves like
+ /* This used to call 'filbuf' in stdio form, but as that behaves like
getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
another abstraction. */
i = PerlIO_getc(fp); /* get more characters */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
+ PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
cnt = PerlIO_get_cnt(fp);
ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
+ PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
*bp = '\0';
SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
}
}
- if (RsPARA(PL_rs)) { /* have to do this both before and after */
+ if (RsPARA(PL_rs)) { /* have to do this both before and after */
while (i != EOF) { /* to make sure file boundaries work right */
i = PerlIO_getc(fp);
if (i != '\n') {
}
}
+ 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--;
/* MKS: The original code here died if letters weren't consecutive.
* at least it didn't have to worry about non-C locales. The
* new code assumes that ('z'-'a')==('Z'-'A'), letters are
- * arranged in order (although not consecutively) and that only
+ * arranged in order (although not consecutively) and that only
* [A-Za-z] are accepted by isALPHA in the C locale.
*/
if (*d != 'z' && *d != 'Z') {
/*
=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);
else {
(void)SvIOK_only_UV(sv);
--SvUVX(sv);
- }
+ }
} else {
if (SvIVX(sv) == IV_MIN)
sv_setnv(sv, (NV)IV_MIN - 1.0);
else {
(void)SvIOK_only(sv);
--SvIVX(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
Creates a new SV and copies a string into it. The reference count for the
-SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
+SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
string. You are responsible for ensuring that the source string is at least
C<len> bytes long.
return sv;
}
+/*
+=for apidoc newSVpvn_share
+
+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, 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, 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));
-#ifndef VMS /* 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))
sv_force_normal(sv);
-
+
if (SvPOK(sv)) {
*lp = SvCUR(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;
-
+
if (SvROK(sv))
sv_unref(sv);
(void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
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);
SV_CHECK_THINKFIRST(rv);
SvAMAGIC_off(rv);
+ if (SvTYPE(rv) >= SVt_PVMG) {
+ U32 refcnt = SvREFCNT(rv);
+ SvREFCNT(rv) = 0;
+ sv_clear(rv);
+ SvFLAGS(rv) = 0;
+ SvREFCNT(rv) = refcnt;
+ }
+
if (SvTYPE(rv) < SVt_RV)
- sv_upgrade(rv, SVt_RV);
+ sv_upgrade(rv, SVt_RV);
+ else if (SvTYPE(rv) > SVt_RV) {
+ (void)SvOOK_off(rv);
+ if (SvPVX(rv) && SvLEN(rv))
+ Safefree(SvPVX(rv));
+ SvCUR_set(rv, 0);
+ SvLEN_set(rv, 0);
+ }
(void)SvOK_off(rv);
SvRV(rv) = 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);
p = q;
}
- if (q++ >= patend)
- break;
+ 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 */
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;
+ }
- 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 (!asterisk)
+ EXPECT_NUMBER(q, width);
+
+ 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) {
-#ifdef HAS_QUAD
+#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
case 'L': /* Ld */
+ /* FALL THROUGH */
+#endif
+#ifdef HAS_QUAD
case 'q': /* qd */
intsize = 'q';
q++;
break;
#endif
case 'l':
-#ifdef HAS_QUAD
- if (*(q + 1) == 'l') { /* lld */
+#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
+ if (*(q + 1) == 'l') { /* lld, llf */
intsize = 'q';
q += 2;
break;
/* 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(vecstr, &ulen);
+ 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(vecstr, &ulen);
+ 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 = ebuf + sizeof ebuf;
*--eptr = '\0';
*--eptr = c;
-#ifdef USE_LONG_DOUBLE
+#if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
{
- static char const my_prifldbl[] = PERL_PRIfldbl;
- char const *p = my_prifldbl + sizeof my_prifldbl - 3;
- while (p >= my_prifldbl) { *--eptr = *p--; }
+ /* Copy the one or more characters in a long double
+ * format before the 'base' ([efgEFG]) character to
+ * the format string. */
+ static char const prifldbl[] = PERL_PRIfldbl;
+ char const *p = prifldbl + sizeof(prifldbl) - 3;
+ while (p >= prifldbl) { *--eptr = *p--; }
}
#endif
if (has_precis) {
*--eptr = '#';
*--eptr = '%';
- {
- RESTORE_NUMERIC_STANDARD();
- (void)sprintf(PL_efloatbuf, eptr, nv);
- RESTORE_NUMERIC_LOCAL();
- }
+ /* 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 */
(PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
if (c) {
if (isPRINT(c))
- Perl_sv_catpvf(aTHX_ msg,
+ Perl_sv_catpvf(aTHX_ msg,
"\"%%%c\"", c & 0xFF);
else
Perl_sv_catpvf(aTHX_ msg,
/* ... 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));)
- 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