3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
8 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
11 * This file contains the code that creates, manipulates and destroys
12 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
13 * structure of an SV, so their creation and destruction is handled
14 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
15 * level functions (eg. substr, split, join) for each of the types are
26 #ifdef PERL_COPY_ON_WRITE
27 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
28 #define SV_COW_NEXT_SV_SET(current,next) SvUVX(current) = PTR2UV(next)
29 /* This is a pessamistic view. Scalar must be purely a read-write PV to copy-
31 #define CAN_COW_MASK (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \
32 SVf_POK|SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE| \
33 SVf_OOK|SVf_BREAK|SVf_READONLY|SVf_AMAGIC)
34 #define CAN_COW_FLAGS (SVp_POK|SVf_POK)
37 /* ============================================================================
39 =head1 Allocation and deallocation of SVs.
41 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
42 av, hv...) contains type and reference count information, as well as a
43 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
44 specific to each type.
46 Normally, this allocation is done using arenas, which are approximately
47 1K chunks of memory parcelled up into N heads or bodies. The first slot
48 in each arena is reserved, and is used to hold a link to the next arena.
49 In the case of heads, the unused first slot also contains some flags and
50 a note of the number of slots. Snaked through each arena chain is a
51 linked list of free items; when this becomes empty, an extra arena is
52 allocated and divided up into N items which are threaded into the free
55 The following global variables are associated with arenas:
57 PL_sv_arenaroot pointer to list of SV arenas
58 PL_sv_root pointer to list of free SV structures
60 PL_foo_arenaroot pointer to list of foo arenas,
61 PL_foo_root pointer to list of free foo bodies
62 ... for foo in xiv, xnv, xrv, xpv etc.
64 Note that some of the larger and more rarely used body types (eg xpvio)
65 are not allocated using arenas, but are instead just malloc()/free()ed as
66 required. Also, if PURIFY is defined, arenas are abandoned altogether,
67 with all items individually malloc()ed. In addition, a few SV heads are
68 not allocated from an arena, but are instead directly created as static
69 or auto variables, eg PL_sv_undef.
71 The SV arena serves the secondary purpose of allowing still-live SVs
72 to be located and destroyed during final cleanup.
74 At the lowest level, the macros new_SV() and del_SV() grab and free
75 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
76 to return the SV to the free list with error checking.) new_SV() calls
77 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
78 SVs in the free list have their SvTYPE field set to all ones.
80 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
81 that allocate and return individual body types. Normally these are mapped
82 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
83 instead mapped directly to malloc()/free() if PURIFY is defined. The
84 new/del functions remove from, or add to, the appropriate PL_foo_root
85 list, and call more_xiv() etc to add a new arena if the list is empty.
87 At the time of very final cleanup, sv_free_arenas() is called from
88 perl_destruct() to physically free all the arenas allocated since the
89 start of the interpreter. Note that this also clears PL_he_arenaroot,
90 which is otherwise dealt with in hv.c.
92 Manipulation of any of the PL_*root pointers is protected by enclosing
93 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
94 if threads are enabled.
96 The function visit() scans the SV arenas list, and calls a specified
97 function for each SV it finds which is still live - ie which has an SvTYPE
98 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
99 following functions (specified as [function that calls visit()] / [function
100 called by visit() for each SV]):
102 sv_report_used() / do_report_used()
103 dump all remaining SVs (debugging aid)
105 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
106 Attempt to free all objects pointed to by RVs,
107 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
108 try to do the same for all objects indirectly
109 referenced by typeglobs too. Called once from
110 perl_destruct(), prior to calling sv_clean_all()
113 sv_clean_all() / do_clean_all()
114 SvREFCNT_dec(sv) each remaining SV, possibly
115 triggering an sv_free(). It also sets the
116 SVf_BREAK flag on the SV to indicate that the
117 refcnt has been artificially lowered, and thus
118 stopping sv_free() from giving spurious warnings
119 about SVs which unexpectedly have a refcnt
120 of zero. called repeatedly from perl_destruct()
121 until there are no SVs left.
125 Private API to rest of sv.c
129 new_XIV(), del_XIV(),
130 new_XNV(), del_XNV(),
135 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
140 ============================================================================ */
145 * "A time to plant, and a time to uproot what was planted..."
148 #define plant_SV(p) \
150 SvANY(p) = (void *)PL_sv_root; \
151 SvFLAGS(p) = SVTYPEMASK; \
156 /* sv_mutex must be held while calling uproot_SV() */
157 #define uproot_SV(p) \
160 PL_sv_root = (SV*)SvANY(p); \
165 /* new_SV(): return a new, empty SV head */
181 /* del_SV(): return an empty SV head to the free list */
196 S_del_sv(pTHX_ SV *p)
203 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
205 svend = &sva[SvREFCNT(sva)];
206 if (p >= sv && p < svend)
210 if (ckWARN_d(WARN_INTERNAL))
211 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
212 "Attempt to free non-arena SV: 0x%"UVxf,
220 #else /* ! DEBUGGING */
222 #define del_SV(p) plant_SV(p)
224 #endif /* DEBUGGING */
228 =head1 SV Manipulation Functions
230 =for apidoc sv_add_arena
232 Given a chunk of memory, link it to the head of the list of arenas,
233 and split it into a list of free SVs.
239 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
244 Zero(ptr, size, char);
246 /* The first SV in an arena isn't an SV. */
247 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
248 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
249 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
251 PL_sv_arenaroot = sva;
252 PL_sv_root = sva + 1;
254 svend = &sva[SvREFCNT(sva) - 1];
257 SvANY(sv) = (void *)(SV*)(sv + 1);
258 SvFLAGS(sv) = SVTYPEMASK;
262 SvFLAGS(sv) = SVTYPEMASK;
265 /* make some more SVs by adding another arena */
267 /* sv_mutex must be held while calling more_sv() */
274 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
275 PL_nice_chunk = Nullch;
276 PL_nice_chunk_size = 0;
279 char *chunk; /* must use New here to match call to */
280 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
281 sv_add_arena(chunk, 1008, 0);
287 /* visit(): call the named function for each non-free SV in the arenas. */
290 S_visit(pTHX_ SVFUNC_t f)
297 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
298 svend = &sva[SvREFCNT(sva)];
299 for (sv = sva + 1; sv < svend; ++sv) {
300 if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) {
311 /* called by sv_report_used() for each live SV */
314 do_report_used(pTHX_ SV *sv)
316 if (SvTYPE(sv) != SVTYPEMASK) {
317 PerlIO_printf(Perl_debug_log, "****\n");
324 =for apidoc sv_report_used
326 Dump the contents of all SVs not yet freed. (Debugging aid).
332 Perl_sv_report_used(pTHX)
335 visit(do_report_used);
339 /* called by sv_clean_objs() for each live SV */
342 do_clean_objs(pTHX_ SV *sv)
346 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
347 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
359 /* XXX Might want to check arrays, etc. */
362 /* called by sv_clean_objs() for each live SV */
364 #ifndef DISABLE_DESTRUCTOR_KLUDGE
366 do_clean_named_objs(pTHX_ SV *sv)
368 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
369 if ( SvOBJECT(GvSV(sv)) ||
370 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
371 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
372 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
373 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
375 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
383 =for apidoc sv_clean_objs
385 Attempt to destroy all objects not yet freed
391 Perl_sv_clean_objs(pTHX)
393 PL_in_clean_objs = TRUE;
394 visit(do_clean_objs);
395 #ifndef DISABLE_DESTRUCTOR_KLUDGE
396 /* some barnacles may yet remain, clinging to typeglobs */
397 visit(do_clean_named_objs);
399 PL_in_clean_objs = FALSE;
402 /* called by sv_clean_all() for each live SV */
405 do_clean_all(pTHX_ SV *sv)
407 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
408 SvFLAGS(sv) |= SVf_BREAK;
413 =for apidoc sv_clean_all
415 Decrement the refcnt of each remaining SV, possibly triggering a
416 cleanup. This function may have to be called multiple times to free
417 SVs which are in complex self-referential hierarchies.
423 Perl_sv_clean_all(pTHX)
426 PL_in_clean_all = TRUE;
427 cleaned = visit(do_clean_all);
428 PL_in_clean_all = FALSE;
433 =for apidoc sv_free_arenas
435 Deallocate the memory used by all arenas. Note that all the individual SV
436 heads and bodies within the arenas must already have been freed.
442 Perl_sv_free_arenas(pTHX)
446 XPV *arena, *arenanext;
448 /* Free arenas here, but be careful about fake ones. (We assume
449 contiguity of the fake ones with the corresponding real ones.) */
451 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
452 svanext = (SV*) SvANY(sva);
453 while (svanext && SvFAKE(svanext))
454 svanext = (SV*) SvANY(svanext);
457 Safefree((void *)sva);
460 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
461 arenanext = (XPV*)arena->xpv_pv;
464 PL_xiv_arenaroot = 0;
466 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
467 arenanext = (XPV*)arena->xpv_pv;
470 PL_xnv_arenaroot = 0;
472 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
473 arenanext = (XPV*)arena->xpv_pv;
476 PL_xrv_arenaroot = 0;
478 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
479 arenanext = (XPV*)arena->xpv_pv;
482 PL_xpv_arenaroot = 0;
484 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
485 arenanext = (XPV*)arena->xpv_pv;
488 PL_xpviv_arenaroot = 0;
490 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
491 arenanext = (XPV*)arena->xpv_pv;
494 PL_xpvnv_arenaroot = 0;
496 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
497 arenanext = (XPV*)arena->xpv_pv;
500 PL_xpvcv_arenaroot = 0;
502 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
503 arenanext = (XPV*)arena->xpv_pv;
506 PL_xpvav_arenaroot = 0;
508 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
509 arenanext = (XPV*)arena->xpv_pv;
512 PL_xpvhv_arenaroot = 0;
514 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
515 arenanext = (XPV*)arena->xpv_pv;
518 PL_xpvmg_arenaroot = 0;
520 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
521 arenanext = (XPV*)arena->xpv_pv;
524 PL_xpvlv_arenaroot = 0;
526 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
527 arenanext = (XPV*)arena->xpv_pv;
530 PL_xpvbm_arenaroot = 0;
532 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
533 arenanext = (XPV*)arena->xpv_pv;
539 Safefree(PL_nice_chunk);
540 PL_nice_chunk = Nullch;
541 PL_nice_chunk_size = 0;
547 =for apidoc report_uninit
549 Print appropriate "Use of uninitialized variable" warning
555 Perl_report_uninit(pTHX)
558 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
559 " in ", OP_DESC(PL_op));
561 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, "", "");
564 /* grab a new IV body from the free list, allocating more if necessary */
575 * See comment in more_xiv() -- RAM.
577 PL_xiv_root = *(IV**)xiv;
579 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
582 /* return an IV body to the free list */
585 S_del_xiv(pTHX_ XPVIV *p)
587 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
589 *(IV**)xiv = PL_xiv_root;
594 /* allocate another arena's worth of IV bodies */
602 New(705, ptr, 1008/sizeof(XPV), XPV);
603 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
604 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
607 xivend = &xiv[1008 / sizeof(IV) - 1];
608 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
610 while (xiv < xivend) {
611 *(IV**)xiv = (IV *)(xiv + 1);
617 /* grab a new NV body from the free list, allocating more if necessary */
627 PL_xnv_root = *(NV**)xnv;
629 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
632 /* return an NV body to the free list */
635 S_del_xnv(pTHX_ XPVNV *p)
637 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
639 *(NV**)xnv = PL_xnv_root;
644 /* allocate another arena's worth of NV bodies */
652 New(711, ptr, 1008/sizeof(XPV), XPV);
653 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
654 PL_xnv_arenaroot = ptr;
657 xnvend = &xnv[1008 / sizeof(NV) - 1];
658 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
660 while (xnv < xnvend) {
661 *(NV**)xnv = (NV*)(xnv + 1);
667 /* grab a new struct xrv from the free list, allocating more if necessary */
677 PL_xrv_root = (XRV*)xrv->xrv_rv;
682 /* return a struct xrv to the free list */
685 S_del_xrv(pTHX_ XRV *p)
688 p->xrv_rv = (SV*)PL_xrv_root;
693 /* allocate another arena's worth of struct xrv */
699 register XRV* xrvend;
701 New(712, ptr, 1008/sizeof(XPV), XPV);
702 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
703 PL_xrv_arenaroot = ptr;
706 xrvend = &xrv[1008 / sizeof(XRV) - 1];
707 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
709 while (xrv < xrvend) {
710 xrv->xrv_rv = (SV*)(xrv + 1);
716 /* grab a new struct xpv from the free list, allocating more if necessary */
726 PL_xpv_root = (XPV*)xpv->xpv_pv;
731 /* return a struct xpv to the free list */
734 S_del_xpv(pTHX_ XPV *p)
737 p->xpv_pv = (char*)PL_xpv_root;
742 /* allocate another arena's worth of struct xpv */
748 register XPV* xpvend;
749 New(713, xpv, 1008/sizeof(XPV), XPV);
750 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
751 PL_xpv_arenaroot = xpv;
753 xpvend = &xpv[1008 / sizeof(XPV) - 1];
755 while (xpv < xpvend) {
756 xpv->xpv_pv = (char*)(xpv + 1);
762 /* grab a new struct xpviv from the free list, allocating more if necessary */
771 xpviv = PL_xpviv_root;
772 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
777 /* return a struct xpviv to the free list */
780 S_del_xpviv(pTHX_ XPVIV *p)
783 p->xpv_pv = (char*)PL_xpviv_root;
788 /* allocate another arena's worth of struct xpviv */
793 register XPVIV* xpviv;
794 register XPVIV* xpvivend;
795 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
796 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
797 PL_xpviv_arenaroot = xpviv;
799 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
800 PL_xpviv_root = ++xpviv;
801 while (xpviv < xpvivend) {
802 xpviv->xpv_pv = (char*)(xpviv + 1);
808 /* grab a new struct xpvnv from the free list, allocating more if necessary */
817 xpvnv = PL_xpvnv_root;
818 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
823 /* return a struct xpvnv to the free list */
826 S_del_xpvnv(pTHX_ XPVNV *p)
829 p->xpv_pv = (char*)PL_xpvnv_root;
834 /* allocate another arena's worth of struct xpvnv */
839 register XPVNV* xpvnv;
840 register XPVNV* xpvnvend;
841 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
842 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
843 PL_xpvnv_arenaroot = xpvnv;
845 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
846 PL_xpvnv_root = ++xpvnv;
847 while (xpvnv < xpvnvend) {
848 xpvnv->xpv_pv = (char*)(xpvnv + 1);
854 /* grab a new struct xpvcv from the free list, allocating more if necessary */
863 xpvcv = PL_xpvcv_root;
864 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
869 /* return a struct xpvcv to the free list */
872 S_del_xpvcv(pTHX_ XPVCV *p)
875 p->xpv_pv = (char*)PL_xpvcv_root;
880 /* allocate another arena's worth of struct xpvcv */
885 register XPVCV* xpvcv;
886 register XPVCV* xpvcvend;
887 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
888 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
889 PL_xpvcv_arenaroot = xpvcv;
891 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
892 PL_xpvcv_root = ++xpvcv;
893 while (xpvcv < xpvcvend) {
894 xpvcv->xpv_pv = (char*)(xpvcv + 1);
900 /* grab a new struct xpvav from the free list, allocating more if necessary */
909 xpvav = PL_xpvav_root;
910 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
915 /* return a struct xpvav to the free list */
918 S_del_xpvav(pTHX_ XPVAV *p)
921 p->xav_array = (char*)PL_xpvav_root;
926 /* allocate another arena's worth of struct xpvav */
931 register XPVAV* xpvav;
932 register XPVAV* xpvavend;
933 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
934 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
935 PL_xpvav_arenaroot = xpvav;
937 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
938 PL_xpvav_root = ++xpvav;
939 while (xpvav < xpvavend) {
940 xpvav->xav_array = (char*)(xpvav + 1);
943 xpvav->xav_array = 0;
946 /* grab a new struct xpvhv from the free list, allocating more if necessary */
955 xpvhv = PL_xpvhv_root;
956 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
961 /* return a struct xpvhv to the free list */
964 S_del_xpvhv(pTHX_ XPVHV *p)
967 p->xhv_array = (char*)PL_xpvhv_root;
972 /* allocate another arena's worth of struct xpvhv */
977 register XPVHV* xpvhv;
978 register XPVHV* xpvhvend;
979 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
980 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
981 PL_xpvhv_arenaroot = xpvhv;
983 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
984 PL_xpvhv_root = ++xpvhv;
985 while (xpvhv < xpvhvend) {
986 xpvhv->xhv_array = (char*)(xpvhv + 1);
989 xpvhv->xhv_array = 0;
992 /* grab a new struct xpvmg from the free list, allocating more if necessary */
1001 xpvmg = PL_xpvmg_root;
1002 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
1007 /* return a struct xpvmg to the free list */
1010 S_del_xpvmg(pTHX_ XPVMG *p)
1013 p->xpv_pv = (char*)PL_xpvmg_root;
1018 /* allocate another arena's worth of struct xpvmg */
1023 register XPVMG* xpvmg;
1024 register XPVMG* xpvmgend;
1025 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
1026 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
1027 PL_xpvmg_arenaroot = xpvmg;
1029 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
1030 PL_xpvmg_root = ++xpvmg;
1031 while (xpvmg < xpvmgend) {
1032 xpvmg->xpv_pv = (char*)(xpvmg + 1);
1038 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1047 xpvlv = PL_xpvlv_root;
1048 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
1053 /* return a struct xpvlv to the free list */
1056 S_del_xpvlv(pTHX_ XPVLV *p)
1059 p->xpv_pv = (char*)PL_xpvlv_root;
1064 /* allocate another arena's worth of struct xpvlv */
1069 register XPVLV* xpvlv;
1070 register XPVLV* xpvlvend;
1071 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
1072 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
1073 PL_xpvlv_arenaroot = xpvlv;
1075 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
1076 PL_xpvlv_root = ++xpvlv;
1077 while (xpvlv < xpvlvend) {
1078 xpvlv->xpv_pv = (char*)(xpvlv + 1);
1084 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1093 xpvbm = PL_xpvbm_root;
1094 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
1099 /* return a struct xpvbm to the free list */
1102 S_del_xpvbm(pTHX_ XPVBM *p)
1105 p->xpv_pv = (char*)PL_xpvbm_root;
1110 /* allocate another arena's worth of struct xpvbm */
1115 register XPVBM* xpvbm;
1116 register XPVBM* xpvbmend;
1117 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
1118 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
1119 PL_xpvbm_arenaroot = xpvbm;
1121 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
1122 PL_xpvbm_root = ++xpvbm;
1123 while (xpvbm < xpvbmend) {
1124 xpvbm->xpv_pv = (char*)(xpvbm + 1);
1130 #define my_safemalloc(s) (void*)safemalloc(s)
1131 #define my_safefree(p) safefree((char*)p)
1135 #define new_XIV() my_safemalloc(sizeof(XPVIV))
1136 #define del_XIV(p) my_safefree(p)
1138 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1139 #define del_XNV(p) my_safefree(p)
1141 #define new_XRV() my_safemalloc(sizeof(XRV))
1142 #define del_XRV(p) my_safefree(p)
1144 #define new_XPV() my_safemalloc(sizeof(XPV))
1145 #define del_XPV(p) my_safefree(p)
1147 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1148 #define del_XPVIV(p) my_safefree(p)
1150 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1151 #define del_XPVNV(p) my_safefree(p)
1153 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1154 #define del_XPVCV(p) my_safefree(p)
1156 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1157 #define del_XPVAV(p) my_safefree(p)
1159 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1160 #define del_XPVHV(p) my_safefree(p)
1162 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1163 #define del_XPVMG(p) my_safefree(p)
1165 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1166 #define del_XPVLV(p) my_safefree(p)
1168 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1169 #define del_XPVBM(p) my_safefree(p)
1173 #define new_XIV() (void*)new_xiv()
1174 #define del_XIV(p) del_xiv((XPVIV*) p)
1176 #define new_XNV() (void*)new_xnv()
1177 #define del_XNV(p) del_xnv((XPVNV*) p)
1179 #define new_XRV() (void*)new_xrv()
1180 #define del_XRV(p) del_xrv((XRV*) p)
1182 #define new_XPV() (void*)new_xpv()
1183 #define del_XPV(p) del_xpv((XPV *)p)
1185 #define new_XPVIV() (void*)new_xpviv()
1186 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
1188 #define new_XPVNV() (void*)new_xpvnv()
1189 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
1191 #define new_XPVCV() (void*)new_xpvcv()
1192 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
1194 #define new_XPVAV() (void*)new_xpvav()
1195 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
1197 #define new_XPVHV() (void*)new_xpvhv()
1198 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1200 #define new_XPVMG() (void*)new_xpvmg()
1201 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
1203 #define new_XPVLV() (void*)new_xpvlv()
1204 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
1206 #define new_XPVBM() (void*)new_xpvbm()
1207 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
1211 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1212 #define del_XPVGV(p) my_safefree(p)
1214 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1215 #define del_XPVFM(p) my_safefree(p)
1217 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1218 #define del_XPVIO(p) my_safefree(p)
1221 =for apidoc sv_upgrade
1223 Upgrade an SV to a more complex form. Generally adds a new body type to the
1224 SV, then copies across as much information as possible from the old body.
1225 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1231 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1238 MAGIC* magic = NULL;
1241 if (mt != SVt_PV && SvIsCOW(sv)) {
1242 sv_force_normal_flags(sv, 0);
1245 if (SvTYPE(sv) == mt)
1249 (void)SvOOK_off(sv);
1251 switch (SvTYPE(sv)) {
1272 else if (mt < SVt_PVIV)
1289 pv = (char*)SvRV(sv);
1309 else if (mt == SVt_NV)
1320 del_XPVIV(SvANY(sv));
1330 del_XPVNV(SvANY(sv));
1338 magic = SvMAGIC(sv);
1339 stash = SvSTASH(sv);
1340 del_XPVMG(SvANY(sv));
1343 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1348 Perl_croak(aTHX_ "Can't upgrade to undef");
1350 SvANY(sv) = new_XIV();
1354 SvANY(sv) = new_XNV();
1358 SvANY(sv) = new_XRV();
1362 SvANY(sv) = new_XPV();
1368 SvANY(sv) = new_XPVIV();
1378 SvANY(sv) = new_XPVNV();
1386 SvANY(sv) = new_XPVMG();
1392 SvMAGIC(sv) = magic;
1393 SvSTASH(sv) = stash;
1396 SvANY(sv) = new_XPVLV();
1402 SvMAGIC(sv) = magic;
1403 SvSTASH(sv) = stash;
1410 SvANY(sv) = new_XPVAV();
1418 SvMAGIC(sv) = magic;
1419 SvSTASH(sv) = stash;
1425 SvANY(sv) = new_XPVHV();
1431 HvTOTALKEYS(sv) = 0;
1432 HvPLACEHOLDERS(sv) = 0;
1433 SvMAGIC(sv) = magic;
1434 SvSTASH(sv) = stash;
1441 SvANY(sv) = new_XPVCV();
1442 Zero(SvANY(sv), 1, XPVCV);
1448 SvMAGIC(sv) = magic;
1449 SvSTASH(sv) = stash;
1452 SvANY(sv) = new_XPVGV();
1458 SvMAGIC(sv) = magic;
1459 SvSTASH(sv) = stash;
1467 SvANY(sv) = new_XPVBM();
1473 SvMAGIC(sv) = magic;
1474 SvSTASH(sv) = stash;
1480 SvANY(sv) = new_XPVFM();
1481 Zero(SvANY(sv), 1, XPVFM);
1487 SvMAGIC(sv) = magic;
1488 SvSTASH(sv) = stash;
1491 SvANY(sv) = new_XPVIO();
1492 Zero(SvANY(sv), 1, XPVIO);
1498 SvMAGIC(sv) = magic;
1499 SvSTASH(sv) = stash;
1500 IoPAGE_LEN(sv) = 60;
1503 SvFLAGS(sv) &= ~SVTYPEMASK;
1509 =for apidoc sv_backoff
1511 Remove any string offset. You should normally use the C<SvOOK_off> macro
1518 Perl_sv_backoff(pTHX_ register SV *sv)
1522 char *s = SvPVX(sv);
1523 SvLEN(sv) += SvIVX(sv);
1524 SvPVX(sv) -= SvIVX(sv);
1526 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1528 SvFLAGS(sv) &= ~SVf_OOK;
1535 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1536 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1537 Use the C<SvGROW> wrapper instead.
1543 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1549 #ifdef HAS_64K_LIMIT
1550 if (newlen >= 0x10000) {
1551 PerlIO_printf(Perl_debug_log,
1552 "Allocation too large: %"UVxf"\n", (UV)newlen);
1555 #endif /* HAS_64K_LIMIT */
1558 if (SvTYPE(sv) < SVt_PV) {
1559 sv_upgrade(sv, SVt_PV);
1562 else if (SvOOK(sv)) { /* pv is offset? */
1565 if (newlen > SvLEN(sv))
1566 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1567 #ifdef HAS_64K_LIMIT
1568 if (newlen >= 0x10000)
1575 if (newlen > SvLEN(sv)) { /* need more room? */
1576 if (SvLEN(sv) && s) {
1578 STRLEN l = malloced_size((void*)SvPVX(sv));
1584 Renew(s,newlen,char);
1587 New(703, s, newlen, char);
1588 if (SvPVX(sv) && SvCUR(sv)) {
1589 Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1593 SvLEN_set(sv, newlen);
1599 =for apidoc sv_setiv
1601 Copies an integer into the given SV, upgrading first if necessary.
1602 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1608 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1610 SV_CHECK_THINKFIRST_COW_DROP(sv);
1611 switch (SvTYPE(sv)) {
1613 sv_upgrade(sv, SVt_IV);
1616 sv_upgrade(sv, SVt_PVNV);
1620 sv_upgrade(sv, SVt_PVIV);
1629 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1632 (void)SvIOK_only(sv); /* validate number */
1638 =for apidoc sv_setiv_mg
1640 Like C<sv_setiv>, but also handles 'set' magic.
1646 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1653 =for apidoc sv_setuv
1655 Copies an unsigned integer into the given SV, upgrading first if necessary.
1656 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1662 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1664 /* With these two if statements:
1665 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1668 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1670 If you wish to remove them, please benchmark to see what the effect is
1672 if (u <= (UV)IV_MAX) {
1673 sv_setiv(sv, (IV)u);
1682 =for apidoc sv_setuv_mg
1684 Like C<sv_setuv>, but also handles 'set' magic.
1690 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1692 /* With these two if statements:
1693 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1696 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1698 If you wish to remove them, please benchmark to see what the effect is
1700 if (u <= (UV)IV_MAX) {
1701 sv_setiv(sv, (IV)u);
1711 =for apidoc sv_setnv
1713 Copies a double into the given SV, upgrading first if necessary.
1714 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1720 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1722 SV_CHECK_THINKFIRST_COW_DROP(sv);
1723 switch (SvTYPE(sv)) {
1726 sv_upgrade(sv, SVt_NV);
1731 sv_upgrade(sv, SVt_PVNV);
1740 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1744 (void)SvNOK_only(sv); /* validate number */
1749 =for apidoc sv_setnv_mg
1751 Like C<sv_setnv>, but also handles 'set' magic.
1757 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1763 /* Print an "isn't numeric" warning, using a cleaned-up,
1764 * printable version of the offending string
1768 S_not_a_number(pTHX_ SV *sv)
1775 dsv = sv_2mortal(newSVpv("", 0));
1776 pv = sv_uni_display(dsv, sv, 10, 0);
1779 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1780 /* each *s can expand to 4 chars + "...\0",
1781 i.e. need room for 8 chars */
1784 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
1786 if (ch & 128 && !isPRINT_LC(ch)) {
1795 else if (ch == '\r') {
1799 else if (ch == '\f') {
1803 else if (ch == '\\') {
1807 else if (ch == '\0') {
1811 else if (isPRINT_LC(ch))
1828 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1829 "Argument \"%s\" isn't numeric in %s", pv,
1832 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1833 "Argument \"%s\" isn't numeric", pv);
1837 =for apidoc looks_like_number
1839 Test if the content of an SV looks like a number (or is a number).
1840 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1841 non-numeric warning), even if your atof() doesn't grok them.
1847 Perl_looks_like_number(pTHX_ SV *sv)
1849 register char *sbegin;
1856 else if (SvPOKp(sv))
1857 sbegin = SvPV(sv, len);
1859 return 1; /* Historic. Wrong? */
1860 return grok_number(sbegin, len, NULL);
1863 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1864 until proven guilty, assume that things are not that bad... */
1869 As 64 bit platforms often have an NV that doesn't preserve all bits of
1870 an IV (an assumption perl has been based on to date) it becomes necessary
1871 to remove the assumption that the NV always carries enough precision to
1872 recreate the IV whenever needed, and that the NV is the canonical form.
1873 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1874 precision as a side effect of conversion (which would lead to insanity
1875 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1876 1) to distinguish between IV/UV/NV slots that have cached a valid
1877 conversion where precision was lost and IV/UV/NV slots that have a
1878 valid conversion which has lost no precision
1879 2) to ensure that if a numeric conversion to one form is requested that
1880 would lose precision, the precise conversion (or differently
1881 imprecise conversion) is also performed and cached, to prevent
1882 requests for different numeric formats on the same SV causing
1883 lossy conversion chains. (lossless conversion chains are perfectly
1888 SvIOKp is true if the IV slot contains a valid value
1889 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1890 SvNOKp is true if the NV slot contains a valid value
1891 SvNOK is true only if the NV value is accurate
1894 while converting from PV to NV, check to see if converting that NV to an
1895 IV(or UV) would lose accuracy over a direct conversion from PV to
1896 IV(or UV). If it would, cache both conversions, return NV, but mark
1897 SV as IOK NOKp (ie not NOK).
1899 While converting from PV to IV, check to see if converting that IV to an
1900 NV would lose accuracy over a direct conversion from PV to NV. If it
1901 would, cache both conversions, flag similarly.
1903 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1904 correctly because if IV & NV were set NV *always* overruled.
1905 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1906 changes - now IV and NV together means that the two are interchangeable:
1907 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1909 The benefit of this is that operations such as pp_add know that if
1910 SvIOK is true for both left and right operands, then integer addition
1911 can be used instead of floating point (for cases where the result won't
1912 overflow). Before, floating point was always used, which could lead to
1913 loss of precision compared with integer addition.
1915 * making IV and NV equal status should make maths accurate on 64 bit
1917 * may speed up maths somewhat if pp_add and friends start to use
1918 integers when possible instead of fp. (Hopefully the overhead in
1919 looking for SvIOK and checking for overflow will not outweigh the
1920 fp to integer speedup)
1921 * will slow down integer operations (callers of SvIV) on "inaccurate"
1922 values, as the change from SvIOK to SvIOKp will cause a call into
1923 sv_2iv each time rather than a macro access direct to the IV slot
1924 * should speed up number->string conversion on integers as IV is
1925 favoured when IV and NV are equally accurate
1927 ####################################################################
1928 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1929 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1930 On the other hand, SvUOK is true iff UV.
1931 ####################################################################
1933 Your mileage will vary depending your CPU's relative fp to integer
1937 #ifndef NV_PRESERVES_UV
1938 # define IS_NUMBER_UNDERFLOW_IV 1
1939 # define IS_NUMBER_UNDERFLOW_UV 2
1940 # define IS_NUMBER_IV_AND_UV 2
1941 # define IS_NUMBER_OVERFLOW_IV 4
1942 # define IS_NUMBER_OVERFLOW_UV 5
1944 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1946 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1948 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1950 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
1951 if (SvNVX(sv) < (NV)IV_MIN) {
1952 (void)SvIOKp_on(sv);
1955 return IS_NUMBER_UNDERFLOW_IV;
1957 if (SvNVX(sv) > (NV)UV_MAX) {
1958 (void)SvIOKp_on(sv);
1962 return IS_NUMBER_OVERFLOW_UV;
1964 (void)SvIOKp_on(sv);
1966 /* Can't use strtol etc to convert this string. (See truth table in
1968 if (SvNVX(sv) <= (UV)IV_MAX) {
1969 SvIVX(sv) = I_V(SvNVX(sv));
1970 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1971 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1973 /* Integer is imprecise. NOK, IOKp */
1975 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1978 SvUVX(sv) = U_V(SvNVX(sv));
1979 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1980 if (SvUVX(sv) == UV_MAX) {
1981 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1982 possibly be preserved by NV. Hence, it must be overflow.
1984 return IS_NUMBER_OVERFLOW_UV;
1986 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1988 /* Integer is imprecise. NOK, IOKp */
1990 return IS_NUMBER_OVERFLOW_IV;
1992 #endif /* !NV_PRESERVES_UV*/
1997 Return the integer value of an SV, doing any necessary string conversion,
1998 magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2004 Perl_sv_2iv(pTHX_ register SV *sv)
2008 if (SvGMAGICAL(sv)) {
2013 return I_V(SvNVX(sv));
2015 if (SvPOKp(sv) && SvLEN(sv))
2018 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2019 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2025 if (SvTHINKFIRST(sv)) {
2028 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2029 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2030 return SvIV(tmpstr);
2031 return PTR2IV(SvRV(sv));
2034 sv_force_normal_flags(sv, 0);
2036 if (SvREADONLY(sv) && !SvOK(sv)) {
2037 if (ckWARN(WARN_UNINITIALIZED))
2044 return (IV)(SvUVX(sv));
2051 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2052 * without also getting a cached IV/UV from it at the same time
2053 * (ie PV->NV conversion should detect loss of accuracy and cache
2054 * IV or UV at same time to avoid this. NWC */
2056 if (SvTYPE(sv) == SVt_NV)
2057 sv_upgrade(sv, SVt_PVNV);
2059 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2060 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2061 certainly cast into the IV range at IV_MAX, whereas the correct
2062 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2064 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2065 SvIVX(sv) = I_V(SvNVX(sv));
2066 if (SvNVX(sv) == (NV) SvIVX(sv)
2067 #ifndef NV_PRESERVES_UV
2068 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2069 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2070 /* Don't flag it as "accurately an integer" if the number
2071 came from a (by definition imprecise) NV operation, and
2072 we're outside the range of NV integer precision */
2075 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2076 DEBUG_c(PerlIO_printf(Perl_debug_log,
2077 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2083 /* IV not precise. No need to convert from PV, as NV
2084 conversion would already have cached IV if it detected
2085 that PV->IV would be better than PV->NV->IV
2086 flags already correct - don't set public IOK. */
2087 DEBUG_c(PerlIO_printf(Perl_debug_log,
2088 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2093 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2094 but the cast (NV)IV_MIN rounds to a the value less (more
2095 negative) than IV_MIN which happens to be equal to SvNVX ??
2096 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2097 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2098 (NV)UVX == NVX are both true, but the values differ. :-(
2099 Hopefully for 2s complement IV_MIN is something like
2100 0x8000000000000000 which will be exact. NWC */
2103 SvUVX(sv) = U_V(SvNVX(sv));
2105 (SvNVX(sv) == (NV) SvUVX(sv))
2106 #ifndef NV_PRESERVES_UV
2107 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2108 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2109 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2110 /* Don't flag it as "accurately an integer" if the number
2111 came from a (by definition imprecise) NV operation, and
2112 we're outside the range of NV integer precision */
2118 DEBUG_c(PerlIO_printf(Perl_debug_log,
2119 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2123 return (IV)SvUVX(sv);
2126 else if (SvPOKp(sv) && SvLEN(sv)) {
2128 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2129 /* We want to avoid a possible problem when we cache an IV which
2130 may be later translated to an NV, and the resulting NV is not
2131 the same as the direct translation of the initial string
2132 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2133 be careful to ensure that the value with the .456 is around if the
2134 NV value is requested in the future).
2136 This means that if we cache such an IV, we need to cache the
2137 NV as well. Moreover, we trade speed for space, and do not
2138 cache the NV if we are sure it's not needed.
2141 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2142 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2143 == IS_NUMBER_IN_UV) {
2144 /* It's definitely an integer, only upgrade to PVIV */
2145 if (SvTYPE(sv) < SVt_PVIV)
2146 sv_upgrade(sv, SVt_PVIV);
2148 } else if (SvTYPE(sv) < SVt_PVNV)
2149 sv_upgrade(sv, SVt_PVNV);
2151 /* If NV preserves UV then we only use the UV value if we know that
2152 we aren't going to call atof() below. If NVs don't preserve UVs
2153 then the value returned may have more precision than atof() will
2154 return, even though value isn't perfectly accurate. */
2155 if ((numtype & (IS_NUMBER_IN_UV
2156 #ifdef NV_PRESERVES_UV
2159 )) == IS_NUMBER_IN_UV) {
2160 /* This won't turn off the public IOK flag if it was set above */
2161 (void)SvIOKp_on(sv);
2163 if (!(numtype & IS_NUMBER_NEG)) {
2165 if (value <= (UV)IV_MAX) {
2166 SvIVX(sv) = (IV)value;
2172 /* 2s complement assumption */
2173 if (value <= (UV)IV_MIN) {
2174 SvIVX(sv) = -(IV)value;
2176 /* Too negative for an IV. This is a double upgrade, but
2177 I'm assuming it will be rare. */
2178 if (SvTYPE(sv) < SVt_PVNV)
2179 sv_upgrade(sv, SVt_PVNV);
2183 SvNVX(sv) = -(NV)value;
2188 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2189 will be in the previous block to set the IV slot, and the next
2190 block to set the NV slot. So no else here. */
2192 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2193 != IS_NUMBER_IN_UV) {
2194 /* It wasn't an (integer that doesn't overflow the UV). */
2195 SvNVX(sv) = Atof(SvPVX(sv));
2197 if (! numtype && ckWARN(WARN_NUMERIC))
2200 #if defined(USE_LONG_DOUBLE)
2201 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2202 PTR2UV(sv), SvNVX(sv)));
2204 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2205 PTR2UV(sv), SvNVX(sv)));
2209 #ifdef NV_PRESERVES_UV
2210 (void)SvIOKp_on(sv);
2212 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2213 SvIVX(sv) = I_V(SvNVX(sv));
2214 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2217 /* Integer is imprecise. NOK, IOKp */
2219 /* UV will not work better than IV */
2221 if (SvNVX(sv) > (NV)UV_MAX) {
2223 /* Integer is inaccurate. NOK, IOKp, is UV */
2227 SvUVX(sv) = U_V(SvNVX(sv));
2228 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2229 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2233 /* Integer is imprecise. NOK, IOKp, is UV */
2239 #else /* NV_PRESERVES_UV */
2240 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2241 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2242 /* The IV slot will have been set from value returned by
2243 grok_number above. The NV slot has just been set using
2246 assert (SvIOKp(sv));
2248 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2249 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2250 /* Small enough to preserve all bits. */
2251 (void)SvIOKp_on(sv);
2253 SvIVX(sv) = I_V(SvNVX(sv));
2254 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2256 /* Assumption: first non-preserved integer is < IV_MAX,
2257 this NV is in the preserved range, therefore: */
2258 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2260 Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2264 0 0 already failed to read UV.
2265 0 1 already failed to read UV.
2266 1 0 you won't get here in this case. IV/UV
2267 slot set, public IOK, Atof() unneeded.
2268 1 1 already read UV.
2269 so there's no point in sv_2iuv_non_preserve() attempting
2270 to use atol, strtol, strtoul etc. */
2271 if (sv_2iuv_non_preserve (sv, numtype)
2272 >= IS_NUMBER_OVERFLOW_IV)
2276 #endif /* NV_PRESERVES_UV */
2279 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2281 if (SvTYPE(sv) < SVt_IV)
2282 /* Typically the caller expects that sv_any is not NULL now. */
2283 sv_upgrade(sv, SVt_IV);
2286 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2287 PTR2UV(sv),SvIVX(sv)));
2288 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2294 Return the unsigned integer value of an SV, doing any necessary string
2295 conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
2302 Perl_sv_2uv(pTHX_ register SV *sv)
2306 if (SvGMAGICAL(sv)) {
2311 return U_V(SvNVX(sv));
2312 if (SvPOKp(sv) && SvLEN(sv))
2315 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2316 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2322 if (SvTHINKFIRST(sv)) {
2325 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2326 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2327 return SvUV(tmpstr);
2328 return PTR2UV(SvRV(sv));
2331 sv_force_normal_flags(sv, 0);
2333 if (SvREADONLY(sv) && !SvOK(sv)) {
2334 if (ckWARN(WARN_UNINITIALIZED))
2344 return (UV)SvIVX(sv);
2348 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2349 * without also getting a cached IV/UV from it at the same time
2350 * (ie PV->NV conversion should detect loss of accuracy and cache
2351 * IV or UV at same time to avoid this. */
2352 /* IV-over-UV optimisation - choose to cache IV if possible */
2354 if (SvTYPE(sv) == SVt_NV)
2355 sv_upgrade(sv, SVt_PVNV);
2357 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2358 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2359 SvIVX(sv) = I_V(SvNVX(sv));
2360 if (SvNVX(sv) == (NV) SvIVX(sv)
2361 #ifndef NV_PRESERVES_UV
2362 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2363 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2364 /* Don't flag it as "accurately an integer" if the number
2365 came from a (by definition imprecise) NV operation, and
2366 we're outside the range of NV integer precision */
2369 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2370 DEBUG_c(PerlIO_printf(Perl_debug_log,
2371 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2377 /* IV not precise. No need to convert from PV, as NV
2378 conversion would already have cached IV if it detected
2379 that PV->IV would be better than PV->NV->IV
2380 flags already correct - don't set public IOK. */
2381 DEBUG_c(PerlIO_printf(Perl_debug_log,
2382 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2387 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2388 but the cast (NV)IV_MIN rounds to a the value less (more
2389 negative) than IV_MIN which happens to be equal to SvNVX ??
2390 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2391 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2392 (NV)UVX == NVX are both true, but the values differ. :-(
2393 Hopefully for 2s complement IV_MIN is something like
2394 0x8000000000000000 which will be exact. NWC */
2397 SvUVX(sv) = U_V(SvNVX(sv));
2399 (SvNVX(sv) == (NV) SvUVX(sv))
2400 #ifndef NV_PRESERVES_UV
2401 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2402 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2403 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2404 /* Don't flag it as "accurately an integer" if the number
2405 came from a (by definition imprecise) NV operation, and
2406 we're outside the range of NV integer precision */
2411 DEBUG_c(PerlIO_printf(Perl_debug_log,
2412 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2418 else if (SvPOKp(sv) && SvLEN(sv)) {
2420 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2422 /* We want to avoid a possible problem when we cache a UV which
2423 may be later translated to an NV, and the resulting NV is not
2424 the translation of the initial data.
2426 This means that if we cache such a UV, we need to cache the
2427 NV as well. Moreover, we trade speed for space, and do not
2428 cache the NV if not needed.
2431 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2432 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2433 == IS_NUMBER_IN_UV) {
2434 /* It's definitely an integer, only upgrade to PVIV */
2435 if (SvTYPE(sv) < SVt_PVIV)
2436 sv_upgrade(sv, SVt_PVIV);
2438 } else if (SvTYPE(sv) < SVt_PVNV)
2439 sv_upgrade(sv, SVt_PVNV);
2441 /* If NV preserves UV then we only use the UV value if we know that
2442 we aren't going to call atof() below. If NVs don't preserve UVs
2443 then the value returned may have more precision than atof() will
2444 return, even though it isn't accurate. */
2445 if ((numtype & (IS_NUMBER_IN_UV
2446 #ifdef NV_PRESERVES_UV
2449 )) == IS_NUMBER_IN_UV) {
2450 /* This won't turn off the public IOK flag if it was set above */
2451 (void)SvIOKp_on(sv);
2453 if (!(numtype & IS_NUMBER_NEG)) {
2455 if (value <= (UV)IV_MAX) {
2456 SvIVX(sv) = (IV)value;
2458 /* it didn't overflow, and it was positive. */
2463 /* 2s complement assumption */
2464 if (value <= (UV)IV_MIN) {
2465 SvIVX(sv) = -(IV)value;
2467 /* Too negative for an IV. This is a double upgrade, but
2468 I'm assuming it will be rare. */
2469 if (SvTYPE(sv) < SVt_PVNV)
2470 sv_upgrade(sv, SVt_PVNV);
2474 SvNVX(sv) = -(NV)value;
2480 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2481 != IS_NUMBER_IN_UV) {
2482 /* It wasn't an integer, or it overflowed the UV. */
2483 SvNVX(sv) = Atof(SvPVX(sv));
2485 if (! numtype && ckWARN(WARN_NUMERIC))
2488 #if defined(USE_LONG_DOUBLE)
2489 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2490 PTR2UV(sv), SvNVX(sv)));
2492 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2493 PTR2UV(sv), SvNVX(sv)));
2496 #ifdef NV_PRESERVES_UV
2497 (void)SvIOKp_on(sv);
2499 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2500 SvIVX(sv) = I_V(SvNVX(sv));
2501 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2504 /* Integer is imprecise. NOK, IOKp */
2506 /* UV will not work better than IV */
2508 if (SvNVX(sv) > (NV)UV_MAX) {
2510 /* Integer is inaccurate. NOK, IOKp, is UV */
2514 SvUVX(sv) = U_V(SvNVX(sv));
2515 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2516 NV preservse UV so can do correct comparison. */
2517 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2521 /* Integer is imprecise. NOK, IOKp, is UV */
2526 #else /* NV_PRESERVES_UV */
2527 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2528 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2529 /* The UV slot will have been set from value returned by
2530 grok_number above. The NV slot has just been set using
2533 assert (SvIOKp(sv));
2535 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2536 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2537 /* Small enough to preserve all bits. */
2538 (void)SvIOKp_on(sv);
2540 SvIVX(sv) = I_V(SvNVX(sv));
2541 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2543 /* Assumption: first non-preserved integer is < IV_MAX,
2544 this NV is in the preserved range, therefore: */
2545 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2547 Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2550 sv_2iuv_non_preserve (sv, numtype);
2552 #endif /* NV_PRESERVES_UV */
2556 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2557 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2560 if (SvTYPE(sv) < SVt_IV)
2561 /* Typically the caller expects that sv_any is not NULL now. */
2562 sv_upgrade(sv, SVt_IV);
2566 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2567 PTR2UV(sv),SvUVX(sv)));
2568 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2574 Return the num value of an SV, doing any necessary string or integer
2575 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2582 Perl_sv_2nv(pTHX_ register SV *sv)
2586 if (SvGMAGICAL(sv)) {
2590 if (SvPOKp(sv) && SvLEN(sv)) {
2591 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2592 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
2594 return Atof(SvPVX(sv));
2598 return (NV)SvUVX(sv);
2600 return (NV)SvIVX(sv);
2603 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2604 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2610 if (SvTHINKFIRST(sv)) {
2613 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2614 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2615 return SvNV(tmpstr);
2616 return PTR2NV(SvRV(sv));
2619 sv_force_normal_flags(sv, 0);
2621 if (SvREADONLY(sv) && !SvOK(sv)) {
2622 if (ckWARN(WARN_UNINITIALIZED))
2627 if (SvTYPE(sv) < SVt_NV) {
2628 if (SvTYPE(sv) == SVt_IV)
2629 sv_upgrade(sv, SVt_PVNV);
2631 sv_upgrade(sv, SVt_NV);
2632 #ifdef USE_LONG_DOUBLE
2634 STORE_NUMERIC_LOCAL_SET_STANDARD();
2635 PerlIO_printf(Perl_debug_log,
2636 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2637 PTR2UV(sv), SvNVX(sv));
2638 RESTORE_NUMERIC_LOCAL();
2642 STORE_NUMERIC_LOCAL_SET_STANDARD();
2643 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2644 PTR2UV(sv), SvNVX(sv));
2645 RESTORE_NUMERIC_LOCAL();
2649 else if (SvTYPE(sv) < SVt_PVNV)
2650 sv_upgrade(sv, SVt_PVNV);
2655 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2656 #ifdef NV_PRESERVES_UV
2659 /* Only set the public NV OK flag if this NV preserves the IV */
2660 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2661 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2662 : (SvIVX(sv) == I_V(SvNVX(sv))))
2668 else if (SvPOKp(sv) && SvLEN(sv)) {
2670 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2671 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2673 #ifdef NV_PRESERVES_UV
2674 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2675 == IS_NUMBER_IN_UV) {
2676 /* It's definitely an integer */
2677 SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
2679 SvNVX(sv) = Atof(SvPVX(sv));
2682 SvNVX(sv) = Atof(SvPVX(sv));
2683 /* Only set the public NV OK flag if this NV preserves the value in
2684 the PV at least as well as an IV/UV would.
2685 Not sure how to do this 100% reliably. */
2686 /* if that shift count is out of range then Configure's test is
2687 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2689 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2690 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2691 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2692 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2693 /* Can't use strtol etc to convert this string, so don't try.
2694 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2697 /* value has been set. It may not be precise. */
2698 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2699 /* 2s complement assumption for (UV)IV_MIN */
2700 SvNOK_on(sv); /* Integer is too negative. */
2705 if (numtype & IS_NUMBER_NEG) {
2706 SvIVX(sv) = -(IV)value;
2707 } else if (value <= (UV)IV_MAX) {
2708 SvIVX(sv) = (IV)value;
2714 if (numtype & IS_NUMBER_NOT_INT) {
2715 /* I believe that even if the original PV had decimals,
2716 they are lost beyond the limit of the FP precision.
2717 However, neither is canonical, so both only get p
2718 flags. NWC, 2000/11/25 */
2719 /* Both already have p flags, so do nothing */
2722 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2723 if (SvIVX(sv) == I_V(nv)) {
2728 /* It had no "." so it must be integer. */
2731 /* between IV_MAX and NV(UV_MAX).
2732 Could be slightly > UV_MAX */
2734 if (numtype & IS_NUMBER_NOT_INT) {
2735 /* UV and NV both imprecise. */
2737 UV nv_as_uv = U_V(nv);
2739 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2750 #endif /* NV_PRESERVES_UV */
2753 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2755 if (SvTYPE(sv) < SVt_NV)
2756 /* Typically the caller expects that sv_any is not NULL now. */
2757 /* XXX Ilya implies that this is a bug in callers that assume this
2758 and ideally should be fixed. */
2759 sv_upgrade(sv, SVt_NV);
2762 #if defined(USE_LONG_DOUBLE)
2764 STORE_NUMERIC_LOCAL_SET_STANDARD();
2765 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2766 PTR2UV(sv), SvNVX(sv));
2767 RESTORE_NUMERIC_LOCAL();
2771 STORE_NUMERIC_LOCAL_SET_STANDARD();
2772 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2773 PTR2UV(sv), SvNVX(sv));
2774 RESTORE_NUMERIC_LOCAL();
2780 /* asIV(): extract an integer from the string value of an SV.
2781 * Caller must validate PVX */
2784 S_asIV(pTHX_ SV *sv)
2787 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2789 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2790 == IS_NUMBER_IN_UV) {
2791 /* It's definitely an integer */
2792 if (numtype & IS_NUMBER_NEG) {
2793 if (value < (UV)IV_MIN)
2796 if (value < (UV)IV_MAX)
2801 if (ckWARN(WARN_NUMERIC))
2804 return I_V(Atof(SvPVX(sv)));
2807 /* asUV(): extract an unsigned integer from the string value of an SV
2808 * Caller must validate PVX */
2811 S_asUV(pTHX_ SV *sv)
2814 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2816 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2817 == IS_NUMBER_IN_UV) {
2818 /* It's definitely an integer */
2819 if (!(numtype & IS_NUMBER_NEG))
2823 if (ckWARN(WARN_NUMERIC))
2826 return U_V(Atof(SvPVX(sv)));
2830 =for apidoc sv_2pv_nolen
2832 Like C<sv_2pv()>, but doesn't return the length too. You should usually
2833 use the macro wrapper C<SvPV_nolen(sv)> instead.
2838 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2841 return sv_2pv(sv, &n_a);
2844 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2845 * UV as a string towards the end of buf, and return pointers to start and
2848 * We assume that buf is at least TYPE_CHARS(UV) long.
2852 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2854 char *ptr = buf + TYPE_CHARS(UV);
2868 *--ptr = '0' + (char)(uv % 10);
2877 =for apidoc sv_2pv_flags
2879 Returns a pointer to the string value of an SV, and sets *lp to its length.
2880 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2882 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2883 usually end up here too.
2889 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2894 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2895 char *tmpbuf = tbuf;
2901 if (SvGMAGICAL(sv)) {
2902 if (flags & SV_GMAGIC)
2910 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2912 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2917 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2922 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2923 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2930 if (SvTHINKFIRST(sv)) {
2933 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2934 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv)))) {
2935 char *pv = SvPV(tmpstr, *lp);
2949 switch (SvTYPE(sv)) {
2951 if ( ((SvFLAGS(sv) &
2952 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2953 == (SVs_OBJECT|SVs_RMG))
2954 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2955 regexp *re = (regexp *)mg->mg_obj;
2958 char *fptr = "msix";
2963 char need_newline = 0;
2964 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
2966 while((ch = *fptr++)) {
2968 reflags[left++] = ch;
2971 reflags[right--] = ch;
2976 reflags[left] = '-';
2980 mg->mg_len = re->prelen + 4 + left;
2982 * If /x was used, we have to worry about a regex
2983 * ending with a comment later being embedded
2984 * within another regex. If so, we don't want this
2985 * regex's "commentization" to leak out to the
2986 * right part of the enclosing regex, we must cap
2987 * it with a newline.
2989 * So, if /x was used, we scan backwards from the
2990 * end of the regex. If we find a '#' before we
2991 * find a newline, we need to add a newline
2992 * ourself. If we find a '\n' first (or if we
2993 * don't find '#' or '\n'), we don't need to add
2994 * anything. -jfriedl
2996 if (PMf_EXTENDED & re->reganch)
2998 char *endptr = re->precomp + re->prelen;
2999 while (endptr >= re->precomp)
3001 char c = *(endptr--);
3003 break; /* don't need another */
3005 /* we end while in a comment, so we
3007 mg->mg_len++; /* save space for it */
3008 need_newline = 1; /* note to add it */
3013 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3014 Copy("(?", mg->mg_ptr, 2, char);
3015 Copy(reflags, mg->mg_ptr+2, left, char);
3016 Copy(":", mg->mg_ptr+left+2, 1, char);
3017 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3019 mg->mg_ptr[mg->mg_len - 2] = '\n';
3020 mg->mg_ptr[mg->mg_len - 1] = ')';
3021 mg->mg_ptr[mg->mg_len] = 0;
3023 PL_reginterp_cnt += re->program[0].next_off;
3025 if (re->reganch & ROPT_UTF8)
3040 case SVt_PVBM: if (SvROK(sv))
3043 s = "SCALAR"; break;
3044 case SVt_PVLV: s = "LVALUE"; break;
3045 case SVt_PVAV: s = "ARRAY"; break;
3046 case SVt_PVHV: s = "HASH"; break;
3047 case SVt_PVCV: s = "CODE"; break;
3048 case SVt_PVGV: s = "GLOB"; break;
3049 case SVt_PVFM: s = "FORMAT"; break;
3050 case SVt_PVIO: s = "IO"; break;
3051 default: s = "UNKNOWN"; break;
3055 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
3058 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
3064 if (SvREADONLY(sv) && !SvOK(sv)) {
3065 if (ckWARN(WARN_UNINITIALIZED))
3071 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3072 /* I'm assuming that if both IV and NV are equally valid then
3073 converting the IV is going to be more efficient */
3074 U32 isIOK = SvIOK(sv);
3075 U32 isUIOK = SvIsUV(sv);
3076 char buf[TYPE_CHARS(UV)];
3079 if (SvTYPE(sv) < SVt_PVIV)
3080 sv_upgrade(sv, SVt_PVIV);
3082 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3084 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3085 SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
3086 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3087 SvCUR_set(sv, ebuf - ptr);
3097 else if (SvNOKp(sv)) {
3098 if (SvTYPE(sv) < SVt_PVNV)
3099 sv_upgrade(sv, SVt_PVNV);
3100 /* The +20 is pure guesswork. Configure test needed. --jhi */
3101 SvGROW(sv, NV_DIG + 20);
3103 olderrno = errno; /* some Xenix systems wipe out errno here */
3105 if (SvNVX(sv) == 0.0)
3106 (void)strcpy(s,"0");
3110 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3113 #ifdef FIXNEGATIVEZERO
3114 if (*s == '-' && s[1] == '0' && !s[2])
3124 if (ckWARN(WARN_UNINITIALIZED)
3125 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3128 if (SvTYPE(sv) < SVt_PV)
3129 /* Typically the caller expects that sv_any is not NULL now. */
3130 sv_upgrade(sv, SVt_PV);
3133 *lp = s - SvPVX(sv);
3136 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3137 PTR2UV(sv),SvPVX(sv)));
3141 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3142 /* Sneaky stuff here */
3146 tsv = newSVpv(tmpbuf, 0);
3162 len = strlen(tmpbuf);
3164 #ifdef FIXNEGATIVEZERO
3165 if (len == 2 && t[0] == '-' && t[1] == '0') {
3170 (void)SvUPGRADE(sv, SVt_PV);
3172 s = SvGROW(sv, len + 1);
3181 =for apidoc sv_copypv
3183 Copies a stringified representation of the source SV into the
3184 destination SV. Automatically performs any necessary mg_get and
3185 coercion of numeric values into strings. Guaranteed to preserve
3186 UTF-8 flag even from overloaded objects. Similar in nature to
3187 sv_2pv[_flags] but operates directly on an SV instead of just the
3188 string. Mostly uses sv_2pv_flags to do its work, except when that
3189 would lose the UTF-8'ness of the PV.
3195 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3200 sv_setpvn(dsv,s,len);
3208 =for apidoc sv_2pvbyte_nolen
3210 Return a pointer to the byte-encoded representation of the SV.
3211 May cause the SV to be downgraded from UTF8 as a side-effect.
3213 Usually accessed via the C<SvPVbyte_nolen> macro.
3219 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3222 return sv_2pvbyte(sv, &n_a);
3226 =for apidoc sv_2pvbyte
3228 Return a pointer to the byte-encoded representation of the SV, and set *lp
3229 to its length. May cause the SV to be downgraded from UTF8 as a
3232 Usually accessed via the C<SvPVbyte> macro.
3238 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3240 sv_utf8_downgrade(sv,0);
3241 return SvPV(sv,*lp);
3245 =for apidoc sv_2pvutf8_nolen
3247 Return a pointer to the UTF8-encoded representation of the SV.
3248 May cause the SV to be upgraded to UTF8 as a side-effect.
3250 Usually accessed via the C<SvPVutf8_nolen> macro.
3256 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3259 return sv_2pvutf8(sv, &n_a);
3263 =for apidoc sv_2pvutf8
3265 Return a pointer to the UTF8-encoded representation of the SV, and set *lp
3266 to its length. May cause the SV to be upgraded to UTF8 as a side-effect.
3268 Usually accessed via the C<SvPVutf8> macro.
3274 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3276 sv_utf8_upgrade(sv);
3277 return SvPV(sv,*lp);
3281 =for apidoc sv_2bool
3283 This function is only called on magical items, and is only used by
3284 sv_true() or its macro equivalent.
3290 Perl_sv_2bool(pTHX_ register SV *sv)
3299 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3300 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3301 return (bool)SvTRUE(tmpsv);
3302 return SvRV(sv) != 0;
3305 register XPV* Xpvtmp;
3306 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3307 (*Xpvtmp->xpv_pv > '0' ||
3308 Xpvtmp->xpv_cur > 1 ||
3309 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3316 return SvIVX(sv) != 0;
3319 return SvNVX(sv) != 0.0;
3327 =for apidoc sv_utf8_upgrade
3329 Convert the PV of an SV to its UTF8-encoded form.
3330 Forces the SV to string form if it is not already.
3331 Always sets the SvUTF8 flag to avoid future validity checks even
3332 if all the bytes have hibit clear.
3334 This is not as a general purpose byte encoding to Unicode interface:
3335 use the Encode extension for that.
3337 =for apidoc sv_utf8_upgrade_flags
3339 Convert the PV of an SV to its UTF8-encoded form.
3340 Forces the SV to string form if it is not already.
3341 Always sets the SvUTF8 flag to avoid future validity checks even
3342 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3343 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3344 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3346 This is not as a general purpose byte encoding to Unicode interface:
3347 use the Encode extension for that.
3353 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3363 (void) sv_2pv_flags(sv,&len, flags);
3372 sv_force_normal_flags(sv, 0);
3376 sv_recode_to_utf8(sv, PL_encoding);
3377 else { /* Assume Latin-1/EBCDIC */
3378 /* This function could be much more efficient if we
3379 * had a FLAG in SVs to signal if there are any hibit
3380 * chars in the PV. Given that there isn't such a flag
3381 * make the loop as fast as possible. */
3382 s = (U8 *) SvPVX(sv);
3383 e = (U8 *) SvEND(sv);
3387 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3393 len = SvCUR(sv) + 1; /* Plus the \0 */
3394 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3395 SvCUR(sv) = len - 1;
3397 Safefree(s); /* No longer using what was there before. */
3398 SvLEN(sv) = len; /* No longer know the real size. */
3400 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3407 =for apidoc sv_utf8_downgrade
3409 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3410 This may not be possible if the PV contains non-byte encoding characters;
3411 if this is the case, either returns false or, if C<fail_ok> is not
3414 This is not as a general purpose Unicode to byte encoding interface:
3415 use the Encode extension for that.
3421 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3423 if (SvPOK(sv) && SvUTF8(sv)) {
3429 sv_force_normal_flags(sv, 0);
3431 s = (U8 *) SvPV(sv, len);
3432 if (!utf8_to_bytes(s, &len)) {
3437 Perl_croak(aTHX_ "Wide character in %s",
3440 Perl_croak(aTHX_ "Wide character");
3451 =for apidoc sv_utf8_encode
3453 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3454 flag so that it looks like octets again. Used as a building block
3455 for encode_utf8 in Encode.xs
3461 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3463 (void) sv_utf8_upgrade(sv);
3468 =for apidoc sv_utf8_decode
3470 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3471 turn off SvUTF8 if needed so that we see characters. Used as a building block
3472 for decode_utf8 in Encode.xs
3478 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3484 /* The octets may have got themselves encoded - get them back as
3487 if (!sv_utf8_downgrade(sv, TRUE))
3490 /* it is actually just a matter of turning the utf8 flag on, but
3491 * we want to make sure everything inside is valid utf8 first.
3493 c = (U8 *) SvPVX(sv);
3494 if (!is_utf8_string(c, SvCUR(sv)+1))
3496 e = (U8 *) SvEND(sv);
3499 if (!UTF8_IS_INVARIANT(ch)) {
3509 =for apidoc sv_setsv
3511 Copies the contents of the source SV C<ssv> into the destination SV
3512 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3513 function if the source SV needs to be reused. Does not handle 'set' magic.
3514 Loosely speaking, it performs a copy-by-value, obliterating any previous
3515 content of the destination.
3517 You probably want to use one of the assortment of wrappers, such as
3518 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3519 C<SvSetMagicSV_nosteal>.
3521 =for apidoc sv_setsv_flags
3523 Copies the contents of the source SV C<ssv> into the destination SV
3524 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3525 function if the source SV needs to be reused. Does not handle 'set' magic.
3526 Loosely speaking, it performs a copy-by-value, obliterating any previous
3527 content of the destination.
3528 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3529 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
3530 implemented in terms of this function.
3532 You probably want to use one of the assortment of wrappers, such as
3533 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3534 C<SvSetMagicSV_nosteal>.
3536 This is the primary function for copying scalars, and most other
3537 copy-ish functions and macros use this underneath.
3543 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3545 register U32 sflags;
3551 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3553 sstr = &PL_sv_undef;
3554 stype = SvTYPE(sstr);
3555 dtype = SvTYPE(dstr);
3560 /* need to nuke the magic */
3562 SvRMAGICAL_off(dstr);
3565 /* There's a lot of redundancy below but we're going for speed here */
3570 if (dtype != SVt_PVGV) {
3571 (void)SvOK_off(dstr);
3579 sv_upgrade(dstr, SVt_IV);
3582 sv_upgrade(dstr, SVt_PVNV);
3586 sv_upgrade(dstr, SVt_PVIV);
3589 (void)SvIOK_only(dstr);
3590 SvIVX(dstr) = SvIVX(sstr);
3593 if (SvTAINTED(sstr))
3604 sv_upgrade(dstr, SVt_NV);
3609 sv_upgrade(dstr, SVt_PVNV);
3612 SvNVX(dstr) = SvNVX(sstr);
3613 (void)SvNOK_only(dstr);
3614 if (SvTAINTED(sstr))
3622 sv_upgrade(dstr, SVt_RV);
3623 else if (dtype == SVt_PVGV &&
3624 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3627 if (GvIMPORTED(dstr) != GVf_IMPORTED
3628 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3630 GvIMPORTED_on(dstr);
3641 sv_upgrade(dstr, SVt_PV);
3644 if (dtype < SVt_PVIV)
3645 sv_upgrade(dstr, SVt_PVIV);
3648 if (dtype < SVt_PVNV)
3649 sv_upgrade(dstr, SVt_PVNV);
3656 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3659 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3663 if (dtype <= SVt_PVGV) {
3665 if (dtype != SVt_PVGV) {
3666 char *name = GvNAME(sstr);
3667 STRLEN len = GvNAMELEN(sstr);
3668 sv_upgrade(dstr, SVt_PVGV);
3669 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3670 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3671 GvNAME(dstr) = savepvn(name, len);
3672 GvNAMELEN(dstr) = len;
3673 SvFAKE_on(dstr); /* can coerce to non-glob */
3675 /* ahem, death to those who redefine active sort subs */
3676 else if (PL_curstackinfo->si_type == PERLSI_SORT
3677 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3678 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3681 #ifdef GV_UNIQUE_CHECK
3682 if (GvUNIQUE((GV*)dstr)) {
3683 Perl_croak(aTHX_ PL_no_modify);
3687 (void)SvOK_off(dstr);
3688 GvINTRO_off(dstr); /* one-shot flag */
3690 GvGP(dstr) = gp_ref(GvGP(sstr));
3691 if (SvTAINTED(sstr))
3693 if (GvIMPORTED(dstr) != GVf_IMPORTED
3694 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3696 GvIMPORTED_on(dstr);
3704 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3706 if ((int)SvTYPE(sstr) != stype) {
3707 stype = SvTYPE(sstr);
3708 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3712 if (stype == SVt_PVLV)
3713 (void)SvUPGRADE(dstr, SVt_PVNV);
3715 (void)SvUPGRADE(dstr, (U32)stype);
3718 sflags = SvFLAGS(sstr);
3720 if (sflags & SVf_ROK) {
3721 if (dtype >= SVt_PV) {
3722 if (dtype == SVt_PVGV) {
3723 SV *sref = SvREFCNT_inc(SvRV(sstr));
3725 int intro = GvINTRO(dstr);
3727 #ifdef GV_UNIQUE_CHECK
3728 if (GvUNIQUE((GV*)dstr)) {
3729 Perl_croak(aTHX_ PL_no_modify);
3734 GvINTRO_off(dstr); /* one-shot flag */
3735 GvLINE(dstr) = CopLINE(PL_curcop);
3736 GvEGV(dstr) = (GV*)dstr;
3739 switch (SvTYPE(sref)) {
3742 SAVESPTR(GvAV(dstr));
3744 dref = (SV*)GvAV(dstr);
3745 GvAV(dstr) = (AV*)sref;
3746 if (!GvIMPORTED_AV(dstr)
3747 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3749 GvIMPORTED_AV_on(dstr);
3754 SAVESPTR(GvHV(dstr));
3756 dref = (SV*)GvHV(dstr);
3757 GvHV(dstr) = (HV*)sref;
3758 if (!GvIMPORTED_HV(dstr)
3759 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3761 GvIMPORTED_HV_on(dstr);
3766 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3767 SvREFCNT_dec(GvCV(dstr));
3768 GvCV(dstr) = Nullcv;
3769 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3770 PL_sub_generation++;
3772 SAVESPTR(GvCV(dstr));
3775 dref = (SV*)GvCV(dstr);
3776 if (GvCV(dstr) != (CV*)sref) {
3777 CV* cv = GvCV(dstr);
3779 if (!GvCVGEN((GV*)dstr) &&
3780 (CvROOT(cv) || CvXSUB(cv)))
3782 /* ahem, death to those who redefine
3783 * active sort subs */
3784 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3785 PL_sortcop == CvSTART(cv))
3787 "Can't redefine active sort subroutine %s",
3788 GvENAME((GV*)dstr));
3789 /* Redefining a sub - warning is mandatory if
3790 it was a const and its value changed. */
3791 if (ckWARN(WARN_REDEFINE)
3793 && (!CvCONST((CV*)sref)
3794 || sv_cmp(cv_const_sv(cv),
3795 cv_const_sv((CV*)sref)))))
3797 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3799 ? "Constant subroutine %s::%s redefined"
3800 : "Subroutine %s::%s redefined",
3801 HvNAME(GvSTASH((GV*)dstr)),
3802 GvENAME((GV*)dstr));
3806 cv_ckproto(cv, (GV*)dstr,
3807 SvPOK(sref) ? SvPVX(sref) : Nullch);
3809 GvCV(dstr) = (CV*)sref;
3810 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3811 GvASSUMECV_on(dstr);
3812 PL_sub_generation++;
3814 if (!GvIMPORTED_CV(dstr)
3815 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3817 GvIMPORTED_CV_on(dstr);
3822 SAVESPTR(GvIOp(dstr));
3824 dref = (SV*)GvIOp(dstr);
3825 GvIOp(dstr) = (IO*)sref;
3829 SAVESPTR(GvFORM(dstr));
3831 dref = (SV*)GvFORM(dstr);
3832 GvFORM(dstr) = (CV*)sref;
3836 SAVESPTR(GvSV(dstr));
3838 dref = (SV*)GvSV(dstr);
3840 if (!GvIMPORTED_SV(dstr)
3841 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3843 GvIMPORTED_SV_on(dstr);
3851 if (SvTAINTED(sstr))
3856 (void)SvOOK_off(dstr); /* backoff */
3858 Safefree(SvPVX(dstr));
3859 SvLEN(dstr)=SvCUR(dstr)=0;
3862 (void)SvOK_off(dstr);
3863 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3865 if (sflags & SVp_NOK) {
3867 /* Only set the public OK flag if the source has public OK. */
3868 if (sflags & SVf_NOK)
3869 SvFLAGS(dstr) |= SVf_NOK;
3870 SvNVX(dstr) = SvNVX(sstr);
3872 if (sflags & SVp_IOK) {
3873 (void)SvIOKp_on(dstr);
3874 if (sflags & SVf_IOK)
3875 SvFLAGS(dstr) |= SVf_IOK;
3876 if (sflags & SVf_IVisUV)
3878 SvIVX(dstr) = SvIVX(sstr);
3880 if (SvAMAGIC(sstr)) {
3884 else if (sflags & SVp_POK) {
3888 * Check to see if we can just swipe the string. If so, it's a
3889 * possible small lose on short strings, but a big win on long ones.
3890 * It might even be a win on short strings if SvPVX(dstr)
3891 * has to be allocated and SvPVX(sstr) has to be freed.
3895 #ifdef PERL_COPY_ON_WRITE
3896 (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
3900 (sflags & SVs_TEMP) && /* slated for free anyway? */
3901 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3902 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3903 SvLEN(sstr) && /* and really is a string */
3904 /* and won't be needed again, potentially */
3905 !(PL_op && PL_op->op_type == OP_AASSIGN))
3906 #ifdef PERL_COPY_ON_WRITE
3907 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
3908 && SvTYPE(sstr) >= SVt_PVIV)
3911 /* Failed the swipe test, and it's not a shared hash key either.
3912 Have to copy the string. */
3913 STRLEN len = SvCUR(sstr);
3914 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3915 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3916 SvCUR_set(dstr, len);
3917 *SvEND(dstr) = '\0';
3918 (void)SvPOK_only(dstr);
3920 /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
3922 #ifdef PERL_COPY_ON_WRITE
3923 /* Either it's a shared hash key, or it's suitable for
3924 copy-on-write or we can swipe the string. */
3926 PerlIO_printf(Perl_debug_log,
3927 "Copy on write: sstr --> dstr\n");
3932 /* I believe I should acquire a global SV mutex if
3933 it's a COW sv (not a shared hash key) to stop
3934 it going un copy-on-write.
3935 If the source SV has gone un copy on write between up there
3936 and down here, then (assert() that) it is of the correct
3937 form to make it copy on write again */
3938 if ((sflags & (SVf_FAKE | SVf_READONLY))
3939 != (SVf_FAKE | SVf_READONLY)) {
3940 SvREADONLY_on(sstr);
3942 /* Make the source SV into a loop of 1.
3943 (about to become 2) */
3944 SV_COW_NEXT_SV_SET(sstr, sstr);
3948 /* Initial code is common. */
3949 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3951 SvFLAGS(dstr) &= ~SVf_OOK;
3952 Safefree(SvPVX(dstr) - SvIVX(dstr));
3954 else if (SvLEN(dstr))
3955 Safefree(SvPVX(dstr));
3957 (void)SvPOK_only(dstr);
3959 #ifdef PERL_COPY_ON_WRITE
3961 /* making another shared SV. */
3962 STRLEN cur = SvCUR(sstr);
3963 STRLEN len = SvLEN(sstr);
3965 /* SvIsCOW_normal */
3966 /* splice us in between source and next-after-source. */
3967 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3968 SV_COW_NEXT_SV_SET(sstr, dstr);
3969 SvPV_set(dstr, SvPVX(sstr));
3971 /* SvIsCOW_shared_hash */
3972 UV hash = SvUVX(sstr);
3973 DEBUG_C(PerlIO_printf(Perl_debug_log,
3974 "Copy on write: Sharing hash\n"));
3976 sharepvn(SvPVX(sstr),
3977 (sflags & SVf_UTF8?-cur:cur), hash));
3982 SvREADONLY_on(dstr);
3984 /* Relesase a global SV mutex. */
3988 { /* Passes the swipe test. */
3989 SvPV_set(dstr, SvPVX(sstr));
3990 SvLEN_set(dstr, SvLEN(sstr));
3991 SvCUR_set(dstr, SvCUR(sstr));
3994 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3995 SvPV_set(sstr, Nullch);
4001 if (sflags & SVf_UTF8)
4004 if (sflags & SVp_NOK) {
4006 if (sflags & SVf_NOK)
4007 SvFLAGS(dstr) |= SVf_NOK;
4008 SvNVX(dstr) = SvNVX(sstr);
4010 if (sflags & SVp_IOK) {
4011 (void)SvIOKp_on(dstr);
4012 if (sflags & SVf_IOK)
4013 SvFLAGS(dstr) |= SVf_IOK;
4014 if (sflags & SVf_IVisUV)
4016 SvIVX(dstr) = SvIVX(sstr);
4019 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4020 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4021 smg->mg_ptr, smg->mg_len);
4022 SvRMAGICAL_on(dstr);
4025 else if (sflags & SVp_IOK) {
4026 if (sflags & SVf_IOK)
4027 (void)SvIOK_only(dstr);
4029 (void)SvOK_off(dstr);
4030 (void)SvIOKp_on(dstr);
4032 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4033 if (sflags & SVf_IVisUV)
4035 SvIVX(dstr) = SvIVX(sstr);
4036 if (sflags & SVp_NOK) {
4037 if (sflags & SVf_NOK)
4038 (void)SvNOK_on(dstr);
4040 (void)SvNOKp_on(dstr);
4041 SvNVX(dstr) = SvNVX(sstr);
4044 else if (sflags & SVp_NOK) {
4045 if (sflags & SVf_NOK)
4046 (void)SvNOK_only(dstr);
4048 (void)SvOK_off(dstr);
4051 SvNVX(dstr) = SvNVX(sstr);
4054 if (dtype == SVt_PVGV) {
4055 if (ckWARN(WARN_MISC))
4056 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4059 (void)SvOK_off(dstr);
4061 if (SvTAINTED(sstr))
4066 =for apidoc sv_setsv_mg
4068 Like C<sv_setsv>, but also handles 'set' magic.
4074 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4076 sv_setsv(dstr,sstr);
4081 =for apidoc sv_setpvn
4083 Copies a string into an SV. The C<len> parameter indicates the number of
4084 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4090 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4092 register char *dptr;
4094 SV_CHECK_THINKFIRST_COW_DROP(sv);
4100 /* len is STRLEN which is unsigned, need to copy to signed */
4103 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4105 (void)SvUPGRADE(sv, SVt_PV);
4107 SvGROW(sv, len + 1);
4109 Move(ptr,dptr,len,char);
4112 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4117 =for apidoc sv_setpvn_mg
4119 Like C<sv_setpvn>, but also handles 'set' magic.
4125 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4127 sv_setpvn(sv,ptr,len);
4132 =for apidoc sv_setpv
4134 Copies a string into an SV. The string must be null-terminated. Does not
4135 handle 'set' magic. See C<sv_setpv_mg>.
4141 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4143 register STRLEN len;
4145 SV_CHECK_THINKFIRST_COW_DROP(sv);
4151 (void)SvUPGRADE(sv, SVt_PV);
4153 SvGROW(sv, len + 1);
4154 Move(ptr,SvPVX(sv),len+1,char);
4156 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4161 =for apidoc sv_setpv_mg
4163 Like C<sv_setpv>, but also handles 'set' magic.
4169 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4176 =for apidoc sv_usepvn
4178 Tells an SV to use C<ptr> to find its string value. Normally the string is
4179 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4180 The C<ptr> should point to memory that was allocated by C<malloc>. The
4181 string length, C<len>, must be supplied. This function will realloc the
4182 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4183 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4184 See C<sv_usepvn_mg>.
4190 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4192 SV_CHECK_THINKFIRST_COW_DROP(sv);
4193 (void)SvUPGRADE(sv, SVt_PV);
4198 (void)SvOOK_off(sv);
4199 if (SvPVX(sv) && SvLEN(sv))
4200 Safefree(SvPVX(sv));
4201 Renew(ptr, len+1, char);
4204 SvLEN_set(sv, len+1);
4206 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4211 =for apidoc sv_usepvn_mg
4213 Like C<sv_usepvn>, but also handles 'set' magic.
4219 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4221 sv_usepvn(sv,ptr,len);
4225 #ifdef PERL_COPY_ON_WRITE
4226 /* Need to do this *after* making the SV normal, as we need the buffer
4227 pointer to remain valid until after we've copied it. If we let go too early,
4228 another thread could invalidate it by unsharing last of the same hash key
4229 (which it can do by means other than releasing copy-on-write Svs)
4230 or by changing the other copy-on-write SVs in the loop. */
4232 S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len,
4233 U32 hash, SV *after)
4235 if (len) { /* this SV was SvIsCOW_normal(sv) */
4236 /* we need to find the SV pointing to us. */
4237 SV *current = SV_COW_NEXT_SV(after);
4239 if (current == sv) {
4240 /* The SV we point to points back to us (there were only two of us
4242 Hence other SV is no longer copy on write either. */
4244 SvREADONLY_off(after);
4246 /* We need to follow the pointers around the loop. */
4248 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4251 /* don't loop forever if the structure is bust, and we have
4252 a pointer into a closed loop. */
4253 assert (current != after);
4254 assert (SvPVX(current) == pvx);
4256 /* Make the SV before us point to the SV after us. */
4257 SV_COW_NEXT_SV_SET(current, after);
4260 unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash);
4265 Perl_sv_release_IVX(pTHX_ register SV *sv)
4268 sv_force_normal_flags(sv, 0);
4269 return SvOOK_off(sv);
4273 =for apidoc sv_force_normal_flags
4275 Undo various types of fakery on an SV: if the PV is a shared string, make
4276 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4277 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4278 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4279 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4280 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4281 set to some other value. In addtion, the C<flags> parameter gets passed to
4282 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4283 with flags set to 0.
4289 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4291 #ifdef PERL_COPY_ON_WRITE
4292 if (SvREADONLY(sv)) {
4293 /* At this point I believe I should acquire a global SV mutex. */
4295 char *pvx = SvPVX(sv);
4296 STRLEN len = SvLEN(sv);
4297 STRLEN cur = SvCUR(sv);
4298 U32 hash = SvUVX(sv);
4299 SV *next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4301 PerlIO_printf(Perl_debug_log,
4302 "Copy on write: Force normal %ld\n",
4308 /* This SV doesn't own the buffer, so need to New() a new one: */
4311 if (flags & SV_COW_DROP_PV) {
4312 /* OK, so we don't need to copy our buffer. */
4315 SvGROW(sv, cur + 1);
4316 Move(pvx,SvPVX(sv),cur,char);
4320 sv_release_COW(sv, pvx, cur, len, hash, next);
4325 else if (PL_curcop != &PL_compiling)
4326 Perl_croak(aTHX_ PL_no_modify);
4327 /* At this point I believe that I can drop the global SV mutex. */
4330 if (SvREADONLY(sv)) {
4332 char *pvx = SvPVX(sv);
4333 STRLEN len = SvCUR(sv);
4334 U32 hash = SvUVX(sv);
4335 SvGROW(sv, len + 1);
4336 Move(pvx,SvPVX(sv),len,char);
4340 unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
4342 else if (PL_curcop != &PL_compiling)
4343 Perl_croak(aTHX_ PL_no_modify);
4347 sv_unref_flags(sv, flags);
4348 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4353 =for apidoc sv_force_normal
4355 Undo various types of fakery on an SV: if the PV is a shared string, make
4356 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4357 an xpvmg. See also C<sv_force_normal_flags>.
4363 Perl_sv_force_normal(pTHX_ register SV *sv)
4365 sv_force_normal_flags(sv, 0);
4371 Efficient removal of characters from the beginning of the string buffer.
4372 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4373 the string buffer. The C<ptr> becomes the first character of the adjusted
4374 string. Uses the "OOK hack".
4380 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
4382 register STRLEN delta;
4384 if (!ptr || !SvPOKp(sv))
4386 SV_CHECK_THINKFIRST(sv);
4387 if (SvTYPE(sv) < SVt_PVIV)
4388 sv_upgrade(sv,SVt_PVIV);
4391 if (!SvLEN(sv)) { /* make copy of shared string */
4392 char *pvx = SvPVX(sv);
4393 STRLEN len = SvCUR(sv);
4394 SvGROW(sv, len + 1);
4395 Move(pvx,SvPVX(sv),len,char);
4399 SvFLAGS(sv) |= SVf_OOK;
4401 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
4402 delta = ptr - SvPVX(sv);
4410 =for apidoc sv_catpvn
4412 Concatenates the string onto the end of the string which is in the SV. The
4413 C<len> indicates number of bytes to copy. If the SV has the UTF8
4414 status set, then the bytes appended should be valid UTF8.
4415 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4417 =for apidoc sv_catpvn_flags
4419 Concatenates the string onto the end of the string which is in the SV. The
4420 C<len> indicates number of bytes to copy. If the SV has the UTF8
4421 status set, then the bytes appended should be valid UTF8.
4422 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4423 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4424 in terms of this function.
4430 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4435 dstr = SvPV_force_flags(dsv, dlen, flags);
4436 SvGROW(dsv, dlen + slen + 1);
4439 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4442 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4447 =for apidoc sv_catpvn_mg
4449 Like C<sv_catpvn>, but also handles 'set' magic.
4455 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4457 sv_catpvn(sv,ptr,len);
4462 =for apidoc sv_catsv
4464 Concatenates the string from SV C<ssv> onto the end of the string in
4465 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4466 not 'set' magic. See C<sv_catsv_mg>.
4468 =for apidoc sv_catsv_flags
4470 Concatenates the string from SV C<ssv> onto the end of the string in
4471 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4472 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4473 and C<sv_catsv_nomg> are implemented in terms of this function.
4478 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4484 if ((spv = SvPV(ssv, slen))) {
4485 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4486 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4487 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4488 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4489 dsv->sv_flags doesn't have that bit set.
4490 Andy Dougherty 12 Oct 2001
4492 I32 sutf8 = DO_UTF8(ssv);
4495 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4497 dutf8 = DO_UTF8(dsv);
4499 if (dutf8 != sutf8) {
4501 /* Not modifying source SV, so taking a temporary copy. */
4502 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4504 sv_utf8_upgrade(csv);
4505 spv = SvPV(csv, slen);
4508 sv_utf8_upgrade_nomg(dsv);
4510 sv_catpvn_nomg(dsv, spv, slen);
4515 =for apidoc sv_catsv_mg
4517 Like C<sv_catsv>, but also handles 'set' magic.
4523 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4530 =for apidoc sv_catpv
4532 Concatenates the string onto the end of the string which is in the SV.
4533 If the SV has the UTF8 status set, then the bytes appended should be
4534 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4539 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4541 register STRLEN len;
4547 junk = SvPV_force(sv, tlen);
4549 SvGROW(sv, tlen + len + 1);
4552 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4554 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4559 =for apidoc sv_catpv_mg
4561 Like C<sv_catpv>, but also handles 'set' magic.
4567 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4576 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4577 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4584 Perl_newSV(pTHX_ STRLEN len)
4590 sv_upgrade(sv, SVt_PV);
4591 SvGROW(sv, len + 1);
4596 =for apidoc sv_magicext
4598 Adds magic to an SV, upgrading it if necessary. Applies the
4599 supplied vtable and returns pointer to the magic added.
4601 Note that sv_magicext will allow things that sv_magic will not.
4602 In particular you can add magic to SvREADONLY SVs and and more than
4603 one instance of the same 'how'
4605 I C<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
4606 if C<namelen> is zero then C<name> is stored as-is and - as another special
4607 case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain
4608 an C<SV*> and has its REFCNT incremented
4610 (This is now used as a subroutine by sv_magic.)
4615 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
4616 const char* name, I32 namlen)
4620 if (SvTYPE(sv) < SVt_PVMG) {
4621 (void)SvUPGRADE(sv, SVt_PVMG);
4623 Newz(702,mg, 1, MAGIC);
4624 mg->mg_moremagic = SvMAGIC(sv);
4627 /* Some magic sontains a reference loop, where the sv and object refer to
4628 each other. To prevent a reference loop that would prevent such
4629 objects being freed, we look for such loops and if we find one we
4630 avoid incrementing the object refcount.
4632 Note we cannot do this to avoid self-tie loops as intervening RV must
4633 have its REFCNT incremented to keep it in existence - instead we could
4634 special case them in sv_free() -- NI-S
4637 if (!obj || obj == sv ||
4638 how == PERL_MAGIC_arylen ||
4639 how == PERL_MAGIC_qr ||
4640 (SvTYPE(obj) == SVt_PVGV &&
4641 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4642 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4643 GvFORM(obj) == (CV*)sv)))
4648 mg->mg_obj = SvREFCNT_inc(obj);
4649 mg->mg_flags |= MGf_REFCOUNTED;
4652 mg->mg_len = namlen;
4655 mg->mg_ptr = savepvn(name, namlen);
4656 else if (namlen == HEf_SVKEY)
4657 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4659 mg->mg_ptr = (char *) name;
4661 mg->mg_virtual = vtable;
4665 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4670 =for apidoc sv_magic
4672 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4673 then adds a new magic item of type C<how> to the head of the magic list.
4679 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4684 #ifdef PERL_COPY_ON_WRITE
4686 sv_force_normal_flags(sv, 0);
4688 if (SvREADONLY(sv)) {
4689 if (PL_curcop != &PL_compiling
4690 && how != PERL_MAGIC_regex_global
4691 && how != PERL_MAGIC_bm
4692 && how != PERL_MAGIC_fm
4693 && how != PERL_MAGIC_sv
4696 Perl_croak(aTHX_ PL_no_modify);
4699 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4700 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4701 /* sv_magic() refuses to add a magic of the same 'how' as an
4704 if (how == PERL_MAGIC_taint)
4712 vtable = &PL_vtbl_sv;
4714 case PERL_MAGIC_overload:
4715 vtable = &PL_vtbl_amagic;
4717 case PERL_MAGIC_overload_elem:
4718 vtable = &PL_vtbl_amagicelem;
4720 case PERL_MAGIC_overload_table:
4721 vtable = &PL_vtbl_ovrld;
4724 vtable = &PL_vtbl_bm;
4726 case PERL_MAGIC_regdata:
4727 vtable = &PL_vtbl_regdata;
4729 case PERL_MAGIC_regdatum:
4730 vtable = &PL_vtbl_regdatum;
4732 case PERL_MAGIC_env:
4733 vtable = &PL_vtbl_env;
4736 vtable = &PL_vtbl_fm;
4738 case PERL_MAGIC_envelem:
4739 vtable = &PL_vtbl_envelem;
4741 case PERL_MAGIC_regex_global:
4742 vtable = &PL_vtbl_mglob;
4744 case PERL_MAGIC_isa:
4745 vtable = &PL_vtbl_isa;
4747 case PERL_MAGIC_isaelem:
4748 vtable = &PL_vtbl_isaelem;
4750 case PERL_MAGIC_nkeys:
4751 vtable = &PL_vtbl_nkeys;
4753 case PERL_MAGIC_dbfile:
4756 case PERL_MAGIC_dbline:
4757 vtable = &PL_vtbl_dbline;
4759 #ifdef USE_5005THREADS
4760 case PERL_MAGIC_mutex:
4761 vtable = &PL_vtbl_mutex;
4763 #endif /* USE_5005THREADS */
4764 #ifdef USE_LOCALE_COLLATE
4765 case PERL_MAGIC_collxfrm:
4766 vtable = &PL_vtbl_collxfrm;
4768 #endif /* USE_LOCALE_COLLATE */
4769 case PERL_MAGIC_tied:
4770 vtable = &PL_vtbl_pack;
4772 case PERL_MAGIC_tiedelem:
4773 case PERL_MAGIC_tiedscalar:
4774 vtable = &PL_vtbl_packelem;
4777 vtable = &PL_vtbl_regexp;
4779 case PERL_MAGIC_sig:
4780 vtable = &PL_vtbl_sig;
4782 case PERL_MAGIC_sigelem:
4783 vtable = &PL_vtbl_sigelem;
4785 case PERL_MAGIC_taint:
4786 vtable = &PL_vtbl_taint;
4788 case PERL_MAGIC_uvar:
4789 vtable = &PL_vtbl_uvar;
4791 case PERL_MAGIC_vec:
4792 vtable = &PL_vtbl_vec;
4794 case PERL_MAGIC_vstring:
4797 case PERL_MAGIC_substr:
4798 vtable = &PL_vtbl_substr;
4800 case PERL_MAGIC_defelem:
4801 vtable = &PL_vtbl_defelem;
4803 case PERL_MAGIC_glob:
4804 vtable = &PL_vtbl_glob;
4806 case PERL_MAGIC_arylen:
4807 vtable = &PL_vtbl_arylen;
4809 case PERL_MAGIC_pos:
4810 vtable = &PL_vtbl_pos;
4812 case PERL_MAGIC_backref:
4813 vtable = &PL_vtbl_backref;
4815 case PERL_MAGIC_ext:
4816 /* Reserved for use by extensions not perl internals. */
4817 /* Useful for attaching extension internal data to perl vars. */
4818 /* Note that multiple extensions may clash if magical scalars */
4819 /* etc holding private data from one are passed to another. */
4822 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4825 /* Rest of work is done else where */
4826 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4829 case PERL_MAGIC_taint:
4832 case PERL_MAGIC_ext:
4833 case PERL_MAGIC_dbfile:
4840 =for apidoc sv_unmagic
4842 Removes all magic of type C<type> from an SV.
4848 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4852 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4855 for (mg = *mgp; mg; mg = *mgp) {
4856 if (mg->mg_type == type) {
4857 MGVTBL* vtbl = mg->mg_virtual;
4858 *mgp = mg->mg_moremagic;
4859 if (vtbl && vtbl->svt_free)
4860 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4861 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4863 Safefree(mg->mg_ptr);
4864 else if (mg->mg_len == HEf_SVKEY)
4865 SvREFCNT_dec((SV*)mg->mg_ptr);
4867 if (mg->mg_flags & MGf_REFCOUNTED)
4868 SvREFCNT_dec(mg->mg_obj);
4872 mgp = &mg->mg_moremagic;
4876 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4883 =for apidoc sv_rvweaken
4885 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4886 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4887 push a back-reference to this RV onto the array of backreferences
4888 associated with that magic.
4894 Perl_sv_rvweaken(pTHX_ SV *sv)
4897 if (!SvOK(sv)) /* let undefs pass */
4900 Perl_croak(aTHX_ "Can't weaken a nonreference");
4901 else if (SvWEAKREF(sv)) {
4902 if (ckWARN(WARN_MISC))
4903 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
4907 sv_add_backref(tsv, sv);
4913 /* Give tsv backref magic if it hasn't already got it, then push a
4914 * back-reference to sv onto the array associated with the backref magic.
4918 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4922 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4923 av = (AV*)mg->mg_obj;
4926 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4927 SvREFCNT_dec(av); /* for sv_magic */
4932 /* delete a back-reference to ourselves from the backref magic associated
4933 * with the SV we point to.
4937 S_sv_del_backref(pTHX_ SV *sv)
4944 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4945 Perl_croak(aTHX_ "panic: del_backref");
4946 av = (AV *)mg->mg_obj;
4951 svp[i] = &PL_sv_undef; /* XXX */
4958 =for apidoc sv_insert
4960 Inserts a string at the specified offset/length within the SV. Similar to
4961 the Perl substr() function.
4967 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4971 register char *midend;
4972 register char *bigend;
4978 Perl_croak(aTHX_ "Can't modify non-existent substring");
4979 SvPV_force(bigstr, curlen);
4980 (void)SvPOK_only_UTF8(bigstr);
4981 if (offset + len > curlen) {
4982 SvGROW(bigstr, offset+len+1);
4983 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4984 SvCUR_set(bigstr, offset+len);
4988 i = littlelen - len;
4989 if (i > 0) { /* string might grow */
4990 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4991 mid = big + offset + len;
4992 midend = bigend = big + SvCUR(bigstr);
4995 while (midend > mid) /* shove everything down */
4996 *--bigend = *--midend;
4997 Move(little,big+offset,littlelen,char);
5003 Move(little,SvPVX(bigstr)+offset,len,char);
5008 big = SvPVX(bigstr);
5011 bigend = big + SvCUR(bigstr);
5013 if (midend > bigend)
5014 Perl_croak(aTHX_ "panic: sv_insert");
5016 if (mid - big > bigend - midend) { /* faster to shorten from end */
5018 Move(little, mid, littlelen,char);
5021 i = bigend - midend;
5023 Move(midend, mid, i,char);
5027 SvCUR_set(bigstr, mid - big);
5030 else if ((i = mid - big)) { /* faster from front */
5031 midend -= littlelen;
5033 sv_chop(bigstr,midend-i);
5038 Move(little, mid, littlelen,char);
5040 else if (littlelen) {
5041 midend -= littlelen;
5042 sv_chop(bigstr,midend);
5043 Move(little,midend,littlelen,char);
5046 sv_chop(bigstr,midend);
5052 =for apidoc sv_replace
5054 Make the first argument a copy of the second, then delete the original.
5055 The target SV physically takes over ownership of the body of the source SV
5056 and inherits its flags; however, the target keeps any magic it owns,
5057 and any magic in the source is discarded.
5058 Note that this is a rather specialist SV copying operation; most of the
5059 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5065 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5067 U32 refcnt = SvREFCNT(sv);
5068 SV_CHECK_THINKFIRST_COW_DROP(sv);
5069 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5070 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5071 if (SvMAGICAL(sv)) {
5075 sv_upgrade(nsv, SVt_PVMG);
5076 SvMAGIC(nsv) = SvMAGIC(sv);
5077 SvFLAGS(nsv) |= SvMAGICAL(sv);
5083 assert(!SvREFCNT(sv));
5084 StructCopy(nsv,sv,SV);
5085 #ifdef PERL_COPY_ON_WRITE
5086 if (SvIsCOW_normal(nsv)) {
5087 /* We need to follow the pointers around the loop to make the
5088 previous SV point to sv, rather than nsv. */
5091 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5094 assert(SvPVX(current) == SvPVX(nsv));
5096 /* Make the SV before us point to the SV after us. */
5098 PerlIO_printf(Perl_debug_log, "previous is\n");
5100 PerlIO_printf(Perl_debug_log,
5101 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5102 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5104 SV_COW_NEXT_SV_SET(current, sv);
5107 SvREFCNT(sv) = refcnt;
5108 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5113 =for apidoc sv_clear
5115 Clear an SV: call any destructors, free up any memory used by the body,
5116 and free the body itself. The SV's head is I<not> freed, although
5117 its type is set to all 1's so that it won't inadvertently be assumed
5118 to be live during global destruction etc.
5119 This function should only be called when REFCNT is zero. Most of the time
5120 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5127 Perl_sv_clear(pTHX_ register SV *sv)
5131 assert(SvREFCNT(sv) == 0);
5134 if (PL_defstash) { /* Still have a symbol table? */
5139 Zero(&tmpref, 1, SV);
5140 sv_upgrade(&tmpref, SVt_RV);
5142 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
5143 SvREFCNT(&tmpref) = 1;
5146 stash = SvSTASH(sv);
5147 destructor = StashHANDLER(stash,DESTROY);
5150 PUSHSTACKi(PERLSI_DESTROY);
5151 SvRV(&tmpref) = SvREFCNT_inc(sv);
5156 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
5162 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5164 del_XRV(SvANY(&tmpref));
5167 if (PL_in_clean_objs)
5168 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5170 /* DESTROY gave object new lease on life */
5176 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5177 SvOBJECT_off(sv); /* Curse the object. */
5178 if (SvTYPE(sv) != SVt_PVIO)
5179 --PL_sv_objcount; /* XXX Might want something more general */
5182 if (SvTYPE(sv) >= SVt_PVMG) {
5185 if (SvFLAGS(sv) & SVpad_TYPED)
5186 SvREFCNT_dec(SvSTASH(sv));
5189 switch (SvTYPE(sv)) {
5192 IoIFP(sv) != PerlIO_stdin() &&
5193 IoIFP(sv) != PerlIO_stdout() &&
5194 IoIFP(sv) != PerlIO_stderr())
5196 io_close((IO*)sv, FALSE);
5198 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5199 PerlDir_close(IoDIRP(sv));
5200 IoDIRP(sv) = (DIR*)NULL;
5201 Safefree(IoTOP_NAME(sv));
5202 Safefree(IoFMT_NAME(sv));
5203 Safefree(IoBOTTOM_NAME(sv));
5218 SvREFCNT_dec(LvTARG(sv));
5222 Safefree(GvNAME(sv));
5223 /* cannot decrease stash refcount yet, as we might recursively delete
5224 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
5225 of stash until current sv is completely gone.
5226 -- JohnPC, 27 Mar 1998 */
5227 stash = GvSTASH(sv);
5233 (void)SvOOK_off(sv);
5241 SvREFCNT_dec(SvRV(sv));
5243 #ifdef PERL_COPY_ON_WRITE
5244 else if (SvPVX(sv)) {
5246 /* I believe I need to grab the global SV mutex here and
5247 then recheck the COW status. */
5249 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5252 sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv),
5253 SvUVX(sv), SV_COW_NEXT_SV(sv));
5254 /* And drop it here. */
5256 } else if (SvLEN(sv)) {
5257 Safefree(SvPVX(sv));
5261 else if (SvPVX(sv) && SvLEN(sv))
5262 Safefree(SvPVX(sv));
5263 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5264 unsharepvn(SvPVX(sv),
5265 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
5279 switch (SvTYPE(sv)) {
5295 del_XPVIV(SvANY(sv));
5298 del_XPVNV(SvANY(sv));
5301 del_XPVMG(SvANY(sv));
5304 del_XPVLV(SvANY(sv));
5307 del_XPVAV(SvANY(sv));
5310 del_XPVHV(SvANY(sv));
5313 del_XPVCV(SvANY(sv));
5316 del_XPVGV(SvANY(sv));
5317 /* code duplication for increased performance. */
5318 SvFLAGS(sv) &= SVf_BREAK;
5319 SvFLAGS(sv) |= SVTYPEMASK;
5320 /* decrease refcount of the stash that owns this GV, if any */
5322 SvREFCNT_dec(stash);
5323 return; /* not break, SvFLAGS reset already happened */
5325 del_XPVBM(SvANY(sv));
5328 del_XPVFM(SvANY(sv));
5331 del_XPVIO(SvANY(sv));
5334 SvFLAGS(sv) &= SVf_BREAK;
5335 SvFLAGS(sv) |= SVTYPEMASK;
5339 =for apidoc sv_newref
5341 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5348 Perl_sv_newref(pTHX_ SV *sv)
5351 ATOMIC_INC(SvREFCNT(sv));
5358 Decrement an SV's reference count, and if it drops to zero, call
5359 C<sv_clear> to invoke destructors and free up any memory used by
5360 the body; finally, deallocate the SV's head itself.
5361 Normally called via a wrapper macro C<SvREFCNT_dec>.
5367 Perl_sv_free(pTHX_ SV *sv)
5369 int refcount_is_zero;
5373 if (SvREFCNT(sv) == 0) {
5374 if (SvFLAGS(sv) & SVf_BREAK)
5375 /* this SV's refcnt has been artificially decremented to
5376 * trigger cleanup */
5378 if (PL_in_clean_all) /* All is fair */
5380 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5381 /* make sure SvREFCNT(sv)==0 happens very seldom */
5382 SvREFCNT(sv) = (~(U32)0)/2;
5385 if (ckWARN_d(WARN_INTERNAL))
5386 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar");
5389 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
5390 if (!refcount_is_zero)
5394 if (ckWARN_d(WARN_DEBUGGING))
5395 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5396 "Attempt to free temp prematurely: SV 0x%"UVxf,
5401 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5402 /* make sure SvREFCNT(sv)==0 happens very seldom */
5403 SvREFCNT(sv) = (~(U32)0)/2;
5414 Returns the length of the string in the SV. Handles magic and type
5415 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5421 Perl_sv_len(pTHX_ register SV *sv)
5429 len = mg_length(sv);
5431 (void)SvPV(sv, len);
5436 =for apidoc sv_len_utf8
5438 Returns the number of characters in the string in an SV, counting wide
5439 UTF8 bytes as a single character. Handles magic and type coercion.
5445 Perl_sv_len_utf8(pTHX_ register SV *sv)
5451 return mg_length(sv);
5455 U8 *s = (U8*)SvPV(sv, len);
5457 return Perl_utf8_length(aTHX_ s, s + len);
5462 =for apidoc sv_pos_u2b
5464 Converts the value pointed to by offsetp from a count of UTF8 chars from
5465 the start of the string, to a count of the equivalent number of bytes; if
5466 lenp is non-zero, it does the same to lenp, but this time starting from
5467 the offset, rather than from the start of the string. Handles magic and
5474 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5479 I32 uoffset = *offsetp;
5485 start = s = (U8*)SvPV(sv, len);
5487 while (s < send && uoffset--)
5491 *offsetp = s - start;
5495 while (s < send && ulen--)
5505 =for apidoc sv_pos_b2u
5507 Converts the value pointed to by offsetp from a count of bytes from the
5508 start of the string, to a count of the equivalent number of UTF8 chars.
5509 Handles magic and type coercion.
5515 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
5524 s = (U8*)SvPV(sv, len);
5525 if ((I32)len < *offsetp)
5526 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5527 send = s + *offsetp;
5531 /* Call utf8n_to_uvchr() to validate the sequence
5532 * (unless a simple non-UTF character) */
5533 if (!UTF8_IS_INVARIANT(*s))
5534 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5549 Returns a boolean indicating whether the strings in the two SVs are
5550 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5551 coerce its args to strings if necessary.
5557 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5565 SV* svrecode = Nullsv;
5572 pv1 = SvPV(sv1, cur1);
5579 pv2 = SvPV(sv2, cur2);
5581 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5582 /* Differing utf8ness.
5583 * Do not UTF8size the comparands as a side-effect. */
5586 svrecode = newSVpvn(pv2, cur2);
5587 sv_recode_to_utf8(svrecode, PL_encoding);
5588 pv2 = SvPV(svrecode, cur2);
5591 svrecode = newSVpvn(pv1, cur1);
5592 sv_recode_to_utf8(svrecode, PL_encoding);
5593 pv1 = SvPV(svrecode, cur1);
5595 /* Now both are in UTF-8. */
5600 bool is_utf8 = TRUE;
5603 /* sv1 is the UTF-8 one,
5604 * if is equal it must be downgrade-able */
5605 char *pv = (char*)bytes_from_utf8((U8*)pv1,
5611 /* sv2 is the UTF-8 one,
5612 * if is equal it must be downgrade-able */
5613 char *pv = (char *)bytes_from_utf8((U8*)pv2,
5619 /* Downgrade not possible - cannot be eq */
5626 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
5629 SvREFCNT_dec(svrecode);
5640 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
5641 string in C<sv1> is less than, equal to, or greater than the string in
5642 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5643 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
5649 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5652 char *pv1, *pv2, *tpv = Nullch;
5654 SV *svrecode = Nullsv;
5661 pv1 = SvPV(sv1, cur1);
5668 pv2 = SvPV(sv2, cur2);
5670 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5671 /* Differing utf8ness.
5672 * Do not UTF8size the comparands as a side-effect. */
5675 svrecode = newSVpvn(pv2, cur2);
5676 sv_recode_to_utf8(svrecode, PL_encoding);
5677 pv2 = SvPV(svrecode, cur2);
5680 pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2);
5685 svrecode = newSVpvn(pv1, cur1);
5686 sv_recode_to_utf8(svrecode, PL_encoding);
5687 pv1 = SvPV(svrecode, cur1);
5690 pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1);
5696 cmp = cur2 ? -1 : 0;
5700 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
5703 cmp = retval < 0 ? -1 : 1;
5704 } else if (cur1 == cur2) {
5707 cmp = cur1 < cur2 ? -1 : 1;
5712 SvREFCNT_dec(svrecode);
5721 =for apidoc sv_cmp_locale
5723 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5724 'use bytes' aware, handles get magic, and will coerce its args to strings
5725 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
5731 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5733 #ifdef USE_LOCALE_COLLATE
5739 if (PL_collation_standard)
5743 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5745 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5747 if (!pv1 || !len1) {
5758 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5761 return retval < 0 ? -1 : 1;
5764 * When the result of collation is equality, that doesn't mean
5765 * that there are no differences -- some locales exclude some
5766 * characters from consideration. So to avoid false equalities,
5767 * we use the raw string as a tiebreaker.
5773 #endif /* USE_LOCALE_COLLATE */
5775 return sv_cmp(sv1, sv2);
5779 #ifdef USE_LOCALE_COLLATE
5782 =for apidoc sv_collxfrm
5784 Add Collate Transform magic to an SV if it doesn't already have it.
5786 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5787 scalar data of the variable, but transformed to such a format that a normal
5788 memory comparison can be used to compare the data according to the locale
5795 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5799 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5800 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5805 Safefree(mg->mg_ptr);
5807 if ((xf = mem_collxfrm(s, len, &xlen))) {
5808 if (SvREADONLY(sv)) {
5811 return xf + sizeof(PL_collation_ix);
5814 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5815 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5828 if (mg && mg->mg_ptr) {
5830 return mg->mg_ptr + sizeof(PL_collation_ix);
5838 #endif /* USE_LOCALE_COLLATE */
5843 Get a line from the filehandle and store it into the SV, optionally
5844 appending to the currently-stored string.
5850 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5854 register STDCHAR rslast;
5855 register STDCHAR *bp;
5860 SV_CHECK_THINKFIRST_COW_DROP(sv);
5861 /* XXX. If you make this PVIV, then copy on write can copy scalars read
5863 However, perlbench says it's slower, because the existing swipe code
5864 is faster than copy on write.
5865 Swings and roundabouts. */
5866 (void)SvUPGRADE(sv, SVt_PV);
5870 if (PL_curcop == &PL_compiling) {
5871 /* we always read code in line mode */
5875 else if (RsSNARF(PL_rs)) {
5879 else if (RsRECORD(PL_rs)) {
5880 I32 recsize, bytesread;
5883 /* Grab the size of the record we're getting */
5884 recsize = SvIV(SvRV(PL_rs));
5885 (void)SvPOK_only(sv); /* Validate pointer */
5886 buffer = SvGROW(sv, (STRLEN)(recsize + 1));
5889 /* VMS wants read instead of fread, because fread doesn't respect */
5890 /* RMS record boundaries. This is not necessarily a good thing to be */
5891 /* doing, but we've got no other real choice */
5892 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5894 bytesread = PerlIO_read(fp, buffer, recsize);
5896 SvCUR_set(sv, bytesread);
5897 buffer[bytesread] = '\0';
5898 if (PerlIO_isutf8(fp))
5902 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5904 else if (RsPARA(PL_rs)) {
5910 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5911 if (PerlIO_isutf8(fp)) {
5912 rsptr = SvPVutf8(PL_rs, rslen);
5915 if (SvUTF8(PL_rs)) {
5916 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5917 Perl_croak(aTHX_ "Wide character in $/");
5920 rsptr = SvPV(PL_rs, rslen);
5924 rslast = rslen ? rsptr[rslen - 1] : '\0';
5926 if (rspara) { /* have to do this both before and after */
5927 do { /* to make sure file boundaries work right */
5930 i = PerlIO_getc(fp);
5934 PerlIO_ungetc(fp,i);
5940 /* See if we know enough about I/O mechanism to cheat it ! */
5942 /* This used to be #ifdef test - it is made run-time test for ease
5943 of abstracting out stdio interface. One call should be cheap
5944 enough here - and may even be a macro allowing compile
5948 if (PerlIO_fast_gets(fp)) {
5951 * We're going to steal some values from the stdio struct
5952 * and put EVERYTHING in the innermost loop into registers.
5954 register STDCHAR *ptr;
5958 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5959 /* An ungetc()d char is handled separately from the regular
5960 * buffer, so we getc() it back out and stuff it in the buffer.
5962 i = PerlIO_getc(fp);
5963 if (i == EOF) return 0;
5964 *(--((*fp)->_ptr)) = (unsigned char) i;
5968 /* Here is some breathtakingly efficient cheating */
5970 cnt = PerlIO_get_cnt(fp); /* get count into register */
5971 (void)SvPOK_only(sv); /* validate pointer */
5972 if ((I32)(SvLEN(sv) - append) <= cnt + 1) { /* make sure we have the room */
5973 if (cnt > 80 && (I32)SvLEN(sv) > append) {
5974 shortbuffered = cnt - SvLEN(sv) + append + 1;
5975 cnt -= shortbuffered;
5979 /* remember that cnt can be negative */
5980 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
5985 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5986 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5987 DEBUG_P(PerlIO_printf(Perl_debug_log,
5988 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5989 DEBUG_P(PerlIO_printf(Perl_debug_log,
5990 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5991 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5992 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5997 while (cnt > 0) { /* this | eat */
5999 if ((*bp++ = *ptr++) == rslast) /* really | dust */
6000 goto thats_all_folks; /* screams | sed :-) */
6004 Copy(ptr, bp, cnt, char); /* this | eat */
6005 bp += cnt; /* screams | dust */
6006 ptr += cnt; /* louder | sed :-) */
6011 if (shortbuffered) { /* oh well, must extend */
6012 cnt = shortbuffered;
6014 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
6016 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6017 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
6021 DEBUG_P(PerlIO_printf(Perl_debug_log,
6022 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6023 PTR2UV(ptr),(long)cnt));
6024 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6026 DEBUG_P(PerlIO_printf(Perl_debug_log,
6027 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6028 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6029 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6031 /* This used to call 'filbuf' in stdio form, but as that behaves like
6032 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6033 another abstraction. */
6034 i = PerlIO_getc(fp); /* get more characters */
6036 DEBUG_P(PerlIO_printf(Perl_debug_log,
6037 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6038 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6039 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6041 cnt = PerlIO_get_cnt(fp);
6042 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
6043 DEBUG_P(PerlIO_printf(Perl_debug_log,
6044 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6046 if (i == EOF) /* all done for ever? */
6047 goto thats_really_all_folks;
6049 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
6051 SvGROW(sv, bpx + cnt + 2);
6052 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
6054 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
6056 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
6057 goto thats_all_folks;
6061 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
6062 memNE((char*)bp - rslen, rsptr, rslen))
6063 goto screamer; /* go back to the fray */
6064 thats_really_all_folks:
6066 cnt += shortbuffered;
6067 DEBUG_P(PerlIO_printf(Perl_debug_log,
6068 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6069 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
6070 DEBUG_P(PerlIO_printf(Perl_debug_log,
6071 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6072 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6073 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6075 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
6076 DEBUG_P(PerlIO_printf(Perl_debug_log,
6077 "Screamer: done, len=%ld, string=|%.*s|\n",
6078 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
6083 /*The big, slow, and stupid way */
6086 /* Need to work around EPOC SDK features */
6087 /* On WINS: MS VC5 generates calls to _chkstk, */
6088 /* if a `large' stack frame is allocated */
6089 /* gcc on MARM does not generate calls like these */
6095 register STDCHAR *bpe = buf + sizeof(buf);
6097 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6098 ; /* keep reading */
6102 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6103 /* Accomodate broken VAXC compiler, which applies U8 cast to
6104 * both args of ?: operator, causing EOF to change into 255
6107 i = (U8)buf[cnt - 1];
6113 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
6115 sv_catpvn(sv, (char *) buf, cnt);
6117 sv_setpvn(sv, (char *) buf, cnt);
6119 if (i != EOF && /* joy */
6121 SvCUR(sv) < rslen ||
6122 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6126 * If we're reading from a TTY and we get a short read,
6127 * indicating that the user hit his EOF character, we need
6128 * to notice it now, because if we try to read from the TTY
6129 * again, the EOF condition will disappear.
6131 * The comparison of cnt to sizeof(buf) is an optimization
6132 * that prevents unnecessary calls to feof().
6136 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6141 if (rspara) { /* have to do this both before and after */
6142 while (i != EOF) { /* to make sure file boundaries work right */
6143 i = PerlIO_getc(fp);
6145 PerlIO_ungetc(fp,i);
6151 if (PerlIO_isutf8(fp))
6156 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
6162 Auto-increment of the value in the SV, doing string to numeric conversion
6163 if necessary. Handles 'get' magic.
6169 Perl_sv_inc(pTHX_ register SV *sv)
6178 if (SvTHINKFIRST(sv)) {
6180 sv_force_normal_flags(sv, 0);
6181 if (SvREADONLY(sv)) {
6182 if (PL_curcop != &PL_compiling)
6183 Perl_croak(aTHX_ PL_no_modify);
6187 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6189 i = PTR2IV(SvRV(sv));
6194 flags = SvFLAGS(sv);
6195 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6196 /* It's (privately or publicly) a float, but not tested as an
6197 integer, so test it to see. */
6199 flags = SvFLAGS(sv);
6201 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6202 /* It's publicly an integer, or privately an integer-not-float */
6203 #ifdef PERL_PRESERVE_IVUV
6207 if (SvUVX(sv) == UV_MAX)
6208 sv_setnv(sv, UV_MAX_P1);
6210 (void)SvIOK_only_UV(sv);
6213 if (SvIVX(sv) == IV_MAX)
6214 sv_setuv(sv, (UV)IV_MAX + 1);
6216 (void)SvIOK_only(sv);
6222 if (flags & SVp_NOK) {
6223 (void)SvNOK_only(sv);
6228 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
6229 if ((flags & SVTYPEMASK) < SVt_PVIV)
6230 sv_upgrade(sv, SVt_IV);
6231 (void)SvIOK_only(sv);
6236 while (isALPHA(*d)) d++;
6237 while (isDIGIT(*d)) d++;
6239 #ifdef PERL_PRESERVE_IVUV
6240 /* Got to punt this as an integer if needs be, but we don't issue
6241 warnings. Probably ought to make the sv_iv_please() that does
6242 the conversion if possible, and silently. */
6243 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6244 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6245 /* Need to try really hard to see if it's an integer.
6246 9.22337203685478e+18 is an integer.
6247 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6248 so $a="9.22337203685478e+18"; $a+0; $a++
6249 needs to be the same as $a="9.22337203685478e+18"; $a++
6256 /* sv_2iv *should* have made this an NV */
6257 if (flags & SVp_NOK) {
6258 (void)SvNOK_only(sv);
6262 /* I don't think we can get here. Maybe I should assert this
6263 And if we do get here I suspect that sv_setnv will croak. NWC
6265 #if defined(USE_LONG_DOUBLE)
6266 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",
6267 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6269 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6270 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6273 #endif /* PERL_PRESERVE_IVUV */
6274 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
6278 while (d >= SvPVX(sv)) {
6286 /* MKS: The original code here died if letters weren't consecutive.
6287 * at least it didn't have to worry about non-C locales. The
6288 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6289 * arranged in order (although not consecutively) and that only
6290 * [A-Za-z] are accepted by isALPHA in the C locale.
6292 if (*d != 'z' && *d != 'Z') {
6293 do { ++*d; } while (!isALPHA(*d));
6296 *(d--) -= 'z' - 'a';
6301 *(d--) -= 'z' - 'a' + 1;
6305 /* oh,oh, the number grew */
6306 SvGROW(sv, SvCUR(sv) + 2);
6308 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
6319 Auto-decrement of the value in the SV, doing string to numeric conversion
6320 if necessary. Handles 'get' magic.
6326 Perl_sv_dec(pTHX_ register SV *sv)
6334 if (SvTHINKFIRST(sv)) {
6336 sv_force_normal_flags(sv, 0);
6337 if (SvREADONLY(sv)) {
6338 if (PL_curcop != &PL_compiling)
6339 Perl_croak(aTHX_ PL_no_modify);
6343 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6345 i = PTR2IV(SvRV(sv));
6350 /* Unlike sv_inc we don't have to worry about string-never-numbers
6351 and keeping them magic. But we mustn't warn on punting */
6352 flags = SvFLAGS(sv);
6353 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6354 /* It's publicly an integer, or privately an integer-not-float */
6355 #ifdef PERL_PRESERVE_IVUV
6359 if (SvUVX(sv) == 0) {
6360 (void)SvIOK_only(sv);
6364 (void)SvIOK_only_UV(sv);
6368 if (SvIVX(sv) == IV_MIN)
6369 sv_setnv(sv, (NV)IV_MIN - 1.0);
6371 (void)SvIOK_only(sv);
6377 if (flags & SVp_NOK) {
6379 (void)SvNOK_only(sv);
6382 if (!(flags & SVp_POK)) {
6383 if ((flags & SVTYPEMASK) < SVt_PVNV)
6384 sv_upgrade(sv, SVt_NV);
6386 (void)SvNOK_only(sv);
6389 #ifdef PERL_PRESERVE_IVUV
6391 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6392 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6393 /* Need to try really hard to see if it's an integer.
6394 9.22337203685478e+18 is an integer.
6395 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6396 so $a="9.22337203685478e+18"; $a+0; $a--
6397 needs to be the same as $a="9.22337203685478e+18"; $a--
6404 /* sv_2iv *should* have made this an NV */
6405 if (flags & SVp_NOK) {
6406 (void)SvNOK_only(sv);
6410 /* I don't think we can get here. Maybe I should assert this
6411 And if we do get here I suspect that sv_setnv will croak. NWC
6413 #if defined(USE_LONG_DOUBLE)
6414 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",
6415 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6417 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6418 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6422 #endif /* PERL_PRESERVE_IVUV */
6423 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
6427 =for apidoc sv_mortalcopy
6429 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6430 The new SV is marked as mortal. It will be destroyed "soon", either by an
6431 explicit call to FREETMPS, or by an implicit call at places such as
6432 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
6437 /* Make a string that will exist for the duration of the expression
6438 * evaluation. Actually, it may have to last longer than that, but
6439 * hopefully we won't free it until it has been assigned to a
6440 * permanent location. */
6443 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6448 sv_setsv(sv,oldstr);
6450 PL_tmps_stack[++PL_tmps_ix] = sv;
6456 =for apidoc sv_newmortal
6458 Creates a new null SV which is mortal. The reference count of the SV is
6459 set to 1. It will be destroyed "soon", either by an explicit call to
6460 FREETMPS, or by an implicit call at places such as statement boundaries.
6461 See also C<sv_mortalcopy> and C<sv_2mortal>.
6467 Perl_sv_newmortal(pTHX)
6472 SvFLAGS(sv) = SVs_TEMP;
6474 PL_tmps_stack[++PL_tmps_ix] = sv;
6479 =for apidoc sv_2mortal
6481 Marks an existing SV as mortal. The SV will be destroyed "soon", either
6482 by an explicit call to FREETMPS, or by an implicit call at places such as
6483 statement boundaries. See also C<sv_newmortal> and C<sv_mortalcopy>.
6489 Perl_sv_2mortal(pTHX_ register SV *sv)
6493 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6496 PL_tmps_stack[++PL_tmps_ix] = sv;
6504 Creates a new SV and copies a string into it. The reference count for the
6505 SV is set to 1. If C<len> is zero, Perl will compute the length using
6506 strlen(). For efficiency, consider using C<newSVpvn> instead.
6512 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6519 sv_setpvn(sv,s,len);
6524 =for apidoc newSVpvn
6526 Creates a new SV and copies a string into it. The reference count for the
6527 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
6528 string. You are responsible for ensuring that the source string is at least
6535 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6540 sv_setpvn(sv,s,len);
6545 =for apidoc newSVpvn_share
6547 Creates a new SV with its SvPVX pointing to a shared string in the string
6548 table. If the string does not already exist in the table, it is created
6549 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
6550 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6551 otherwise the hash is computed. The idea here is that as the string table
6552 is used for shared hash keys these strings will have SvPVX == HeKEY and
6553 hash lookup will avoid string compare.
6559 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6562 bool is_utf8 = FALSE;
6564 STRLEN tmplen = -len;
6566 /* See the note in hv.c:hv_fetch() --jhi */
6567 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
6571 PERL_HASH(hash, src, len);
6573 sv_upgrade(sv, SVt_PVIV);
6574 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
6587 #if defined(PERL_IMPLICIT_CONTEXT)
6589 /* pTHX_ magic can't cope with varargs, so this is a no-context
6590 * version of the main function, (which may itself be aliased to us).
6591 * Don't access this version directly.
6595 Perl_newSVpvf_nocontext(const char* pat, ...)
6600 va_start(args, pat);
6601 sv = vnewSVpvf(pat, &args);
6608 =for apidoc newSVpvf
6610 Creates a new SV and initializes it with the string formatted like
6617 Perl_newSVpvf(pTHX_ const char* pat, ...)
6621 va_start(args, pat);
6622 sv = vnewSVpvf(pat, &args);
6627 /* backend for newSVpvf() and newSVpvf_nocontext() */
6630 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6634 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6641 Creates a new SV and copies a floating point value into it.
6642 The reference count for the SV is set to 1.
6648 Perl_newSVnv(pTHX_ NV n)
6660 Creates a new SV and copies an integer into it. The reference count for the
6667 Perl_newSViv(pTHX_ IV i)
6679 Creates a new SV and copies an unsigned integer into it.
6680 The reference count for the SV is set to 1.
6686 Perl_newSVuv(pTHX_ UV u)
6696 =for apidoc newRV_noinc
6698 Creates an RV wrapper for an SV. The reference count for the original
6699 SV is B<not> incremented.
6705 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6710 sv_upgrade(sv, SVt_RV);
6717 /* newRV_inc is the official function name to use now.
6718 * newRV_inc is in fact #defined to newRV in sv.h
6722 Perl_newRV(pTHX_ SV *tmpRef)
6724 return newRV_noinc(SvREFCNT_inc(tmpRef));
6730 Creates a new SV which is an exact duplicate of the original SV.
6737 Perl_newSVsv(pTHX_ register SV *old)
6743 if (SvTYPE(old) == SVTYPEMASK) {
6744 if (ckWARN_d(WARN_INTERNAL))
6745 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
6760 =for apidoc sv_reset
6762 Underlying implementation for the C<reset> Perl function.
6763 Note that the perl-level function is vaguely deprecated.
6769 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6777 char todo[PERL_UCHAR_MAX+1];
6782 if (!*s) { /* reset ?? searches */
6783 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6784 pm->op_pmdynflags &= ~PMdf_USED;
6789 /* reset variables */
6791 if (!HvARRAY(stash))
6794 Zero(todo, 256, char);
6796 i = (unsigned char)*s;
6800 max = (unsigned char)*s++;
6801 for ( ; i <= max; i++) {
6804 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6805 for (entry = HvARRAY(stash)[i];
6807 entry = HeNEXT(entry))
6809 if (!todo[(U8)*HeKEY(entry)])
6811 gv = (GV*)HeVAL(entry);
6813 if (SvTHINKFIRST(sv)) {
6814 if (!SvREADONLY(sv) && SvROK(sv))
6819 if (SvTYPE(sv) >= SVt_PV) {
6821 if (SvPVX(sv) != Nullch)
6828 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6830 #ifdef USE_ENVIRON_ARRAY
6832 # ifdef USE_ITHREADS
6833 && PL_curinterp == aTHX
6837 environ[0] = Nullch;
6849 Using various gambits, try to get an IO from an SV: the IO slot if its a
6850 GV; or the recursive result if we're an RV; or the IO slot of the symbol
6851 named after the PV if we're a string.
6857 Perl_sv_2io(pTHX_ SV *sv)
6863 switch (SvTYPE(sv)) {
6871 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6875 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6877 return sv_2io(SvRV(sv));
6878 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6884 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6893 Using various gambits, try to get a CV from an SV; in addition, try if
6894 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
6900 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6907 return *gvp = Nullgv, Nullcv;
6908 switch (SvTYPE(sv)) {
6927 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6928 tryAMAGICunDEREF(to_cv);
6931 if (SvTYPE(sv) == SVt_PVCV) {
6940 Perl_croak(aTHX_ "Not a subroutine reference");
6945 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6951 if (lref && !GvCVu(gv)) {
6954 tmpsv = NEWSV(704,0);
6955 gv_efullname3(tmpsv, gv, Nullch);
6956 /* XXX this is probably not what they think they're getting.
6957 * It has the same effect as "sub name;", i.e. just a forward
6959 newSUB(start_subparse(FALSE, 0),
6960 newSVOP(OP_CONST, 0, tmpsv),
6965 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6974 Returns true if the SV has a true value by Perl's rules.
6975 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
6976 instead use an in-line version.
6982 Perl_sv_true(pTHX_ register SV *sv)
6988 if ((tXpv = (XPV*)SvANY(sv)) &&
6989 (tXpv->xpv_cur > 1 ||
6990 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6997 return SvIVX(sv) != 0;
7000 return SvNVX(sv) != 0.0;
7002 return sv_2bool(sv);
7010 A private implementation of the C<SvIVx> macro for compilers which can't
7011 cope with complex macro expressions. Always use the macro instead.
7017 Perl_sv_iv(pTHX_ register SV *sv)
7021 return (IV)SvUVX(sv);
7030 A private implementation of the C<SvUVx> macro for compilers which can't
7031 cope with complex macro expressions. Always use the macro instead.
7037 Perl_sv_uv(pTHX_ register SV *sv)
7042 return (UV)SvIVX(sv);
7050 A private implementation of the C<SvNVx> macro for compilers which can't
7051 cope with complex macro expressions. Always use the macro instead.
7057 Perl_sv_nv(pTHX_ register SV *sv)
7067 Use the C<SvPV_nolen> macro instead
7071 A private implementation of the C<SvPV> macro for compilers which can't
7072 cope with complex macro expressions. Always use the macro instead.
7078 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
7084 return sv_2pv(sv, lp);
7089 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
7095 return sv_2pv_flags(sv, lp, 0);
7099 =for apidoc sv_pvn_force
7101 Get a sensible string out of the SV somehow.
7102 A private implementation of the C<SvPV_force> macro for compilers which
7103 can't cope with complex macro expressions. Always use the macro instead.
7105 =for apidoc sv_pvn_force_flags
7107 Get a sensible string out of the SV somehow.
7108 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7109 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7110 implemented in terms of this function.
7111 You normally want to use the various wrapper macros instead: see
7112 C<SvPV_force> and C<SvPV_force_nomg>
7118 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7122 if (SvTHINKFIRST(sv) && !SvROK(sv))
7123 sv_force_normal_flags(sv, 0);
7129 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
7130 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7134 s = sv_2pv_flags(sv, lp, flags);
7135 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
7140 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
7141 SvGROW(sv, len + 1);
7142 Move(s,SvPVX(sv),len,char);
7147 SvPOK_on(sv); /* validate pointer */
7149 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7150 PTR2UV(sv),SvPVX(sv)));
7157 =for apidoc sv_pvbyte
7159 Use C<SvPVbyte_nolen> instead.
7161 =for apidoc sv_pvbyten
7163 A private implementation of the C<SvPVbyte> macro for compilers
7164 which can't cope with complex macro expressions. Always use the macro
7171 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
7173 sv_utf8_downgrade(sv,0);
7174 return sv_pvn(sv,lp);
7178 =for apidoc sv_pvbyten_force
7180 A private implementation of the C<SvPVbytex_force> macro for compilers
7181 which can't cope with complex macro expressions. Always use the macro
7188 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7190 sv_utf8_downgrade(sv,0);
7191 return sv_pvn_force(sv,lp);
7195 =for apidoc sv_pvutf8
7197 Use the C<SvPVutf8_nolen> macro instead
7199 =for apidoc sv_pvutf8n
7201 A private implementation of the C<SvPVutf8> macro for compilers
7202 which can't cope with complex macro expressions. Always use the macro
7209 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
7211 sv_utf8_upgrade(sv);
7212 return sv_pvn(sv,lp);
7216 =for apidoc sv_pvutf8n_force
7218 A private implementation of the C<SvPVutf8_force> macro for compilers
7219 which can't cope with complex macro expressions. Always use the macro
7226 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
7228 sv_utf8_upgrade(sv);
7229 return sv_pvn_force(sv,lp);
7233 =for apidoc sv_reftype
7235 Returns a string describing what the SV is a reference to.
7241 Perl_sv_reftype(pTHX_ SV *sv, int ob)
7243 if (ob && SvOBJECT(sv)) {
7244 return HvNAME(SvSTASH(sv));
7247 switch (SvTYPE(sv)) {
7263 case SVt_PVLV: return "LVALUE";
7264 case SVt_PVAV: return "ARRAY";
7265 case SVt_PVHV: return "HASH";
7266 case SVt_PVCV: return "CODE";
7267 case SVt_PVGV: return "GLOB";
7268 case SVt_PVFM: return "FORMAT";
7269 case SVt_PVIO: return "IO";
7270 default: return "UNKNOWN";
7276 =for apidoc sv_isobject
7278 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7279 object. If the SV is not an RV, or if the object is not blessed, then this
7286 Perl_sv_isobject(pTHX_ SV *sv)
7303 Returns a boolean indicating whether the SV is blessed into the specified
7304 class. This does not check for subtypes; use C<sv_derived_from> to verify
7305 an inheritance relationship.
7311 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7323 return strEQ(HvNAME(SvSTASH(sv)), name);
7329 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
7330 it will be upgraded to one. If C<classname> is non-null then the new SV will
7331 be blessed in the specified package. The new SV is returned and its
7332 reference count is 1.
7338 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7344 SV_CHECK_THINKFIRST_COW_DROP(rv);
7347 if (SvTYPE(rv) >= SVt_PVMG) {
7348 U32 refcnt = SvREFCNT(rv);
7352 SvREFCNT(rv) = refcnt;
7355 if (SvTYPE(rv) < SVt_RV)
7356 sv_upgrade(rv, SVt_RV);
7357 else if (SvTYPE(rv) > SVt_RV) {
7358 (void)SvOOK_off(rv);
7359 if (SvPVX(rv) && SvLEN(rv))
7360 Safefree(SvPVX(rv));
7370 HV* stash = gv_stashpv(classname, TRUE);
7371 (void)sv_bless(rv, stash);
7377 =for apidoc sv_setref_pv
7379 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7380 argument will be upgraded to an RV. That RV will be modified to point to
7381 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7382 into the SV. The C<classname> argument indicates the package for the
7383 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7384 will be returned and will have a reference count of 1.
7386 Do not use with other Perl types such as HV, AV, SV, CV, because those
7387 objects will become corrupted by the pointer copy process.
7389 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7395 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7398 sv_setsv(rv, &PL_sv_undef);
7402 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7407 =for apidoc sv_setref_iv
7409 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7410 argument will be upgraded to an RV. That RV will be modified to point to
7411 the new SV. The C<classname> argument indicates the package for the
7412 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7413 will be returned and will have a reference count of 1.
7419 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7421 sv_setiv(newSVrv(rv,classname), iv);
7426 =for apidoc sv_setref_uv
7428 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7429 argument will be upgraded to an RV. That RV will be modified to point to
7430 the new SV. The C<classname> argument indicates the package for the
7431 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7432 will be returned and will have a reference count of 1.
7438 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7440 sv_setuv(newSVrv(rv,classname), uv);
7445 =for apidoc sv_setref_nv
7447 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7448 argument will be upgraded to an RV. That RV will be modified to point to
7449 the new SV. The C<classname> argument indicates the package for the
7450 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7451 will be returned and will have a reference count of 1.
7457 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7459 sv_setnv(newSVrv(rv,classname), nv);
7464 =for apidoc sv_setref_pvn
7466 Copies a string into a new SV, optionally blessing the SV. The length of the
7467 string must be specified with C<n>. The C<rv> argument will be upgraded to
7468 an RV. That RV will be modified to point to the new SV. The C<classname>
7469 argument indicates the package for the blessing. Set C<classname> to
7470 C<Nullch> to avoid the blessing. The new SV will be returned and will have
7471 a reference count of 1.
7473 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7479 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
7481 sv_setpvn(newSVrv(rv,classname), pv, n);
7486 =for apidoc sv_bless
7488 Blesses an SV into a specified package. The SV must be an RV. The package
7489 must be designated by its stash (see C<gv_stashpv()>). The reference count
7490 of the SV is unaffected.
7496 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7500 Perl_croak(aTHX_ "Can't bless non-reference value");
7502 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7503 if (SvREADONLY(tmpRef))
7504 Perl_croak(aTHX_ PL_no_modify);
7505 if (SvOBJECT(tmpRef)) {
7506 if (SvTYPE(tmpRef) != SVt_PVIO)
7508 SvREFCNT_dec(SvSTASH(tmpRef));
7511 SvOBJECT_on(tmpRef);
7512 if (SvTYPE(tmpRef) != SVt_PVIO)
7514 (void)SvUPGRADE(tmpRef, SVt_PVMG);
7515 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
7522 if(SvSMAGICAL(tmpRef))
7523 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
7531 /* Downgrades a PVGV to a PVMG.
7535 S_sv_unglob(pTHX_ SV *sv)
7539 assert(SvTYPE(sv) == SVt_PVGV);
7544 SvREFCNT_dec(GvSTASH(sv));
7545 GvSTASH(sv) = Nullhv;
7547 sv_unmagic(sv, PERL_MAGIC_glob);
7548 Safefree(GvNAME(sv));
7551 /* need to keep SvANY(sv) in the right arena */
7552 xpvmg = new_XPVMG();
7553 StructCopy(SvANY(sv), xpvmg, XPVMG);
7554 del_XPVGV(SvANY(sv));
7557 SvFLAGS(sv) &= ~SVTYPEMASK;
7558 SvFLAGS(sv) |= SVt_PVMG;
7562 =for apidoc sv_unref_flags
7564 Unsets the RV status of the SV, and decrements the reference count of
7565 whatever was being referenced by the RV. This can almost be thought of
7566 as a reversal of C<newSVrv>. The C<cflags> argument can contain
7567 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7568 (otherwise the decrementing is conditional on the reference count being
7569 different from one or the reference being a readonly SV).
7576 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
7580 if (SvWEAKREF(sv)) {
7588 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || (flags & SV_IMMEDIATE_UNREF))
7590 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7591 sv_2mortal(rv); /* Schedule for freeing later */
7595 =for apidoc sv_unref
7597 Unsets the RV status of the SV, and decrements the reference count of
7598 whatever was being referenced by the RV. This can almost be thought of
7599 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
7600 being zero. See C<SvROK_off>.
7606 Perl_sv_unref(pTHX_ SV *sv)
7608 sv_unref_flags(sv, 0);
7612 =for apidoc sv_taint
7614 Taint an SV. Use C<SvTAINTED_on> instead.
7619 Perl_sv_taint(pTHX_ SV *sv)
7621 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
7625 =for apidoc sv_untaint
7627 Untaint an SV. Use C<SvTAINTED_off> instead.
7632 Perl_sv_untaint(pTHX_ SV *sv)
7634 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7635 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7642 =for apidoc sv_tainted
7644 Test an SV for taintedness. Use C<SvTAINTED> instead.
7649 Perl_sv_tainted(pTHX_ SV *sv)
7651 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7652 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7653 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
7659 #if defined(PERL_IMPLICIT_CONTEXT)
7661 /* pTHX_ magic can't cope with varargs, so this is a no-context
7662 * version of the main function, (which may itself be aliased to us).
7663 * Don't access this version directly.
7667 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
7671 va_start(args, pat);
7672 sv_vsetpvf(sv, pat, &args);
7676 /* pTHX_ magic can't cope with varargs, so this is a no-context
7677 * version of the main function, (which may itself be aliased to us).
7678 * Don't access this version directly.
7682 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7686 va_start(args, pat);
7687 sv_vsetpvf_mg(sv, pat, &args);
7693 =for apidoc sv_setpvf
7695 Processes its arguments like C<sprintf> and sets an SV to the formatted
7696 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
7702 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7705 va_start(args, pat);
7706 sv_vsetpvf(sv, pat, &args);
7710 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
7713 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7715 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7719 =for apidoc sv_setpvf_mg
7721 Like C<sv_setpvf>, but also handles 'set' magic.
7727 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7730 va_start(args, pat);
7731 sv_vsetpvf_mg(sv, pat, &args);
7735 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
7738 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7740 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7744 #if defined(PERL_IMPLICIT_CONTEXT)
7746 /* pTHX_ magic can't cope with varargs, so this is a no-context
7747 * version of the main function, (which may itself be aliased to us).
7748 * Don't access this version directly.
7752 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
7756 va_start(args, pat);
7757 sv_vcatpvf(sv, pat, &args);
7761 /* pTHX_ magic can't cope with varargs, so this is a no-context
7762 * version of the main function, (which may itself be aliased to us).
7763 * Don't access this version directly.
7767 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
7771 va_start(args, pat);
7772 sv_vcatpvf_mg(sv, pat, &args);
7778 =for apidoc sv_catpvf
7780 Processes its arguments like C<sprintf> and appends the formatted
7781 output to an SV. If the appended data contains "wide" characters
7782 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
7783 and characters >255 formatted with %c), the original SV might get
7784 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
7785 C<SvSETMAGIC()> must typically be called after calling this function
7786 to handle 'set' magic.
7791 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
7794 va_start(args, pat);
7795 sv_vcatpvf(sv, pat, &args);
7799 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
7802 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7804 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7808 =for apidoc sv_catpvf_mg
7810 Like C<sv_catpvf>, but also handles 'set' magic.
7816 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7819 va_start(args, pat);
7820 sv_vcatpvf_mg(sv, pat, &args);
7824 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
7827 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7829 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7834 =for apidoc sv_vsetpvfn
7836 Works like C<vcatpvfn> but copies the text into the SV instead of
7839 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
7845 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7847 sv_setpvn(sv, "", 0);
7848 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
7851 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
7854 S_expect_number(pTHX_ char** pattern)
7857 switch (**pattern) {
7858 case '1': case '2': case '3':
7859 case '4': case '5': case '6':
7860 case '7': case '8': case '9':
7861 while (isDIGIT(**pattern))
7862 var = var * 10 + (*(*pattern)++ - '0');
7866 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
7869 =for apidoc sv_vcatpvfn
7871 Processes its arguments like C<vsprintf> and appends the formatted output
7872 to an SV. Uses an array of SVs if the C style variable argument list is
7873 missing (NULL). When running with taint checks enabled, indicates via
7874 C<maybe_tainted> if results are untrustworthy (often due to the use of
7877 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
7883 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7890 static char nullstr[] = "(null)";
7892 bool has_utf8 = FALSE; /* has the result utf8? */
7894 /* no matter what, this is a string now */
7895 (void)SvPV_force(sv, origlen);
7897 /* special-case "", "%s", and "%_" */
7900 if (patlen == 2 && pat[0] == '%') {
7904 char *s = va_arg(*args, char*);
7905 sv_catpv(sv, s ? s : nullstr);
7907 else if (svix < svmax) {
7908 sv_catsv(sv, *svargs);
7909 if (DO_UTF8(*svargs))
7915 argsv = va_arg(*args, SV*);
7916 sv_catsv(sv, argsv);
7921 /* See comment on '_' below */
7926 if (!args && svix < svmax && DO_UTF8(*svargs))
7929 patend = (char*)pat + patlen;
7930 for (p = (char*)pat; p < patend; p = q) {
7933 bool vectorize = FALSE;
7934 bool vectorarg = FALSE;
7935 bool vec_utf8 = FALSE;
7941 bool has_precis = FALSE;
7943 bool is_utf8 = FALSE; /* is this item utf8? */
7944 #ifdef HAS_LDBL_SPRINTF_BUG
7945 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
7946 with sfio - Allen <allens@cpan.org> */
7947 bool fix_ldbl_sprintf_bug = FALSE;
7951 U8 utf8buf[UTF8_MAXLEN+1];
7952 STRLEN esignlen = 0;
7954 char *eptr = Nullch;
7956 /* Times 4: a decimal digit takes more than 3 binary digits.
7957 * NV_DIG: mantissa takes than many decimal digits.
7958 * Plus 32: Playing safe. */
7959 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7960 /* large enough for "%#.#f" --chip */
7961 /* what about long double NVs? --jhi */
7964 U8 *vecstr = Null(U8*);
7971 /* we need a long double target in case HAS_LONG_DOUBLE but
7974 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
7983 STRLEN dotstrlen = 1;
7984 I32 efix = 0; /* explicit format parameter index */
7985 I32 ewix = 0; /* explicit width index */
7986 I32 epix = 0; /* explicit precision index */
7987 I32 evix = 0; /* explicit vector index */
7988 bool asterisk = FALSE;
7990 /* echo everything up to the next format specification */
7991 for (q = p; q < patend && *q != '%'; ++q) ;
7993 sv_catpvn(sv, p, q - p);
8000 We allow format specification elements in this order:
8001 \d+\$ explicit format parameter index
8003 v|\*(\d+\$)?v vector with optional (optionally specified) arg
8004 \d+|\*(\d+\$)? width using optional (optionally specified) arg
8005 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8007 [%bcdefginopsux_DFOUX] format (mandatory)
8009 if (EXPECT_NUMBER(q, width)) {
8050 if (EXPECT_NUMBER(q, ewix))
8059 if ((vectorarg = asterisk)) {
8069 EXPECT_NUMBER(q, width);
8074 vecsv = va_arg(*args, SV*);
8076 vecsv = (evix ? evix <= svmax : svix < svmax) ?
8077 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
8078 dotstr = SvPVx(vecsv, dotstrlen);
8083 vecsv = va_arg(*args, SV*);
8084 vecstr = (U8*)SvPVx(vecsv,veclen);
8085 vec_utf8 = DO_UTF8(vecsv);
8087 else if (efix ? efix <= svmax : svix < svmax) {
8088 vecsv = svargs[efix ? efix-1 : svix++];
8089 vecstr = (U8*)SvPVx(vecsv,veclen);
8090 vec_utf8 = DO_UTF8(vecsv);
8100 i = va_arg(*args, int);
8102 i = (ewix ? ewix <= svmax : svix < svmax) ?
8103 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8105 width = (i < 0) ? -i : i;
8115 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
8117 /* XXX: todo, support specified precision parameter */
8121 i = va_arg(*args, int);
8123 i = (ewix ? ewix <= svmax : svix < svmax)
8124 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8125 precis = (i < 0) ? 0 : i;
8130 precis = precis * 10 + (*q++ - '0');
8139 case 'I': /* Ix, I32x, and I64x */
8141 if (q[1] == '6' && q[2] == '4') {
8147 if (q[1] == '3' && q[2] == '2') {
8157 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8168 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8169 if (*(q + 1) == 'l') { /* lld, llf */
8194 argsv = (efix ? efix <= svmax : svix < svmax) ?
8195 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
8202 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
8204 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8206 eptr = (char*)utf8buf;
8207 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
8218 if (args && !vectorize) {
8219 eptr = va_arg(*args, char*);
8221 #ifdef MACOS_TRADITIONAL
8222 /* On MacOS, %#s format is used for Pascal strings */
8227 elen = strlen(eptr);
8230 elen = sizeof nullstr - 1;
8234 eptr = SvPVx(argsv, elen);
8235 if (DO_UTF8(argsv)) {
8236 if (has_precis && precis < elen) {
8238 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
8241 if (width) { /* fudge width (can't fudge elen) */
8242 width += elen - sv_len_utf8(argsv);
8251 * The "%_" hack might have to be changed someday,
8252 * if ISO or ANSI decide to use '_' for something.
8253 * So we keep it hidden from users' code.
8255 if (!args || vectorize)
8257 argsv = va_arg(*args, SV*);
8258 eptr = SvPVx(argsv, elen);
8264 if (has_precis && elen > precis)
8271 if (alt || vectorize)
8273 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
8291 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8300 esignbuf[esignlen++] = plus;
8304 case 'h': iv = (short)va_arg(*args, int); break;
8305 default: iv = va_arg(*args, int); break;
8306 case 'l': iv = va_arg(*args, long); break;
8307 case 'V': iv = va_arg(*args, IV); break;
8309 case 'q': iv = va_arg(*args, Quad_t); break;
8316 case 'h': iv = (short)iv; break;
8318 case 'l': iv = (long)iv; break;
8321 case 'q': iv = (Quad_t)iv; break;
8325 if ( !vectorize ) /* we already set uv above */
8330 esignbuf[esignlen++] = plus;
8334 esignbuf[esignlen++] = '-';
8377 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8388 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
8389 default: uv = va_arg(*args, unsigned); break;
8390 case 'l': uv = va_arg(*args, unsigned long); break;
8391 case 'V': uv = va_arg(*args, UV); break;
8393 case 'q': uv = va_arg(*args, Quad_t); break;
8400 case 'h': uv = (unsigned short)uv; break;
8402 case 'l': uv = (unsigned long)uv; break;
8405 case 'q': uv = (Quad_t)uv; break;
8411 eptr = ebuf + sizeof ebuf;
8417 p = (char*)((c == 'X')
8418 ? "0123456789ABCDEF" : "0123456789abcdef");
8424 esignbuf[esignlen++] = '0';
8425 esignbuf[esignlen++] = c; /* 'x' or 'X' */
8431 *--eptr = '0' + dig;
8433 if (alt && *eptr != '0')
8439 *--eptr = '0' + dig;
8442 esignbuf[esignlen++] = '0';
8443 esignbuf[esignlen++] = 'b';
8446 default: /* it had better be ten or less */
8447 #if defined(PERL_Y2KWARN)
8448 if (ckWARN(WARN_Y2K)) {
8450 char *s = SvPV(sv,n);
8451 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
8452 && (n == 2 || !isDIGIT(s[n-3])))
8454 Perl_warner(aTHX_ packWARN(WARN_Y2K),
8455 "Possible Y2K bug: %%%c %s",
8456 c, "format string following '19'");
8462 *--eptr = '0' + dig;
8463 } while (uv /= base);
8466 elen = (ebuf + sizeof ebuf) - eptr;
8469 zeros = precis - elen;
8470 else if (precis == 0 && elen == 1 && *eptr == '0')
8475 /* FLOATING POINT */
8478 c = 'f'; /* maybe %F isn't supported here */
8484 /* This is evil, but floating point is even more evil */
8486 /* for SV-style calling, we can only get NV
8487 for C-style calling, we assume %f is double;
8488 for simplicity we allow any of %Lf, %llf, %qf for long double
8492 #if defined(USE_LONG_DOUBLE)
8497 #if defined(USE_LONG_DOUBLE)
8498 intsize = args ? 0 : 'q';
8502 #if defined(HAS_LONG_DOUBLE)
8513 /* now we need (long double) if intsize == 'q', else (double) */
8514 nv = (args && !vectorize) ?
8515 #if LONG_DOUBLESIZE > DOUBLESIZE
8517 va_arg(*args, long double) :
8518 va_arg(*args, double)
8520 va_arg(*args, double)
8526 if (c != 'e' && c != 'E') {
8528 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
8529 will cast our (long double) to (double) */
8530 (void)Perl_frexp(nv, &i);
8531 if (i == PERL_INT_MIN)
8532 Perl_die(aTHX_ "panic: frexp");
8534 need = BIT_DIGITS(i);
8536 need += has_precis ? precis : 6; /* known default */
8541 #ifdef HAS_LDBL_SPRINTF_BUG
8542 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8543 with sfio - Allen <allens@cpan.org> */
8546 # define MY_DBL_MAX DBL_MAX
8547 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
8548 # if DOUBLESIZE >= 8
8549 # define MY_DBL_MAX 1.7976931348623157E+308L
8551 # define MY_DBL_MAX 3.40282347E+38L
8555 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
8556 # define MY_DBL_MAX_BUG 1L
8558 # define MY_DBL_MAX_BUG MY_DBL_MAX
8562 # define MY_DBL_MIN DBL_MIN
8563 # else /* XXX guessing! -Allen */
8564 # if DOUBLESIZE >= 8
8565 # define MY_DBL_MIN 2.2250738585072014E-308L
8567 # define MY_DBL_MIN 1.17549435E-38L
8571 if ((intsize == 'q') && (c == 'f') &&
8572 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
8574 /* it's going to be short enough that
8575 * long double precision is not needed */
8577 if ((nv <= 0L) && (nv >= -0L))
8578 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
8580 /* would use Perl_fp_class as a double-check but not
8581 * functional on IRIX - see perl.h comments */
8583 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
8584 /* It's within the range that a double can represent */
8585 #if defined(DBL_MAX) && !defined(DBL_MIN)
8586 if ((nv >= ((long double)1/DBL_MAX)) ||
8587 (nv <= (-(long double)1/DBL_MAX)))
8589 fix_ldbl_sprintf_bug = TRUE;
8592 if (fix_ldbl_sprintf_bug == TRUE) {
8602 # undef MY_DBL_MAX_BUG
8605 #endif /* HAS_LDBL_SPRINTF_BUG */
8607 need += 20; /* fudge factor */
8608 if (PL_efloatsize < need) {
8609 Safefree(PL_efloatbuf);
8610 PL_efloatsize = need + 20; /* more fudge */
8611 New(906, PL_efloatbuf, PL_efloatsize, char);
8612 PL_efloatbuf[0] = '\0';
8615 eptr = ebuf + sizeof ebuf;
8618 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
8619 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
8620 if (intsize == 'q') {
8621 /* Copy the one or more characters in a long double
8622 * format before the 'base' ([efgEFG]) character to
8623 * the format string. */
8624 static char const prifldbl[] = PERL_PRIfldbl;
8625 char const *p = prifldbl + sizeof(prifldbl) - 3;
8626 while (p >= prifldbl) { *--eptr = *p--; }
8631 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8636 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8648 /* No taint. Otherwise we are in the strange situation
8649 * where printf() taints but print($float) doesn't.
8651 #if defined(HAS_LONG_DOUBLE)
8653 (void)sprintf(PL_efloatbuf, eptr, nv);
8655 (void)sprintf(PL_efloatbuf, eptr, (double)nv);
8657 (void)sprintf(PL_efloatbuf, eptr, nv);
8659 eptr = PL_efloatbuf;
8660 elen = strlen(PL_efloatbuf);
8666 i = SvCUR(sv) - origlen;
8667 if (args && !vectorize) {
8669 case 'h': *(va_arg(*args, short*)) = i; break;
8670 default: *(va_arg(*args, int*)) = i; break;
8671 case 'l': *(va_arg(*args, long*)) = i; break;
8672 case 'V': *(va_arg(*args, IV*)) = i; break;
8674 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
8679 sv_setuv_mg(argsv, (UV)i);
8681 continue; /* not "break" */
8688 if (!args && ckWARN(WARN_PRINTF) &&
8689 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
8690 SV *msg = sv_newmortal();
8691 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
8692 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
8695 Perl_sv_catpvf(aTHX_ msg,
8696 "\"%%%c\"", c & 0xFF);
8698 Perl_sv_catpvf(aTHX_ msg,
8699 "\"%%\\%03"UVof"\"",
8702 sv_catpv(msg, "end of string");
8703 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
8706 /* output mangled stuff ... */
8712 /* ... right here, because formatting flags should not apply */
8713 SvGROW(sv, SvCUR(sv) + elen + 1);
8715 Copy(eptr, p, elen, char);
8718 SvCUR(sv) = p - SvPVX(sv);
8719 continue; /* not "break" */
8722 if (is_utf8 != has_utf8) {
8725 sv_utf8_upgrade(sv);
8728 SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
8729 sv_utf8_upgrade(nsv);
8733 SvGROW(sv, SvCUR(sv) + elen + 1);
8738 have = esignlen + zeros + elen;
8739 need = (have > width ? have : width);
8742 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
8744 if (esignlen && fill == '0') {
8745 for (i = 0; i < (int)esignlen; i++)
8749 memset(p, fill, gap);
8752 if (esignlen && fill != '0') {
8753 for (i = 0; i < (int)esignlen; i++)
8757 for (i = zeros; i; i--)
8761 Copy(eptr, p, elen, char);
8765 memset(p, ' ', gap);
8770 Copy(dotstr, p, dotstrlen, char);
8774 vectorize = FALSE; /* done iterating over vecstr */
8781 SvCUR(sv) = p - SvPVX(sv);
8789 /* =========================================================================
8791 =head1 Cloning an interpreter
8793 All the macros and functions in this section are for the private use of
8794 the main function, perl_clone().
8796 The foo_dup() functions make an exact copy of an existing foo thinngy.
8797 During the course of a cloning, a hash table is used to map old addresses
8798 to new addresses. The table is created and manipulated with the
8799 ptr_table_* functions.
8803 ============================================================================*/
8806 #if defined(USE_ITHREADS)
8808 #if defined(USE_5005THREADS)
8809 # include "error: USE_5005THREADS and USE_ITHREADS are incompatible"
8812 #ifndef GpREFCNT_inc
8813 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
8817 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8818 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
8819 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8820 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
8821 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8822 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
8823 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8824 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
8825 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
8826 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
8827 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8828 #define SAVEPV(p) (p ? savepv(p) : Nullch)
8829 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
8832 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
8833 regcomp.c. AMS 20010712 */
8836 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
8840 struct reg_substr_datum *s;
8843 return (REGEXP *)NULL;
8845 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8848 len = r->offsets[0];
8849 npar = r->nparens+1;
8851 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
8852 Copy(r->program, ret->program, len+1, regnode);
8854 New(0, ret->startp, npar, I32);
8855 Copy(r->startp, ret->startp, npar, I32);
8856 New(0, ret->endp, npar, I32);
8857 Copy(r->startp, ret->startp, npar, I32);
8859 New(0, ret->substrs, 1, struct reg_substr_data);
8860 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8861 s->min_offset = r->substrs->data[i].min_offset;
8862 s->max_offset = r->substrs->data[i].max_offset;
8863 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
8864 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
8867 ret->regstclass = NULL;
8870 int count = r->data->count;
8872 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
8873 char, struct reg_data);
8874 New(0, d->what, count, U8);
8877 for (i = 0; i < count; i++) {
8878 d->what[i] = r->data->what[i];
8879 switch (d->what[i]) {
8881 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
8884 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
8887 /* This is cheating. */
8888 New(0, d->data[i], 1, struct regnode_charclass_class);
8889 StructCopy(r->data->data[i], d->data[i],
8890 struct regnode_charclass_class);
8891 ret->regstclass = (regnode*)d->data[i];
8894 /* Compiled op trees are readonly, and can thus be
8895 shared without duplication. */
8896 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
8899 d->data[i] = r->data->data[i];
8909 New(0, ret->offsets, 2*len+1, U32);
8910 Copy(r->offsets, ret->offsets, 2*len+1, U32);
8912 ret->precomp = SAVEPV(r->precomp);
8913 ret->refcnt = r->refcnt;
8914 ret->minlen = r->minlen;
8915 ret->prelen = r->prelen;
8916 ret->nparens = r->nparens;
8917 ret->lastparen = r->lastparen;
8918 ret->lastcloseparen = r->lastcloseparen;
8919 ret->reganch = r->reganch;
8921 ret->sublen = r->sublen;
8923 if (RX_MATCH_COPIED(ret))
8924 ret->subbeg = SAVEPV(r->subbeg);
8926 ret->subbeg = Nullch;
8928 ptr_table_store(PL_ptr_table, r, ret);
8932 /* duplicate a file handle */
8935 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
8939 return (PerlIO*)NULL;
8941 /* look for it in the table first */
8942 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
8946 /* create anew and remember what it is */
8947 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
8948 ptr_table_store(PL_ptr_table, fp, ret);
8952 /* duplicate a directory handle */
8955 Perl_dirp_dup(pTHX_ DIR *dp)
8963 /* duplicate a typeglob */
8966 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
8971 /* look for it in the table first */
8972 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
8976 /* create anew and remember what it is */
8977 Newz(0, ret, 1, GP);
8978 ptr_table_store(PL_ptr_table, gp, ret);
8981 ret->gp_refcnt = 0; /* must be before any other dups! */
8982 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
8983 ret->gp_io = io_dup_inc(gp->gp_io, param);
8984 ret->gp_form = cv_dup_inc(gp->gp_form, param);
8985 ret->gp_av = av_dup_inc(gp->gp_av, param);
8986 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
8987 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
8988 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
8989 ret->gp_cvgen = gp->gp_cvgen;
8990 ret->gp_flags = gp->gp_flags;
8991 ret->gp_line = gp->gp_line;
8992 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
8996 /* duplicate a chain of magic */
8999 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9001 MAGIC *mgprev = (MAGIC*)NULL;
9004 return (MAGIC*)NULL;
9005 /* look for it in the table first */
9006 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9010 for (; mg; mg = mg->mg_moremagic) {
9012 Newz(0, nmg, 1, MAGIC);
9014 mgprev->mg_moremagic = nmg;
9017 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
9018 nmg->mg_private = mg->mg_private;
9019 nmg->mg_type = mg->mg_type;
9020 nmg->mg_flags = mg->mg_flags;
9021 if (mg->mg_type == PERL_MAGIC_qr) {
9022 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
9024 else if(mg->mg_type == PERL_MAGIC_backref) {
9025 AV *av = (AV*) mg->mg_obj;
9028 nmg->mg_obj = (SV*)newAV();
9032 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
9037 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
9038 ? sv_dup_inc(mg->mg_obj, param)
9039 : sv_dup(mg->mg_obj, param);
9041 nmg->mg_len = mg->mg_len;
9042 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
9043 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
9044 if (mg->mg_len > 0) {
9045 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
9046 if (mg->mg_type == PERL_MAGIC_overload_table &&
9047 AMT_AMAGIC((AMT*)mg->mg_ptr))
9049 AMT *amtp = (AMT*)mg->mg_ptr;
9050 AMT *namtp = (AMT*)nmg->mg_ptr;
9052 for (i = 1; i < NofAMmeth; i++) {
9053 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9057 else if (mg->mg_len == HEf_SVKEY)
9058 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9060 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9061 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
9068 /* create a new pointer-mapping table */
9071 Perl_ptr_table_new(pTHX)
9074 Newz(0, tbl, 1, PTR_TBL_t);
9077 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
9081 /* map an existing pointer using a table */
9084 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
9086 PTR_TBL_ENT_t *tblent;
9087 UV hash = PTR2UV(sv);
9089 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9090 for (; tblent; tblent = tblent->next) {
9091 if (tblent->oldval == sv)
9092 return tblent->newval;
9097 /* add a new entry to a pointer-mapping table */
9100 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
9102 PTR_TBL_ENT_t *tblent, **otblent;
9103 /* XXX this may be pessimal on platforms where pointers aren't good
9104 * hash values e.g. if they grow faster in the most significant
9106 UV hash = PTR2UV(oldv);
9110 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
9111 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
9112 if (tblent->oldval == oldv) {
9113 tblent->newval = newv;
9117 Newz(0, tblent, 1, PTR_TBL_ENT_t);
9118 tblent->oldval = oldv;
9119 tblent->newval = newv;
9120 tblent->next = *otblent;
9123 if (i && tbl->tbl_items > tbl->tbl_max)
9124 ptr_table_split(tbl);
9127 /* double the hash bucket size of an existing ptr table */
9130 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9132 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9133 UV oldsize = tbl->tbl_max + 1;
9134 UV newsize = oldsize * 2;
9137 Renew(ary, newsize, PTR_TBL_ENT_t*);
9138 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9139 tbl->tbl_max = --newsize;
9141 for (i=0; i < oldsize; i++, ary++) {
9142 PTR_TBL_ENT_t **curentp, **entp, *ent;
9145 curentp = ary + oldsize;
9146 for (entp = ary, ent = *ary; ent; ent = *entp) {
9147 if ((newsize & PTR2UV(ent->oldval)) != i) {
9149 ent->next = *curentp;
9159 /* remove all the entries from a ptr table */
9162 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9164 register PTR_TBL_ENT_t **array;
9165 register PTR_TBL_ENT_t *entry;
9166 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
9170 if (!tbl || !tbl->tbl_items) {
9174 array = tbl->tbl_ary;
9181 entry = entry->next;
9185 if (++riter > max) {
9188 entry = array[riter];
9195 /* clear and free a ptr table */
9198 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
9203 ptr_table_clear(tbl);
9204 Safefree(tbl->tbl_ary);
9212 /* attempt to make everything in the typeglob readonly */
9215 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
9218 SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
9220 if (GvIO(gv) || GvFORM(gv)) {
9221 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
9223 else if (!GvCV(gv)) {
9227 /* CvPADLISTs cannot be shared */
9228 if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
9233 if (!GvUNIQUE(gv)) {
9235 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
9236 HvNAME(GvSTASH(gv)), GvNAME(gv));
9242 * write attempts will die with
9243 * "Modification of a read-only value attempted"
9249 SvREADONLY_on(GvSV(gv));
9256 SvREADONLY_on(GvAV(gv));
9263 SvREADONLY_on(GvAV(gv));
9266 return sstr; /* he_dup() will SvREFCNT_inc() */
9269 /* duplicate an SV of any type (including AV, HV etc) */
9272 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
9275 SvRV(dstr) = SvWEAKREF(sstr)
9276 ? sv_dup(SvRV(sstr), param)
9277 : sv_dup_inc(SvRV(sstr), param);
9279 else if (SvPVX(sstr)) {
9280 /* Has something there */
9282 /* Normal PV - clone whole allocated space */
9283 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9284 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9285 /* Not that normal - actually sstr is copy on write.
9286 But we are a true, independant SV, so: */
9287 SvREADONLY_off(dstr);
9292 /* Special case - not normally malloced for some reason */
9293 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9294 /* A "shared" PV - clone it as unshared string */
9296 SvREADONLY_off(dstr);
9297 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
9300 /* Some other special case - random pointer */
9301 SvPVX(dstr) = SvPVX(sstr);
9307 SvPVX(dstr) = SvPVX(sstr);
9312 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
9316 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
9318 /* look for it in the table first */
9319 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
9323 /* create anew and remember what it is */
9325 ptr_table_store(PL_ptr_table, sstr, dstr);
9328 SvFLAGS(dstr) = SvFLAGS(sstr);
9329 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
9330 SvREFCNT(dstr) = 0; /* must be before any other dups! */
9333 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
9334 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
9335 PL_watch_pvx, SvPVX(sstr));
9338 switch (SvTYPE(sstr)) {
9343 SvANY(dstr) = new_XIV();
9344 SvIVX(dstr) = SvIVX(sstr);
9347 SvANY(dstr) = new_XNV();
9348 SvNVX(dstr) = SvNVX(sstr);
9351 SvANY(dstr) = new_XRV();
9352 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9355 SvANY(dstr) = new_XPV();
9356 SvCUR(dstr) = SvCUR(sstr);
9357 SvLEN(dstr) = SvLEN(sstr);
9358 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9361 SvANY(dstr) = new_XPVIV();
9362 SvCUR(dstr) = SvCUR(sstr);
9363 SvLEN(dstr) = SvLEN(sstr);
9364 SvIVX(dstr) = SvIVX(sstr);
9365 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9368 SvANY(dstr) = new_XPVNV();
9369 SvCUR(dstr) = SvCUR(sstr);
9370 SvLEN(dstr) = SvLEN(sstr);
9371 SvIVX(dstr) = SvIVX(sstr);
9372 SvNVX(dstr) = SvNVX(sstr);
9373 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9376 SvANY(dstr) = new_XPVMG();
9377 SvCUR(dstr) = SvCUR(sstr);
9378 SvLEN(dstr) = SvLEN(sstr);
9379 SvIVX(dstr) = SvIVX(sstr);
9380 SvNVX(dstr) = SvNVX(sstr);
9381 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9382 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9383 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9386 SvANY(dstr) = new_XPVBM();
9387 SvCUR(dstr) = SvCUR(sstr);
9388 SvLEN(dstr) = SvLEN(sstr);
9389 SvIVX(dstr) = SvIVX(sstr);
9390 SvNVX(dstr) = SvNVX(sstr);
9391 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9392 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9393 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9394 BmRARE(dstr) = BmRARE(sstr);
9395 BmUSEFUL(dstr) = BmUSEFUL(sstr);
9396 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
9399 SvANY(dstr) = new_XPVLV();
9400 SvCUR(dstr) = SvCUR(sstr);
9401 SvLEN(dstr) = SvLEN(sstr);
9402 SvIVX(dstr) = SvIVX(sstr);
9403 SvNVX(dstr) = SvNVX(sstr);
9404 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9405 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9406 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9407 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
9408 LvTARGLEN(dstr) = LvTARGLEN(sstr);
9409 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
9410 LvTYPE(dstr) = LvTYPE(sstr);
9413 if (GvUNIQUE((GV*)sstr)) {
9415 if ((share = gv_share(sstr, param))) {
9418 ptr_table_store(PL_ptr_table, sstr, dstr);
9420 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
9421 HvNAME(GvSTASH(share)), GvNAME(share));
9426 SvANY(dstr) = new_XPVGV();
9427 SvCUR(dstr) = SvCUR(sstr);
9428 SvLEN(dstr) = SvLEN(sstr);
9429 SvIVX(dstr) = SvIVX(sstr);
9430 SvNVX(dstr) = SvNVX(sstr);
9431 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9432 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9433 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9434 GvNAMELEN(dstr) = GvNAMELEN(sstr);
9435 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
9436 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
9437 GvFLAGS(dstr) = GvFLAGS(sstr);
9438 GvGP(dstr) = gp_dup(GvGP(sstr), param);
9439 (void)GpREFCNT_inc(GvGP(dstr));
9442 SvANY(dstr) = new_XPVIO();
9443 SvCUR(dstr) = SvCUR(sstr);
9444 SvLEN(dstr) = SvLEN(sstr);
9445 SvIVX(dstr) = SvIVX(sstr);
9446 SvNVX(dstr) = SvNVX(sstr);
9447 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9448 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9449 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9450 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
9451 if (IoOFP(sstr) == IoIFP(sstr))
9452 IoOFP(dstr) = IoIFP(dstr);
9454 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
9455 /* PL_rsfp_filters entries have fake IoDIRP() */
9456 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
9457 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
9459 IoDIRP(dstr) = IoDIRP(sstr);
9460 IoLINES(dstr) = IoLINES(sstr);
9461 IoPAGE(dstr) = IoPAGE(sstr);
9462 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
9463 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
9464 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
9465 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
9466 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
9467 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
9468 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
9469 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
9470 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
9471 IoTYPE(dstr) = IoTYPE(sstr);
9472 IoFLAGS(dstr) = IoFLAGS(sstr);
9475 SvANY(dstr) = new_XPVAV();
9476 SvCUR(dstr) = SvCUR(sstr);
9477 SvLEN(dstr) = SvLEN(sstr);
9478 SvIVX(dstr) = SvIVX(sstr);
9479 SvNVX(dstr) = SvNVX(sstr);
9480 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9481 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9482 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
9483 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
9484 if (AvARRAY((AV*)sstr)) {
9485 SV **dst_ary, **src_ary;
9486 SSize_t items = AvFILLp((AV*)sstr) + 1;
9488 src_ary = AvARRAY((AV*)sstr);
9489 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
9490 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
9491 SvPVX(dstr) = (char*)dst_ary;
9492 AvALLOC((AV*)dstr) = dst_ary;
9493 if (AvREAL((AV*)sstr)) {
9495 *dst_ary++ = sv_dup_inc(*src_ary++, param);
9499 *dst_ary++ = sv_dup(*src_ary++, param);
9501 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
9502 while (items-- > 0) {
9503 *dst_ary++ = &PL_sv_undef;
9507 SvPVX(dstr) = Nullch;
9508 AvALLOC((AV*)dstr) = (SV**)NULL;
9512 SvANY(dstr) = new_XPVHV();
9513 SvCUR(dstr) = SvCUR(sstr);
9514 SvLEN(dstr) = SvLEN(sstr);
9515 SvIVX(dstr) = SvIVX(sstr);
9516 SvNVX(dstr) = SvNVX(sstr);
9517 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9518 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9519 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
9520 if (HvARRAY((HV*)sstr)) {
9522 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
9523 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
9524 Newz(0, dxhv->xhv_array,
9525 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
9526 while (i <= sxhv->xhv_max) {
9527 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
9528 (bool)!!HvSHAREKEYS(sstr),
9532 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
9533 (bool)!!HvSHAREKEYS(sstr), param);
9536 SvPVX(dstr) = Nullch;
9537 HvEITER((HV*)dstr) = (HE*)NULL;
9539 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
9540 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
9541 /* Record stashes for possible cloning in Perl_clone(). */
9542 if(HvNAME((HV*)dstr))
9543 av_push(param->stashes, dstr);
9546 SvANY(dstr) = new_XPVFM();
9547 FmLINES(dstr) = FmLINES(sstr);
9551 SvANY(dstr) = new_XPVCV();
9553 SvCUR(dstr) = SvCUR(sstr);
9554 SvLEN(dstr) = SvLEN(sstr);
9555 SvIVX(dstr) = SvIVX(sstr);
9556 SvNVX(dstr) = SvNVX(sstr);
9557 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9558 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9559 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9560 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
9561 CvSTART(dstr) = CvSTART(sstr);
9562 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
9563 CvXSUB(dstr) = CvXSUB(sstr);
9564 CvXSUBANY(dstr) = CvXSUBANY(sstr);
9565 if (CvCONST(sstr)) {
9566 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
9567 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
9568 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
9570 CvGV(dstr) = gv_dup(CvGV(sstr), param);
9571 if (param->flags & CLONEf_COPY_STACKS) {
9572 CvDEPTH(dstr) = CvDEPTH(sstr);
9576 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
9577 if (!CvANON(sstr) || CvCLONED(sstr))
9578 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
9580 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param);
9581 CvFLAGS(dstr) = CvFLAGS(sstr);
9582 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
9585 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
9589 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9595 /* duplicate a context */
9598 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
9603 return (PERL_CONTEXT*)NULL;
9605 /* look for it in the table first */
9606 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
9610 /* create anew and remember what it is */
9611 Newz(56, ncxs, max + 1, PERL_CONTEXT);
9612 ptr_table_store(PL_ptr_table, cxs, ncxs);
9615 PERL_CONTEXT *cx = &cxs[ix];
9616 PERL_CONTEXT *ncx = &ncxs[ix];
9617 ncx->cx_type = cx->cx_type;
9618 if (CxTYPE(cx) == CXt_SUBST) {
9619 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
9622 ncx->blk_oldsp = cx->blk_oldsp;
9623 ncx->blk_oldcop = cx->blk_oldcop;
9624 ncx->blk_oldretsp = cx->blk_oldretsp;
9625 ncx->blk_oldmarksp = cx->blk_oldmarksp;
9626 ncx->blk_oldscopesp = cx->blk_oldscopesp;
9627 ncx->blk_oldpm = cx->blk_oldpm;
9628 ncx->blk_gimme = cx->blk_gimme;
9629 switch (CxTYPE(cx)) {
9631 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
9632 ? cv_dup_inc(cx->blk_sub.cv, param)
9633 : cv_dup(cx->blk_sub.cv,param));
9634 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
9635 ? av_dup_inc(cx->blk_sub.argarray, param)
9637 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
9638 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
9639 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9640 ncx->blk_sub.lval = cx->blk_sub.lval;
9643 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
9644 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
9645 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
9646 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
9647 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
9650 ncx->blk_loop.label = cx->blk_loop.label;
9651 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
9652 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
9653 ncx->blk_loop.next_op = cx->blk_loop.next_op;
9654 ncx->blk_loop.last_op = cx->blk_loop.last_op;
9655 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
9656 ? cx->blk_loop.iterdata
9657 : gv_dup((GV*)cx->blk_loop.iterdata, param));
9658 ncx->blk_loop.oldcurpad
9659 = (SV**)ptr_table_fetch(PL_ptr_table,
9660 cx->blk_loop.oldcurpad);
9661 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
9662 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
9663 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
9664 ncx->blk_loop.iterix = cx->blk_loop.iterix;
9665 ncx->blk_loop.itermax = cx->blk_loop.itermax;
9668 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
9669 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
9670 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
9671 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9683 /* duplicate a stack info structure */
9686 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
9691 return (PERL_SI*)NULL;
9693 /* look for it in the table first */
9694 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
9698 /* create anew and remember what it is */
9699 Newz(56, nsi, 1, PERL_SI);
9700 ptr_table_store(PL_ptr_table, si, nsi);
9702 nsi->si_stack = av_dup_inc(si->si_stack, param);
9703 nsi->si_cxix = si->si_cxix;
9704 nsi->si_cxmax = si->si_cxmax;
9705 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
9706 nsi->si_type = si->si_type;
9707 nsi->si_prev = si_dup(si->si_prev, param);
9708 nsi->si_next = si_dup(si->si_next, param);
9709 nsi->si_markoff = si->si_markoff;
9714 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
9715 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
9716 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
9717 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
9718 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
9719 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
9720 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
9721 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
9722 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
9723 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
9724 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
9725 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
9728 #define pv_dup_inc(p) SAVEPV(p)
9729 #define pv_dup(p) SAVEPV(p)
9730 #define svp_dup_inc(p,pp) any_dup(p,pp)
9732 /* map any object to the new equivent - either something in the
9733 * ptr table, or something in the interpreter structure
9737 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
9744 /* look for it in the table first */
9745 ret = ptr_table_fetch(PL_ptr_table, v);
9749 /* see if it is part of the interpreter structure */
9750 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
9751 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
9759 /* duplicate the save stack */
9762 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
9764 ANY *ss = proto_perl->Tsavestack;
9765 I32 ix = proto_perl->Tsavestack_ix;
9766 I32 max = proto_perl->Tsavestack_max;
9779 void (*dptr) (void*);
9780 void (*dxptr) (pTHX_ void*);
9783 Newz(54, nss, max, ANY);
9789 case SAVEt_ITEM: /* normal string */
9790 sv = (SV*)POPPTR(ss,ix);
9791 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9792 sv = (SV*)POPPTR(ss,ix);
9793 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9795 case SAVEt_SV: /* scalar reference */
9796 sv = (SV*)POPPTR(ss,ix);
9797 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9798 gv = (GV*)POPPTR(ss,ix);
9799 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9801 case SAVEt_GENERIC_PVREF: /* generic char* */
9802 c = (char*)POPPTR(ss,ix);
9803 TOPPTR(nss,ix) = pv_dup(c);
9804 ptr = POPPTR(ss,ix);
9805 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9807 case SAVEt_SHARED_PVREF: /* char* in shared space */
9808 c = (char*)POPPTR(ss,ix);
9809 TOPPTR(nss,ix) = savesharedpv(c);
9810 ptr = POPPTR(ss,ix);
9811 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9813 case SAVEt_GENERIC_SVREF: /* generic sv */
9814 case SAVEt_SVREF: /* scalar reference */
9815 sv = (SV*)POPPTR(ss,ix);
9816 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9817 ptr = POPPTR(ss,ix);
9818 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
9820 case SAVEt_AV: /* array reference */
9821 av = (AV*)POPPTR(ss,ix);
9822 TOPPTR(nss,ix) = av_dup_inc(av, param);
9823 gv = (GV*)POPPTR(ss,ix);
9824 TOPPTR(nss,ix) = gv_dup(gv, param);
9826 case SAVEt_HV: /* hash reference */
9827 hv = (HV*)POPPTR(ss,ix);
9828 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9829 gv = (GV*)POPPTR(ss,ix);
9830 TOPPTR(nss,ix) = gv_dup(gv, param);
9832 case SAVEt_INT: /* int reference */
9833 ptr = POPPTR(ss,ix);
9834 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9835 intval = (int)POPINT(ss,ix);
9836 TOPINT(nss,ix) = intval;
9838 case SAVEt_LONG: /* long reference */
9839 ptr = POPPTR(ss,ix);
9840 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9841 longval = (long)POPLONG(ss,ix);
9842 TOPLONG(nss,ix) = longval;
9844 case SAVEt_I32: /* I32 reference */
9845 case SAVEt_I16: /* I16 reference */
9846 case SAVEt_I8: /* I8 reference */
9847 ptr = POPPTR(ss,ix);
9848 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9852 case SAVEt_IV: /* IV reference */
9853 ptr = POPPTR(ss,ix);
9854 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9858 case SAVEt_SPTR: /* SV* reference */
9859 ptr = POPPTR(ss,ix);
9860 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9861 sv = (SV*)POPPTR(ss,ix);
9862 TOPPTR(nss,ix) = sv_dup(sv, param);
9864 case SAVEt_VPTR: /* random* reference */
9865 ptr = POPPTR(ss,ix);
9866 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9867 ptr = POPPTR(ss,ix);
9868 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9870 case SAVEt_PPTR: /* char* reference */
9871 ptr = POPPTR(ss,ix);
9872 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9873 c = (char*)POPPTR(ss,ix);
9874 TOPPTR(nss,ix) = pv_dup(c);
9876 case SAVEt_HPTR: /* HV* reference */
9877 ptr = POPPTR(ss,ix);
9878 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9879 hv = (HV*)POPPTR(ss,ix);
9880 TOPPTR(nss,ix) = hv_dup(hv, param);
9882 case SAVEt_APTR: /* AV* reference */
9883 ptr = POPPTR(ss,ix);
9884 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9885 av = (AV*)POPPTR(ss,ix);
9886 TOPPTR(nss,ix) = av_dup(av, param);
9889 gv = (GV*)POPPTR(ss,ix);
9890 TOPPTR(nss,ix) = gv_dup(gv, param);
9892 case SAVEt_GP: /* scalar reference */
9893 gp = (GP*)POPPTR(ss,ix);
9894 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
9895 (void)GpREFCNT_inc(gp);
9896 gv = (GV*)POPPTR(ss,ix);
9897 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9898 c = (char*)POPPTR(ss,ix);
9899 TOPPTR(nss,ix) = pv_dup(c);
9906 case SAVEt_MORTALIZESV:
9907 sv = (SV*)POPPTR(ss,ix);
9908 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9911 ptr = POPPTR(ss,ix);
9912 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
9913 /* these are assumed to be refcounted properly */
9914 switch (((OP*)ptr)->op_type) {
9921 TOPPTR(nss,ix) = ptr;
9926 TOPPTR(nss,ix) = Nullop;
9931 TOPPTR(nss,ix) = Nullop;
9934 c = (char*)POPPTR(ss,ix);
9935 TOPPTR(nss,ix) = pv_dup_inc(c);
9938 longval = POPLONG(ss,ix);
9939 TOPLONG(nss,ix) = longval;
9942 hv = (HV*)POPPTR(ss,ix);
9943 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9944 c = (char*)POPPTR(ss,ix);
9945 TOPPTR(nss,ix) = pv_dup_inc(c);
9949 case SAVEt_DESTRUCTOR:
9950 ptr = POPPTR(ss,ix);
9951 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9952 dptr = POPDPTR(ss,ix);
9953 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
9955 case SAVEt_DESTRUCTOR_X:
9956 ptr = POPPTR(ss,ix);
9957 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9958 dxptr = POPDXPTR(ss,ix);
9959 TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
9961 case SAVEt_REGCONTEXT:
9967 case SAVEt_STACK_POS: /* Position on Perl stack */
9971 case SAVEt_AELEM: /* array element */
9972 sv = (SV*)POPPTR(ss,ix);
9973 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9976 av = (AV*)POPPTR(ss,ix);
9977 TOPPTR(nss,ix) = av_dup_inc(av, param);
9979 case SAVEt_HELEM: /* hash element */
9980 sv = (SV*)POPPTR(ss,ix);
9981 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9982 sv = (SV*)POPPTR(ss,ix);
9983 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9984 hv = (HV*)POPPTR(ss,ix);
9985 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9988 ptr = POPPTR(ss,ix);
9989 TOPPTR(nss,ix) = ptr;
9996 av = (AV*)POPPTR(ss,ix);
9997 TOPPTR(nss,ix) = av_dup(av, param);
10000 longval = (long)POPLONG(ss,ix);
10001 TOPLONG(nss,ix) = longval;
10002 ptr = POPPTR(ss,ix);
10003 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10004 sv = (SV*)POPPTR(ss,ix);
10005 TOPPTR(nss,ix) = sv_dup(sv, param);
10008 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
10016 =for apidoc perl_clone
10018 Create and return a new interpreter by cloning the current one.
10023 /* XXX the above needs expanding by someone who actually understands it ! */
10024 EXTERN_C PerlInterpreter *
10025 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10028 perl_clone(PerlInterpreter *proto_perl, UV flags)
10030 #ifdef PERL_IMPLICIT_SYS
10032 /* perlhost.h so we need to call into it
10033 to clone the host, CPerlHost should have a c interface, sky */
10035 if (flags & CLONEf_CLONE_HOST) {
10036 return perl_clone_host(proto_perl,flags);
10038 return perl_clone_using(proto_perl, flags,
10040 proto_perl->IMemShared,
10041 proto_perl->IMemParse,
10043 proto_perl->IStdIO,
10047 proto_perl->IProc);
10051 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10052 struct IPerlMem* ipM, struct IPerlMem* ipMS,
10053 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10054 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10055 struct IPerlDir* ipD, struct IPerlSock* ipS,
10056 struct IPerlProc* ipP)
10058 /* XXX many of the string copies here can be optimized if they're
10059 * constants; they need to be allocated as common memory and just
10060 * their pointers copied. */
10063 CLONE_PARAMS clone_params;
10064 CLONE_PARAMS* param = &clone_params;
10066 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10067 PERL_SET_THX(my_perl);
10070 Poison(my_perl, 1, PerlInterpreter);
10075 PL_sig_pending = 0;
10076 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10077 # else /* !DEBUGGING */
10078 Zero(my_perl, 1, PerlInterpreter);
10079 # endif /* DEBUGGING */
10081 /* host pointers */
10083 PL_MemShared = ipMS;
10084 PL_MemParse = ipMP;
10091 #else /* !PERL_IMPLICIT_SYS */
10093 CLONE_PARAMS clone_params;
10094 CLONE_PARAMS* param = &clone_params;
10095 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10096 PERL_SET_THX(my_perl);
10101 Poison(my_perl, 1, PerlInterpreter);
10106 PL_sig_pending = 0;
10107 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10108 # else /* !DEBUGGING */
10109 Zero(my_perl, 1, PerlInterpreter);
10110 # endif /* DEBUGGING */
10111 #endif /* PERL_IMPLICIT_SYS */
10112 param->flags = flags;
10113 param->proto_perl = proto_perl;
10116 PL_xiv_arenaroot = NULL;
10117 PL_xiv_root = NULL;
10118 PL_xnv_arenaroot = NULL;
10119 PL_xnv_root = NULL;
10120 PL_xrv_arenaroot = NULL;
10121 PL_xrv_root = NULL;
10122 PL_xpv_arenaroot = NULL;
10123 PL_xpv_root = NULL;
10124 PL_xpviv_arenaroot = NULL;
10125 PL_xpviv_root = NULL;
10126 PL_xpvnv_arenaroot = NULL;
10127 PL_xpvnv_root = NULL;
10128 PL_xpvcv_arenaroot = NULL;
10129 PL_xpvcv_root = NULL;
10130 PL_xpvav_arenaroot = NULL;
10131 PL_xpvav_root = NULL;
10132 PL_xpvhv_arenaroot = NULL;
10133 PL_xpvhv_root = NULL;
10134 PL_xpvmg_arenaroot = NULL;
10135 PL_xpvmg_root = NULL;
10136 PL_xpvlv_arenaroot = NULL;
10137 PL_xpvlv_root = NULL;
10138 PL_xpvbm_arenaroot = NULL;
10139 PL_xpvbm_root = NULL;
10140 PL_he_arenaroot = NULL;
10142 PL_nice_chunk = NULL;
10143 PL_nice_chunk_size = 0;
10145 PL_sv_objcount = 0;
10146 PL_sv_root = Nullsv;
10147 PL_sv_arenaroot = Nullsv;
10149 PL_debug = proto_perl->Idebug;
10151 #ifdef USE_REENTRANT_API
10152 Perl_reentrant_init(aTHX);
10155 /* create SV map for pointer relocation */
10156 PL_ptr_table = ptr_table_new();
10158 /* initialize these special pointers as early as possible */
10159 SvANY(&PL_sv_undef) = NULL;
10160 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
10161 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
10162 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
10164 SvANY(&PL_sv_no) = new_XPVNV();
10165 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
10166 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10167 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
10168 SvCUR(&PL_sv_no) = 0;
10169 SvLEN(&PL_sv_no) = 1;
10170 SvNVX(&PL_sv_no) = 0;
10171 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
10173 SvANY(&PL_sv_yes) = new_XPVNV();
10174 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
10175 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10176 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
10177 SvCUR(&PL_sv_yes) = 1;
10178 SvLEN(&PL_sv_yes) = 2;
10179 SvNVX(&PL_sv_yes) = 1;
10180 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
10182 /* create (a non-shared!) shared string table */
10183 PL_strtab = newHV();
10184 HvSHAREKEYS_off(PL_strtab);
10185 hv_ksplit(PL_strtab, 512);
10186 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
10188 PL_compiling = proto_perl->Icompiling;
10190 /* These two PVs will be free'd special way so must set them same way op.c does */
10191 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
10192 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
10194 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
10195 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
10197 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
10198 if (!specialWARN(PL_compiling.cop_warnings))
10199 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
10200 if (!specialCopIO(PL_compiling.cop_io))
10201 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
10202 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
10204 /* pseudo environmental stuff */
10205 PL_origargc = proto_perl->Iorigargc;
10207 New(0, PL_origargv, i+1, char*);
10208 PL_origargv[i] = '\0';
10210 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
10213 param->stashes = newAV(); /* Setup array of objects to call clone on */
10215 #ifdef PERLIO_LAYERS
10216 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
10217 PerlIO_clone(aTHX_ proto_perl, param);
10220 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
10221 PL_incgv = gv_dup(proto_perl->Iincgv, param);
10222 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
10223 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
10224 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
10225 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
10228 PL_minus_c = proto_perl->Iminus_c;
10229 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
10230 PL_localpatches = proto_perl->Ilocalpatches;
10231 PL_splitstr = proto_perl->Isplitstr;
10232 PL_preprocess = proto_perl->Ipreprocess;
10233 PL_minus_n = proto_perl->Iminus_n;
10234 PL_minus_p = proto_perl->Iminus_p;
10235 PL_minus_l = proto_perl->Iminus_l;
10236 PL_minus_a = proto_perl->Iminus_a;
10237 PL_minus_F = proto_perl->Iminus_F;
10238 PL_doswitches = proto_perl->Idoswitches;
10239 PL_dowarn = proto_perl->Idowarn;
10240 PL_doextract = proto_perl->Idoextract;
10241 PL_sawampersand = proto_perl->Isawampersand;
10242 PL_unsafe = proto_perl->Iunsafe;
10243 PL_inplace = SAVEPV(proto_perl->Iinplace);
10244 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
10245 PL_perldb = proto_perl->Iperldb;
10246 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
10247 PL_exit_flags = proto_perl->Iexit_flags;
10249 /* magical thingies */
10250 /* XXX time(&PL_basetime) when asked for? */
10251 PL_basetime = proto_perl->Ibasetime;
10252 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
10254 PL_maxsysfd = proto_perl->Imaxsysfd;
10255 PL_multiline = proto_perl->Imultiline;
10256 PL_statusvalue = proto_perl->Istatusvalue;
10258 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
10260 PL_encoding = sv_dup(proto_perl->Iencoding, param);
10262 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
10263 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
10264 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
10266 /* Clone the regex array */
10267 PL_regex_padav = newAV();
10269 I32 len = av_len((AV*)proto_perl->Iregex_padav);
10270 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
10271 av_push(PL_regex_padav,
10272 sv_dup_inc(regexen[0],param));
10273 for(i = 1; i <= len; i++) {
10274 if(SvREPADTMP(regexen[i])) {
10275 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
10277 av_push(PL_regex_padav,
10279 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
10280 SvIVX(regexen[i])), param)))
10285 PL_regex_pad = AvARRAY(PL_regex_padav);
10287 /* shortcuts to various I/O objects */
10288 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
10289 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
10290 PL_defgv = gv_dup(proto_perl->Idefgv, param);
10291 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
10292 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
10293 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
10295 /* shortcuts to regexp stuff */
10296 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
10298 /* shortcuts to misc objects */
10299 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
10301 /* shortcuts to debugging objects */
10302 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
10303 PL_DBline = gv_dup(proto_perl->IDBline, param);
10304 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
10305 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
10306 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
10307 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
10308 PL_lineary = av_dup(proto_perl->Ilineary, param);
10309 PL_dbargs = av_dup(proto_perl->Idbargs, param);
10311 /* symbol tables */
10312 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
10313 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
10314 PL_debstash = hv_dup(proto_perl->Idebstash, param);
10315 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
10316 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
10318 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
10319 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
10320 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
10321 PL_endav = av_dup_inc(proto_perl->Iendav, param);
10322 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
10323 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
10325 PL_sub_generation = proto_perl->Isub_generation;
10327 /* funky return mechanisms */
10328 PL_forkprocess = proto_perl->Iforkprocess;
10330 /* subprocess state */
10331 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
10333 /* internal state */
10334 PL_tainting = proto_perl->Itainting;
10335 PL_maxo = proto_perl->Imaxo;
10336 if (proto_perl->Iop_mask)
10337 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
10339 PL_op_mask = Nullch;
10341 /* current interpreter roots */
10342 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
10343 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
10344 PL_main_start = proto_perl->Imain_start;
10345 PL_eval_root = proto_perl->Ieval_root;
10346 PL_eval_start = proto_perl->Ieval_start;
10348 /* runtime control stuff */
10349 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
10350 PL_copline = proto_perl->Icopline;
10352 PL_filemode = proto_perl->Ifilemode;
10353 PL_lastfd = proto_perl->Ilastfd;
10354 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
10357 PL_gensym = proto_perl->Igensym;
10358 PL_preambled = proto_perl->Ipreambled;
10359 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
10360 PL_laststatval = proto_perl->Ilaststatval;
10361 PL_laststype = proto_perl->Ilaststype;
10362 PL_mess_sv = Nullsv;
10364 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
10365 PL_ofmt = SAVEPV(proto_perl->Iofmt);
10367 /* interpreter atexit processing */
10368 PL_exitlistlen = proto_perl->Iexitlistlen;
10369 if (PL_exitlistlen) {
10370 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10371 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10374 PL_exitlist = (PerlExitListEntry*)NULL;
10375 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
10376 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
10377 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
10379 PL_profiledata = NULL;
10380 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
10381 /* PL_rsfp_filters entries have fake IoDIRP() */
10382 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
10384 PL_compcv = cv_dup(proto_perl->Icompcv, param);
10386 PAD_CLONE_VARS(proto_perl, param);
10388 #ifdef HAVE_INTERP_INTERN
10389 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
10392 /* more statics moved here */
10393 PL_generation = proto_perl->Igeneration;
10394 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
10396 PL_in_clean_objs = proto_perl->Iin_clean_objs;
10397 PL_in_clean_all = proto_perl->Iin_clean_all;
10399 PL_uid = proto_perl->Iuid;
10400 PL_euid = proto_perl->Ieuid;
10401 PL_gid = proto_perl->Igid;
10402 PL_egid = proto_perl->Iegid;
10403 PL_nomemok = proto_perl->Inomemok;
10404 PL_an = proto_perl->Ian;
10405 PL_op_seqmax = proto_perl->Iop_seqmax;
10406 PL_evalseq = proto_perl->Ievalseq;
10407 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
10408 PL_origalen = proto_perl->Iorigalen;
10409 PL_pidstatus = newHV(); /* XXX flag for cloning? */
10410 PL_osname = SAVEPV(proto_perl->Iosname);
10411 PL_sh_path = proto_perl->Ish_path; /* XXX never deallocated */
10412 PL_sighandlerp = proto_perl->Isighandlerp;
10415 PL_runops = proto_perl->Irunops;
10417 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
10420 PL_cshlen = proto_perl->Icshlen;
10421 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
10424 PL_lex_state = proto_perl->Ilex_state;
10425 PL_lex_defer = proto_perl->Ilex_defer;
10426 PL_lex_expect = proto_perl->Ilex_expect;
10427 PL_lex_formbrack = proto_perl->Ilex_formbrack;
10428 PL_lex_dojoin = proto_perl->Ilex_dojoin;
10429 PL_lex_starts = proto_perl->Ilex_starts;
10430 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
10431 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
10432 PL_lex_op = proto_perl->Ilex_op;
10433 PL_lex_inpat = proto_perl->Ilex_inpat;
10434 PL_lex_inwhat = proto_perl->Ilex_inwhat;
10435 PL_lex_brackets = proto_perl->Ilex_brackets;
10436 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
10437 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
10438 PL_lex_casemods = proto_perl->Ilex_casemods;
10439 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
10440 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
10442 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
10443 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
10444 PL_nexttoke = proto_perl->Inexttoke;
10446 /* XXX This is probably masking the deeper issue of why
10447 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
10448 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
10449 * (A little debugging with a watchpoint on it may help.)
10451 if (SvANY(proto_perl->Ilinestr)) {
10452 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
10453 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
10454 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10455 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
10456 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10457 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
10458 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10459 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
10460 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10463 PL_linestr = NEWSV(65,79);
10464 sv_upgrade(PL_linestr,SVt_PVIV);
10465 sv_setpvn(PL_linestr,"",0);
10466 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
10468 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10469 PL_pending_ident = proto_perl->Ipending_ident;
10470 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
10472 PL_expect = proto_perl->Iexpect;
10474 PL_multi_start = proto_perl->Imulti_start;
10475 PL_multi_end = proto_perl->Imulti_end;
10476 PL_multi_open = proto_perl->Imulti_open;
10477 PL_multi_close = proto_perl->Imulti_close;
10479 PL_error_count = proto_perl->Ierror_count;
10480 PL_subline = proto_perl->Isubline;
10481 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
10483 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
10484 if (SvANY(proto_perl->Ilinestr)) {
10485 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
10486 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10487 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
10488 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10489 PL_last_lop_op = proto_perl->Ilast_lop_op;
10492 PL_last_uni = SvPVX(PL_linestr);
10493 PL_last_lop = SvPVX(PL_linestr);
10494 PL_last_lop_op = 0;
10496 PL_in_my = proto_perl->Iin_my;
10497 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
10499 PL_cryptseen = proto_perl->Icryptseen;
10502 PL_hints = proto_perl->Ihints;
10504 PL_amagic_generation = proto_perl->Iamagic_generation;
10506 #ifdef USE_LOCALE_COLLATE
10507 PL_collation_ix = proto_perl->Icollation_ix;
10508 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
10509 PL_collation_standard = proto_perl->Icollation_standard;
10510 PL_collxfrm_base = proto_perl->Icollxfrm_base;
10511 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
10512 #endif /* USE_LOCALE_COLLATE */
10514 #ifdef USE_LOCALE_NUMERIC
10515 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
10516 PL_numeric_standard = proto_perl->Inumeric_standard;
10517 PL_numeric_local = proto_perl->Inumeric_local;
10518 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
10519 #endif /* !USE_LOCALE_NUMERIC */
10521 /* utf8 character classes */
10522 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
10523 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
10524 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
10525 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
10526 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
10527 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
10528 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
10529 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
10530 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
10531 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
10532 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
10533 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
10534 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
10535 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
10536 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
10537 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
10538 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
10539 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
10540 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
10541 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
10544 PL_last_swash_hv = Nullhv; /* reinits on demand */
10545 PL_last_swash_klen = 0;
10546 PL_last_swash_key[0]= '\0';
10547 PL_last_swash_tmps = (U8*)NULL;
10548 PL_last_swash_slen = 0;
10550 /* perly.c globals */
10551 PL_yydebug = proto_perl->Iyydebug;
10552 PL_yynerrs = proto_perl->Iyynerrs;
10553 PL_yyerrflag = proto_perl->Iyyerrflag;
10554 PL_yychar = proto_perl->Iyychar;
10555 PL_yyval = proto_perl->Iyyval;
10556 PL_yylval = proto_perl->Iyylval;
10558 PL_glob_index = proto_perl->Iglob_index;
10559 PL_srand_called = proto_perl->Isrand_called;
10560 PL_uudmap['M'] = 0; /* reinits on demand */
10561 PL_bitcount = Nullch; /* reinits on demand */
10563 if (proto_perl->Ipsig_pend) {
10564 Newz(0, PL_psig_pend, SIG_SIZE, int);
10567 PL_psig_pend = (int*)NULL;
10570 if (proto_perl->Ipsig_ptr) {
10571 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
10572 Newz(0, PL_psig_name, SIG_SIZE, SV*);
10573 for (i = 1; i < SIG_SIZE; i++) {
10574 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
10575 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
10579 PL_psig_ptr = (SV**)NULL;
10580 PL_psig_name = (SV**)NULL;
10583 /* thrdvar.h stuff */
10585 if (flags & CLONEf_COPY_STACKS) {
10586 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
10587 PL_tmps_ix = proto_perl->Ttmps_ix;
10588 PL_tmps_max = proto_perl->Ttmps_max;
10589 PL_tmps_floor = proto_perl->Ttmps_floor;
10590 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
10592 while (i <= PL_tmps_ix) {
10593 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
10597 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
10598 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
10599 Newz(54, PL_markstack, i, I32);
10600 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
10601 - proto_perl->Tmarkstack);
10602 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
10603 - proto_perl->Tmarkstack);
10604 Copy(proto_perl->Tmarkstack, PL_markstack,
10605 PL_markstack_ptr - PL_markstack + 1, I32);
10607 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
10608 * NOTE: unlike the others! */
10609 PL_scopestack_ix = proto_perl->Tscopestack_ix;
10610 PL_scopestack_max = proto_perl->Tscopestack_max;
10611 Newz(54, PL_scopestack, PL_scopestack_max, I32);
10612 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
10614 /* next push_return() sets PL_retstack[PL_retstack_ix]
10615 * NOTE: unlike the others! */
10616 PL_retstack_ix = proto_perl->Tretstack_ix;
10617 PL_retstack_max = proto_perl->Tretstack_max;
10618 Newz(54, PL_retstack, PL_retstack_max, OP*);
10619 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*);
10621 /* NOTE: si_dup() looks at PL_markstack */
10622 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
10624 /* PL_curstack = PL_curstackinfo->si_stack; */
10625 PL_curstack = av_dup(proto_perl->Tcurstack, param);
10626 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
10628 /* next PUSHs() etc. set *(PL_stack_sp+1) */
10629 PL_stack_base = AvARRAY(PL_curstack);
10630 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
10631 - proto_perl->Tstack_base);
10632 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
10634 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
10635 * NOTE: unlike the others! */
10636 PL_savestack_ix = proto_perl->Tsavestack_ix;
10637 PL_savestack_max = proto_perl->Tsavestack_max;
10638 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
10639 PL_savestack = ss_dup(proto_perl, param);
10643 ENTER; /* perl_destruct() wants to LEAVE; */
10646 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
10647 PL_top_env = &PL_start_env;
10649 PL_op = proto_perl->Top;
10652 PL_Xpv = (XPV*)NULL;
10653 PL_na = proto_perl->Tna;
10655 PL_statbuf = proto_perl->Tstatbuf;
10656 PL_statcache = proto_perl->Tstatcache;
10657 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
10658 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
10660 PL_timesbuf = proto_perl->Ttimesbuf;
10663 PL_tainted = proto_perl->Ttainted;
10664 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
10665 PL_rs = sv_dup_inc(proto_perl->Trs, param);
10666 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
10667 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
10668 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
10669 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
10670 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
10671 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
10672 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
10674 PL_restartop = proto_perl->Trestartop;
10675 PL_in_eval = proto_perl->Tin_eval;
10676 PL_delaymagic = proto_perl->Tdelaymagic;
10677 PL_dirty = proto_perl->Tdirty;
10678 PL_localizing = proto_perl->Tlocalizing;
10680 #ifdef PERL_FLEXIBLE_EXCEPTIONS
10681 PL_protect = proto_perl->Tprotect;
10683 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
10684 PL_av_fetch_sv = Nullsv;
10685 PL_hv_fetch_sv = Nullsv;
10686 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
10687 PL_modcount = proto_perl->Tmodcount;
10688 PL_lastgotoprobe = Nullop;
10689 PL_dumpindent = proto_perl->Tdumpindent;
10691 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
10692 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
10693 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
10694 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
10695 PL_sortcxix = proto_perl->Tsortcxix;
10696 PL_efloatbuf = Nullch; /* reinits on demand */
10697 PL_efloatsize = 0; /* reinits on demand */
10701 PL_screamfirst = NULL;
10702 PL_screamnext = NULL;
10703 PL_maxscream = -1; /* reinits on demand */
10704 PL_lastscream = Nullsv;
10706 PL_watchaddr = NULL;
10707 PL_watchok = Nullch;
10709 PL_regdummy = proto_perl->Tregdummy;
10710 PL_regcomp_parse = Nullch;
10711 PL_regxend = Nullch;
10712 PL_regcode = (regnode*)NULL;
10715 PL_regprecomp = Nullch;
10720 PL_seen_zerolen = 0;
10722 PL_regcomp_rx = (regexp*)NULL;
10724 PL_colorset = 0; /* reinits PL_colors[] */
10725 /*PL_colors[6] = {0,0,0,0,0,0};*/
10726 PL_reg_whilem_seen = 0;
10727 PL_reginput = Nullch;
10728 PL_regbol = Nullch;
10729 PL_regeol = Nullch;
10730 PL_regstartp = (I32*)NULL;
10731 PL_regendp = (I32*)NULL;
10732 PL_reglastparen = (U32*)NULL;
10733 PL_regtill = Nullch;
10734 PL_reg_start_tmp = (char**)NULL;
10735 PL_reg_start_tmpl = 0;
10736 PL_regdata = (struct reg_data*)NULL;
10739 PL_reg_eval_set = 0;
10741 PL_regprogram = (regnode*)NULL;
10743 PL_regcc = (CURCUR*)NULL;
10744 PL_reg_call_cc = (struct re_cc_state*)NULL;
10745 PL_reg_re = (regexp*)NULL;
10746 PL_reg_ganch = Nullch;
10747 PL_reg_sv = Nullsv;
10748 PL_reg_match_utf8 = FALSE;
10749 PL_reg_magic = (MAGIC*)NULL;
10751 PL_reg_oldcurpm = (PMOP*)NULL;
10752 PL_reg_curpm = (PMOP*)NULL;
10753 PL_reg_oldsaved = Nullch;
10754 PL_reg_oldsavedlen = 0;
10755 PL_reg_maxiter = 0;
10756 PL_reg_leftiter = 0;
10757 PL_reg_poscache = Nullch;
10758 PL_reg_poscache_size= 0;
10760 /* RE engine - function pointers */
10761 PL_regcompp = proto_perl->Tregcompp;
10762 PL_regexecp = proto_perl->Tregexecp;
10763 PL_regint_start = proto_perl->Tregint_start;
10764 PL_regint_string = proto_perl->Tregint_string;
10765 PL_regfree = proto_perl->Tregfree;
10767 PL_reginterp_cnt = 0;
10768 PL_reg_starttry = 0;
10770 /* Pluggable optimizer */
10771 PL_peepp = proto_perl->Tpeepp;
10773 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
10774 ptr_table_free(PL_ptr_table);
10775 PL_ptr_table = NULL;
10778 /* Call the ->CLONE method, if it exists, for each of the stashes
10779 identified by sv_dup() above.
10781 while(av_len(param->stashes) != -1) {
10782 HV* stash = (HV*) av_shift(param->stashes);
10783 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
10784 if (cloner && GvCV(cloner)) {
10789 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
10791 call_sv((SV*)GvCV(cloner), G_DISCARD);
10797 SvREFCNT_dec(param->stashes);
10802 #endif /* USE_ITHREADS */
10805 =head1 Unicode Support
10807 =for apidoc sv_recode_to_utf8
10809 The encoding is assumed to be an Encode object, on entry the PV
10810 of the sv is assumed to be octets in that encoding, and the sv
10811 will be converted into Unicode (and UTF-8).
10813 If the sv already is UTF-8 (or if it is not POK), or if the encoding
10814 is not a reference, nothing is done to the sv. If the encoding is not
10815 an C<Encode::XS> Encoding object, bad things will happen.
10816 (See F<lib/encoding.pm> and L<Encode>).
10818 The PV of the sv is returned.
10823 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
10825 if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) {
10838 Passing sv_yes is wrong - it needs to be or'ed set of constants
10839 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
10840 remove converted chars from source.
10842 Both will default the value - let them.
10844 XPUSHs(&PL_sv_yes);
10847 call_method("decode", G_SCALAR);
10851 s = SvPV(uni, len);
10852 if (s != SvPVX(sv)) {
10853 SvGROW(sv, len + 1);
10854 Move(s, SvPVX(sv), len, char);
10855 SvCUR_set(sv, len);
10856 SvPVX(sv)[len] = 0;