3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
9 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
12 * This file contains the code that creates, manipulates and destroys
13 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14 * structure of an SV, so their creation and destruction is handled
15 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16 * level functions (eg. substr, split, join) for each of the types are
28 /* Missing proto on LynxOS */
29 char *gconvert(double, int, int, char *);
32 #ifdef PERL_UTF8_CACHE_ASSERT
33 /* if adding more checks watch out for the following tests:
34 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
35 * lib/utf8.t lib/Unicode/Collate/t/index.t
38 #define ASSERT_UTF8_CACHE(cache) \
39 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
40 assert((cache)[2] <= (cache)[3]); \
41 assert((cache)[3] <= (cache)[1]);} \
44 #define ASSERT_UTF8_CACHE(cache) NOOP
47 /* ============================================================================
49 =head1 Allocation and deallocation of SVs.
51 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
52 av, hv...) contains type and reference count information, as well as a
53 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
54 specific to each type.
56 In all but the most memory-paranoid configuations (ex: PURIFY), this
57 allocation is done using arenas, which by default are approximately 4K
58 chunks of memory parcelled up into N heads or bodies (of same size).
59 Sv-bodies are allocated by their sv-type, guaranteeing size
60 consistency needed to allocate safely from arrays.
62 The first slot in each arena is reserved, and is used to hold a link
63 to the next arena. In the case of heads, the unused first slot also
64 contains some flags and a note of the number of slots. Snaked through
65 each arena chain is a linked list of free items; when this becomes
66 empty, an extra arena is allocated and divided up into N items which
67 are threaded into the free list.
69 The following global variables are associated with arenas:
71 PL_sv_arenaroot pointer to list of SV arenas
72 PL_sv_root pointer to list of free SV structures
74 PL_body_arenaroots[] array of pointers to list of arenas, 1 per svtype
75 PL_body_roots[] array of pointers to list of free bodies of svtype
76 arrays are indexed by the svtype needed
78 Note that some of the larger and more rarely used body types (eg
79 xpvio) are not allocated using arenas, but are instead just
80 malloc()/free()ed as required.
82 In addition, a few SV heads are not allocated from an arena, but are
83 instead directly created as static or auto variables, eg PL_sv_undef.
84 The size of arenas can be changed from the default by setting
85 PERL_ARENA_SIZE appropriately at compile time.
87 The SV arena serves the secondary purpose of allowing still-live SVs
88 to be located and destroyed during final cleanup.
90 At the lowest level, the macros new_SV() and del_SV() grab and free
91 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
92 to return the SV to the free list with error checking.) new_SV() calls
93 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
94 SVs in the free list have their SvTYPE field set to all ones.
96 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
97 that allocate and return individual body types. Normally these are mapped
98 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
99 instead mapped directly to malloc()/free() if PURIFY is defined. The
100 new/del functions remove from, or add to, the appropriate PL_foo_root
101 list, and call more_xiv() etc to add a new arena if the list is empty.
103 At the time of very final cleanup, sv_free_arenas() is called from
104 perl_destruct() to physically free all the arenas allocated since the
105 start of the interpreter.
107 Manipulation of any of the PL_*root pointers is protected by enclosing
108 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
109 if threads are enabled.
111 The function visit() scans the SV arenas list, and calls a specified
112 function for each SV it finds which is still live - ie which has an SvTYPE
113 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
114 following functions (specified as [function that calls visit()] / [function
115 called by visit() for each SV]):
117 sv_report_used() / do_report_used()
118 dump all remaining SVs (debugging aid)
120 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
121 Attempt to free all objects pointed to by RVs,
122 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
123 try to do the same for all objects indirectly
124 referenced by typeglobs too. Called once from
125 perl_destruct(), prior to calling sv_clean_all()
128 sv_clean_all() / do_clean_all()
129 SvREFCNT_dec(sv) each remaining SV, possibly
130 triggering an sv_free(). It also sets the
131 SVf_BREAK flag on the SV to indicate that the
132 refcnt has been artificially lowered, and thus
133 stopping sv_free() from giving spurious warnings
134 about SVs which unexpectedly have a refcnt
135 of zero. called repeatedly from perl_destruct()
136 until there are no SVs left.
138 =head2 Arena allocator API Summary
140 Private API to rest of sv.c
144 new_XIV(), del_XIV(),
145 new_XNV(), del_XNV(),
150 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
155 ============================================================================ */
160 * "A time to plant, and a time to uproot what was planted..."
164 * nice_chunk and nice_chunk size need to be set
165 * and queried under the protection of sv_mutex
168 Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
173 new_chunk = (void *)(chunk);
174 new_chunk_size = (chunk_size);
175 if (new_chunk_size > PL_nice_chunk_size) {
176 Safefree(PL_nice_chunk);
177 PL_nice_chunk = (char *) new_chunk;
178 PL_nice_chunk_size = new_chunk_size;
185 #define plant_SV(p) \
187 SvANY(p) = (void *)PL_sv_root; \
188 SvFLAGS(p) = SVTYPEMASK; \
193 /* sv_mutex must be held while calling uproot_SV() */
194 #define uproot_SV(p) \
197 PL_sv_root = (SV*)SvANY(p); \
202 /* make some more SVs by adding another arena */
204 /* sv_mutex must be held while calling more_sv() */
211 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
212 PL_nice_chunk = NULL;
213 PL_nice_chunk_size = 0;
216 char *chunk; /* must use New here to match call to */
217 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
218 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
224 /* new_SV(): return a new, empty SV head */
226 #ifdef DEBUG_LEAKING_SCALARS
227 /* provide a real function for a debugger to play with */
237 sv = S_more_sv(aTHX);
244 # define new_SV(p) (p)=S_new_SV(aTHX)
253 (p) = S_more_sv(aTHX); \
262 /* del_SV(): return an empty SV head to the free list */
277 S_del_sv(pTHX_ SV *p)
282 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
283 const SV * const sv = sva + 1;
284 const SV * const svend = &sva[SvREFCNT(sva)];
285 if (p >= sv && p < svend) {
291 if (ckWARN_d(WARN_INTERNAL))
292 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
293 "Attempt to free non-arena SV: 0x%"UVxf
294 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
301 #else /* ! DEBUGGING */
303 #define del_SV(p) plant_SV(p)
305 #endif /* DEBUGGING */
309 =head1 SV Manipulation Functions
311 =for apidoc sv_add_arena
313 Given a chunk of memory, link it to the head of the list of arenas,
314 and split it into a list of free SVs.
320 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
326 /* The first SV in an arena isn't an SV. */
327 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
328 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
329 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
331 PL_sv_arenaroot = sva;
332 PL_sv_root = sva + 1;
334 svend = &sva[SvREFCNT(sva) - 1];
337 SvANY(sv) = (void *)(SV*)(sv + 1);
341 /* Must always set typemask because it's awlays checked in on cleanup
342 when the arenas are walked looking for objects. */
343 SvFLAGS(sv) = SVTYPEMASK;
350 SvFLAGS(sv) = SVTYPEMASK;
353 /* visit(): call the named function for each non-free SV in the arenas
354 * whose flags field matches the flags/mask args. */
357 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
362 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
363 register const SV * const svend = &sva[SvREFCNT(sva)];
365 for (sv = sva + 1; sv < svend; ++sv) {
366 if (SvTYPE(sv) != SVTYPEMASK
367 && (sv->sv_flags & mask) == flags
380 /* called by sv_report_used() for each live SV */
383 do_report_used(pTHX_ SV *sv)
385 if (SvTYPE(sv) != SVTYPEMASK) {
386 PerlIO_printf(Perl_debug_log, "****\n");
393 =for apidoc sv_report_used
395 Dump the contents of all SVs not yet freed. (Debugging aid).
401 Perl_sv_report_used(pTHX)
404 visit(do_report_used, 0, 0);
408 /* called by sv_clean_objs() for each live SV */
411 do_clean_objs(pTHX_ SV *sv)
415 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
416 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
428 /* XXX Might want to check arrays, etc. */
431 /* called by sv_clean_objs() for each live SV */
433 #ifndef DISABLE_DESTRUCTOR_KLUDGE
435 do_clean_named_objs(pTHX_ SV *sv)
437 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
439 #ifdef PERL_DONT_CREATE_GVSV
442 SvOBJECT(GvSV(sv))) ||
443 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
444 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
445 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
446 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
448 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
449 SvFLAGS(sv) |= SVf_BREAK;
457 =for apidoc sv_clean_objs
459 Attempt to destroy all objects not yet freed
465 Perl_sv_clean_objs(pTHX)
467 PL_in_clean_objs = TRUE;
468 visit(do_clean_objs, SVf_ROK, SVf_ROK);
469 #ifndef DISABLE_DESTRUCTOR_KLUDGE
470 /* some barnacles may yet remain, clinging to typeglobs */
471 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
473 PL_in_clean_objs = FALSE;
476 /* called by sv_clean_all() for each live SV */
479 do_clean_all(pTHX_ SV *sv)
481 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
482 SvFLAGS(sv) |= SVf_BREAK;
487 =for apidoc sv_clean_all
489 Decrement the refcnt of each remaining SV, possibly triggering a
490 cleanup. This function may have to be called multiple times to free
491 SVs which are in complex self-referential hierarchies.
497 Perl_sv_clean_all(pTHX)
500 PL_in_clean_all = TRUE;
501 cleaned = visit(do_clean_all, 0,0);
502 PL_in_clean_all = FALSE;
507 S_free_arena(pTHX_ void **root) {
509 void **next = *(void **)root;
516 =for apidoc sv_free_arenas
518 Deallocate the memory used by all arenas. Note that all the individual SV
519 heads and bodies within the arenas must already have been freed.
524 Perl_sv_free_arenas(pTHX)
530 /* Free arenas here, but be careful about fake ones. (We assume
531 contiguity of the fake ones with the corresponding real ones.) */
533 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
534 svanext = (SV*) SvANY(sva);
535 while (svanext && SvFAKE(svanext))
536 svanext = (SV*) SvANY(svanext);
542 S_free_arena(aTHX_ (void**) PL_body_arenas);
545 for (i=0; i<PERL_ARENA_ROOTS_SIZE; i++) {
546 PL_body_roots[i] = 0;
549 Safefree(PL_nice_chunk);
550 PL_nice_chunk = NULL;
551 PL_nice_chunk_size = 0;
557 =for apidoc report_uninit
559 Print appropriate "Use of uninitialized variable" warning
565 Perl_report_uninit(pTHX)
568 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
569 " in ", OP_DESC(PL_op));
571 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, "", "");
575 Here are mid-level routines that manage the allocation of bodies out
576 of the various arenas. There are 5 kinds of arenas:
578 1. SV-head arenas, which are discussed and handled above
579 2. regular body arenas
580 3. arenas for reduced-size bodies
582 5. pte arenas (thread related)
584 Arena types 2 & 3 are chained by body-type off an array of
585 arena-root pointers, which is indexed by svtype. Some of the
586 larger/less used body types are malloced singly, since a large
587 unused block of them is wasteful. Also, several svtypes dont have
588 bodies; the data fits into the sv-head itself. The arena-root
589 pointer thus has a few unused root-pointers (which may be hijacked
590 later for arena types 4,5)
592 3 differs from 2 as an optimization; some body types have several
593 unused fields in the front of the structure (which are kept in-place
594 for consistency). These bodies can be allocated in smaller chunks,
595 because the leading fields arent accessed. Pointers to such bodies
596 are decremented to point at the unused 'ghost' memory, knowing that
597 the pointers are used with offsets to the real memory.
599 HE, HEK arenas are managed separately, with separate code, but may
600 be merge-able later..
602 PTE arenas are not sv-bodies, but they share these mid-level
603 mechanics, so are considered here. The new mid-level mechanics rely
604 on the sv_type of the body being allocated, so we just reserve one
605 of the unused body-slots for PTEs, then use it in those (2) PTE
606 contexts below (line ~10k)
610 S_more_bodies (pTHX_ size_t size, svtype sv_type)
612 void ** const root = &PL_body_roots[sv_type];
615 const size_t count = PERL_ARENA_SIZE / size;
617 New(0, start, count*size, char);
618 *((void **) start) = PL_body_arenas;
619 PL_body_arenas = (void *)start;
621 end = start + (count-1) * size;
623 /* The initial slot is used to link the arenas together, so it isn't to be
624 linked into the list of ready-to-use bodies. */
628 *root = (void *)start;
630 while (start < end) {
631 char *next = start + size;
632 *(void**) start = (void *)next;
640 /* grab a new thing from the free list, allocating more if necessary */
642 /* 1st, the inline version */
644 #define new_body_inline(xpv, size, sv_type) \
646 void **r3wt = &PL_body_roots[sv_type]; \
648 xpv = *((void **)(r3wt)) \
649 ? *((void **)(r3wt)) : S_more_bodies(aTHX_ size, sv_type); \
650 *(r3wt) = *(void**)(xpv); \
654 /* now use the inline version in the proper function */
658 /* This isn't being used with -DPURIFY, so don't declare it. Otherwise
659 compilers issue warnings. */
662 S_new_body(pTHX_ size_t size, svtype sv_type)
665 new_body_inline(xpv, size, sv_type);
671 /* return a thing to the free list */
673 #define del_body(thing, root) \
675 void **thing_copy = (void **)thing; \
677 *thing_copy = *root; \
678 *root = (void*)thing_copy; \
683 Revisiting type 3 arenas, there are 4 body-types which have some
684 members that are never accessed. They are XPV, XPVIV, XPVAV,
685 XPVHV, which have corresponding types: xpv_allocated,
686 xpviv_allocated, xpvav_allocated, xpvhv_allocated,
688 For these types, the arenas are carved up into *_allocated size
689 chunks, we thus avoid wasted memory for those unaccessed members.
690 When bodies are allocated, we adjust the pointer back in memory by
691 the size of the bit not allocated, so it's as if we allocated the
692 full structure. (But things will all go boom if you write to the
693 part that is "not there", because you'll be overwriting the last
694 members of the preceding structure in memory.)
696 We calculate the correction using the STRUCT_OFFSET macro. For example, if
697 xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
698 and the pointer is unchanged. If the allocated structure is smaller (no
699 initial NV actually allocated) then the net effect is to subtract the size
700 of the NV from the pointer, to return a new pointer as if an initial NV were
703 This is the same trick as was used for NV and IV bodies. Ironically it
704 doesn't need to be used for NV bodies any more, because NV is now at the
705 start of the structure. IV bodies don't need it either, because they are
706 no longer allocated. */
708 /* The following 2 arrays hide the above details in a pair of
709 lookup-tables, allowing us to be body-type agnostic.
711 size maps svtype to its body's allocated size.
712 offset maps svtype to the body-pointer adjustment needed
714 NB: elements in latter are 0 or <0, and are added during
715 allocation, and subtracted during deallocation. It may be clearer
716 to invert the values, and call it shrinkage_by_svtype.
719 struct body_details {
720 size_t size; /* Size to allocate */
721 size_t copy; /* Size of structure to copy (may be shorter) */
723 bool cant_upgrade; /* Can upgrade this type */
724 bool zero_nv; /* zero the NV when upgrading from this */
725 bool arena; /* Allocated from an arena */
732 /* With -DPURFIY we allocate everything directly, and don't use arenas.
733 This seems a rather elegant way to simplify some of the code below. */
734 #define HASARENA FALSE
736 #define HASARENA TRUE
738 #define NOARENA FALSE
740 /* A macro to work out the offset needed to subtract from a pointer to (say)
747 to make its members accessible via a pointer to (say)
757 #define relative_STRUCT_OFFSET(longer, shorter, member) \
758 (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
760 /* Calculate the length to copy. Specifically work out the length less any
761 final padding the compiler needed to add. See the comment in sv_upgrade
762 for why copying the padding proved to be a bug. */
764 #define copy_length(type, last_member) \
765 STRUCT_OFFSET(type, last_member) \
766 + sizeof (((type*)SvANY((SV*)0))->last_member)
768 static const struct body_details bodies_by_type[] = {
769 {0, 0, 0, FALSE, NONV, NOARENA},
770 {sizeof(xiv_allocated), sizeof(IV),
771 + relative_STRUCT_OFFSET(xiv_allocated, XPVIV, xiv_iv),
772 FALSE, NONV, HASARENA},
773 {sizeof(xnv_allocated), sizeof(NV),
774 + relative_STRUCT_OFFSET(xnv_allocated, XPVNV, xnv_nv),
775 FALSE, HADNV, HASARENA},
776 {sizeof(XRV), sizeof(XRV), 0, FALSE, NONV, HASARENA},
777 {sizeof(xpv_allocated),
778 copy_length(XPV, xpv_len)
779 - relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
780 + relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
781 FALSE, NONV, HASARENA},
782 {sizeof(xpviv_allocated),
783 copy_length(XPVIV, xiv_iv)
784 - relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
785 + relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
786 FALSE, NONV, HASARENA},
787 {sizeof(XPVNV), copy_length(XPVNV, xnv_nv), 0, FALSE, HADNV, HASARENA},
788 {sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, FALSE, HADNV, HASARENA},
789 {sizeof(XPVBM), sizeof(XPVBM), 0, TRUE, HADNV, HASARENA},
790 {sizeof(XPVLV), sizeof(XPVLV), 0, TRUE, HADNV, HASARENA},
791 {sizeof(xpvav_allocated),
792 sizeof(xpvav_allocated)
793 - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
794 + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
795 TRUE, HADNV, HASARENA},
796 {sizeof(xpvhv_allocated),
797 sizeof(xpvhv_allocated)
798 - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
799 + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
800 TRUE, HADNV, HASARENA},
801 {sizeof(XPVCV), sizeof(XPVCV), 0, TRUE, HADNV, HASARENA},
802 {sizeof(XPVGV), sizeof(XPVGV), 0, TRUE, HADNV, HASARENA},
803 {sizeof(XPVFM), sizeof(XPVFM), 0, TRUE, HADNV, NOARENA},
804 {sizeof(XPVIO), sizeof(XPVIO), 0, TRUE, HADNV, NOARENA}
807 #define new_body_type(sv_type) \
808 (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type))
810 #define del_body_type(p, sv_type) \
811 del_body(p, &PL_body_roots[sv_type])
814 #define new_body_allocated(sv_type) \
815 (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
816 - bodies_by_type[sv_type].offset)
818 #define del_body_allocated(p, sv_type) \
819 del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
822 #define my_safemalloc(s) (void*)safemalloc(s)
823 #define my_safecalloc(s) (void*)safecalloc(s, 1)
824 #define my_safefree(p) safefree((char*)p)
826 typedef struct xpviv XIV;
827 typedef struct xpvnv XNV;
831 #define new_XIV() my_safemalloc(sizeof(XPVIV))
832 #define del_XIV(p) my_safefree(p)
834 #define new_XNV() my_safemalloc(sizeof(XPVNV))
835 #define del_XNV(p) my_safefree(p)
837 #define new_XRV() my_safemalloc(sizeof(XRV))
838 #define del_XRV(p) my_safefree(p)
840 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
841 #define del_XPVNV(p) my_safefree(p)
843 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
844 #define del_XPVAV(p) my_safefree(p)
846 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
847 #define del_XPVHV(p) my_safefree(p)
849 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
850 #define del_XPVMG(p) my_safefree(p)
852 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
853 #define del_XPVGV(p) my_safefree(p)
857 #define new_XIV() new_body_allocated(SVt_IV)
858 #define del_XIV(p) del_body_allocated(p, SVt_IV)
860 #define new_XNV() new_body_allocated(SVt_NV)
861 #define del_XNV(p) del_body_allocated(p, SVt_NV)
863 #define new_XRV() new_body_type(SVt_RV)
864 #define del_XRV(p) del_body_type(SVt_RV)
866 #define new_XPVNV() new_body_type(SVt_PVNV)
867 #define del_XPVNV(p) del_body_type(p, SVt_PVNV)
869 #define new_XPVAV() new_body_allocated(SVt_PVAV)
870 #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
872 #define new_XPVHV() new_body_allocated(SVt_PVHV)
873 #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
875 #define new_XPVMG() new_body_type(SVt_PVMG)
876 #define del_XPVMG(p) del_body_type(p, SVt_PVMG)
878 #define new_XPVGV() new_body_type(SVt_PVGV)
879 #define del_XPVGV(p) del_body_type(p, SVt_PVGV)
883 /* no arena for you! */
885 #define new_NOARENA(details) \
886 my_safemalloc((details)->size + (details)->offset)
887 #define new_NOARENAZ(details) \
888 my_safecalloc((details)->size + (details)->offset)
891 =for apidoc sv_upgrade
893 Upgrade an SV to a more complex form. Generally adds a new body type to the
894 SV, then copies across as much information as possible from the old body.
895 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
901 Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
905 U32 old_type = SvTYPE(sv);
906 const struct body_details *const old_type_details
907 = bodies_by_type + old_type;
908 const struct body_details *new_type_details;
910 if (new_type != SVt_PV && SvIsCOW(sv)) {
911 sv_force_normal_flags(sv, 0);
914 if (old_type == new_type)
917 old_body = SvANY(sv);
919 /* Copying structures onto other structures that have been neatly zeroed
920 has a subtle gotcha. Consider XPVMG
922 +------+------+------+------+------+-------+-------+
923 | NV | CUR | LEN | IV | MAGIC | STASH |
924 +------+------+------+------+------+-------+-------+
927 where NVs are aligned to 8 bytes, so that sizeof that structure is
928 actually 32 bytes long, with 4 bytes of padding at the end:
930 +------+------+------+------+------+-------+-------+------+
931 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
932 +------+------+------+------+------+-------+-------+------+
933 0 4 8 12 16 20 24 28 32
935 so what happens if you allocate memory for this structure:
937 +------+------+------+------+------+-------+-------+------+------+...
938 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
939 +------+------+------+------+------+-------+-------+------+------+...
940 0 4 8 12 16 20 24 28 32 36
942 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
943 expect, because you copy the area marked ??? onto GP. Now, ??? may have
944 started out as zero once, but it's quite possible that it isn't. So now,
945 rather than a nicely zeroed GP, you have it pointing somewhere random.
948 (In fact, GP ends up pointing at a previous GP structure, because the
949 principle cause of the padding in XPVMG getting garbage is a copy of
950 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
952 So we are careful and work out the size of used parts of all the
959 if (new_type < SVt_PVIV) {
960 new_type = (new_type == SVt_NV)
961 ? SVt_PVNV : SVt_PVIV;
966 if (new_type < SVt_PVNV) {
971 if (new_type == SVt_IV)
973 else if (new_type == SVt_NV)
977 if (new_type == SVt_IV)
979 else if (new_type == SVt_NV)
983 if (new_type == SVt_NV)
989 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
990 there's no way that it can be safely upgraded, because perl.c
991 expects to Safefree(SvANY(PL_mess_sv)) */
992 assert(sv != PL_mess_sv);
993 /* This flag bit is used to mean other things in other scalar types.
994 Given that it only has meaning inside the pad, it shouldn't be set
995 on anything that can get upgraded. */
996 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
999 if (old_type_details->cant_upgrade)
1000 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1001 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1003 new_type_details = bodies_by_type + new_type;
1005 if (old_type > new_type) {
1009 SvFLAGS(sv) &= ~SVTYPEMASK;
1010 SvFLAGS(sv) |= new_type;
1012 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1013 the return statements above will have triggered. */
1014 assert (new_type != SVt_NULL);
1017 assert(old_type == SVt_NULL);
1018 SvANY(sv) = new_XIV();
1022 assert(old_type == SVt_NULL);
1023 SvANY(sv) = new_XNV();
1027 assert(old_type == SVt_NULL);
1028 SvANY(sv) = new_XRV();
1033 assert(new_type_details->size);
1036 assert(new_type_details->arena);
1037 /* This points to the start of the allocated area. */
1038 new_body_inline(new_body, new_type_details->size, new_type);
1039 Zero(new_body, new_type_details->size, char);
1040 new_body = ((char *)new_body) - new_type_details->offset;
1042 /* We always allocated the full length item with PURIFY. To do this
1043 we fake things so that arena is false for all 16 types.. */
1044 new_body = new_NOARENAZ(new_type_details);
1046 SvANY(sv) = new_body;
1047 if (new_type == SVt_PVAV) {
1050 AvFLAGS(sv) = AVf_REAL;
1053 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1054 The target created by newSVrv also is, and it can have magic.
1055 However, it never has SvPVX set.
1057 if (old_type >= SVt_RV && ((XPV*)old_body)->xpv_pv) {
1058 char *pv = ((XPV*)old_body)->xpv_pv;
1059 if (old_type >= SVt_PV) {
1061 pv -= ((XPVIV*)old_body)->xiv_iv;
1065 /* RV shouldn't be pointing at anything, but just in case. */
1067 SvREFCNT_dec((SV*)pv);
1072 if (old_type >= SVt_PVMG) {
1073 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
1074 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1080 /* XXX Is this still needed? Was it ever needed? Surely as there is
1081 no route from NV to PVIV, NOK can never be true */
1082 assert(!SvNOKp(sv));
1094 assert(new_type_details->size);
1095 /* We always allocated the full length item with PURIFY. To do this
1096 we fake things so that arena is false for all 16 types.. */
1097 if(new_type_details->arena) {
1098 /* This points to the start of the allocated area. */
1099 new_body_inline(new_body, new_type_details->size, new_type);
1100 Zero(new_body, new_type_details->size, char);
1101 new_body = ((char *)new_body) - new_type_details->offset;
1103 new_body = new_NOARENAZ(new_type_details);
1105 SvANY(sv) = new_body;
1107 if (old_type_details->copy) {
1108 Copy((char *)old_body + old_type_details->offset,
1109 (char *)new_body + old_type_details->offset,
1110 old_type_details->copy, char);
1113 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1114 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1115 * correct 0.0 for us. Otherwise, if the old body didn't have an
1116 * NV slot, but the new one does, then we need to initialise the
1117 * freshly created NV slot with whatever the correct bit pattern is
1119 if (old_type_details->zero_nv && !bodies_by_type[new_type].zero_nv)
1123 if (new_type == SVt_PVIO)
1124 IoPAGE_LEN(sv) = 60;
1127 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", new_type);
1130 if (old_type_details->size) {
1131 /* If the old body had an allocated size, then we need to free it. */
1133 my_safefree(old_body);
1135 del_body((void*)((char*)old_body + old_type_details->offset),
1136 &PL_body_roots[old_type]);
1143 =for apidoc sv_backoff
1145 Remove any string offset. You should normally use the C<SvOOK_off> macro
1152 Perl_sv_backoff(pTHX_ register SV *sv)
1156 const char * const s = SvPVX_const(sv);
1157 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1158 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1160 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1162 SvFLAGS(sv) &= ~SVf_OOK;
1169 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1170 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1171 Use the C<SvGROW> wrapper instead.
1177 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1183 #ifdef HAS_64K_LIMIT
1184 if (newlen >= 0x10000) {
1185 PerlIO_printf(Perl_debug_log,
1186 "Allocation too large: %"UVxf"\n", (UV)newlen);
1189 #endif /* HAS_64K_LIMIT */
1192 if (SvTYPE(sv) < SVt_PV) {
1193 sv_upgrade(sv, SVt_PV);
1194 s = SvPVX_mutable(sv);
1196 else if (SvOOK(sv)) { /* pv is offset? */
1198 s = SvPVX_mutable(sv);
1199 if (newlen > SvLEN(sv))
1200 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1201 #ifdef HAS_64K_LIMIT
1202 if (newlen >= 0x10000)
1207 s = SvPVX_mutable(sv);
1209 if (newlen > SvLEN(sv)) { /* need more room? */
1210 newlen = PERL_STRLEN_ROUNDUP(newlen);
1211 if (SvLEN(sv) && s) {
1213 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1219 s = saferealloc(s, newlen);
1222 /* sv_force_normal_flags() must not try to unshare the new
1223 PVX we allocate below. AMS 20010713 */
1224 if (SvREADONLY(sv) && SvFAKE(sv)) {
1228 s = safemalloc(newlen);
1229 if (SvPVX_const(sv) && SvCUR(sv)) {
1230 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1234 SvLEN_set(sv, newlen);
1240 =for apidoc sv_setiv
1242 Copies an integer into the given SV, upgrading first if necessary.
1243 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1249 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1251 SV_CHECK_THINKFIRST(sv);
1252 switch (SvTYPE(sv)) {
1254 sv_upgrade(sv, SVt_IV);
1257 sv_upgrade(sv, SVt_PVNV);
1261 sv_upgrade(sv, SVt_PVIV);
1270 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1273 (void)SvIOK_only(sv); /* validate number */
1279 =for apidoc sv_setiv_mg
1281 Like C<sv_setiv>, but also handles 'set' magic.
1287 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1294 =for apidoc sv_setuv
1296 Copies an unsigned integer into the given SV, upgrading first if necessary.
1297 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1303 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1305 /* With these two if statements:
1306 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1309 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1311 If you wish to remove them, please benchmark to see what the effect is
1313 if (u <= (UV)IV_MAX) {
1314 sv_setiv(sv, (IV)u);
1323 =for apidoc sv_setuv_mg
1325 Like C<sv_setuv>, but also handles 'set' magic.
1331 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1340 =for apidoc sv_setnv
1342 Copies a double into the given SV, upgrading first if necessary.
1343 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1349 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1351 SV_CHECK_THINKFIRST(sv);
1352 switch (SvTYPE(sv)) {
1355 sv_upgrade(sv, SVt_NV);
1360 sv_upgrade(sv, SVt_PVNV);
1369 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1373 (void)SvNOK_only(sv); /* validate number */
1378 =for apidoc sv_setnv_mg
1380 Like C<sv_setnv>, but also handles 'set' magic.
1386 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1392 /* Print an "isn't numeric" warning, using a cleaned-up,
1393 * printable version of the offending string
1397 S_not_a_number(pTHX_ SV *sv)
1404 dsv = sv_2mortal(newSVpvn("", 0));
1405 pv = sv_uni_display(dsv, sv, 10, 0);
1408 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1409 /* each *s can expand to 4 chars + "...\0",
1410 i.e. need room for 8 chars */
1412 const char *s, *end;
1413 for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
1416 if (ch & 128 && !isPRINT_LC(ch)) {
1425 else if (ch == '\r') {
1429 else if (ch == '\f') {
1433 else if (ch == '\\') {
1437 else if (ch == '\0') {
1441 else if (isPRINT_LC(ch))
1458 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1459 "Argument \"%s\" isn't numeric in %s", pv,
1462 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1463 "Argument \"%s\" isn't numeric", pv);
1467 =for apidoc looks_like_number
1469 Test if the content of an SV looks like a number (or is a number).
1470 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1471 non-numeric warning), even if your atof() doesn't grok them.
1477 Perl_looks_like_number(pTHX_ SV *sv)
1479 register const char *sbegin;
1483 sbegin = SvPVX_const(sv);
1486 else if (SvPOKp(sv))
1487 sbegin = SvPV_const(sv, len);
1489 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1490 return grok_number(sbegin, len, NULL);
1493 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1494 until proven guilty, assume that things are not that bad... */
1499 As 64 bit platforms often have an NV that doesn't preserve all bits of
1500 an IV (an assumption perl has been based on to date) it becomes necessary
1501 to remove the assumption that the NV always carries enough precision to
1502 recreate the IV whenever needed, and that the NV is the canonical form.
1503 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1504 precision as a side effect of conversion (which would lead to insanity
1505 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1506 1) to distinguish between IV/UV/NV slots that have cached a valid
1507 conversion where precision was lost and IV/UV/NV slots that have a
1508 valid conversion which has lost no precision
1509 2) to ensure that if a numeric conversion to one form is requested that
1510 would lose precision, the precise conversion (or differently
1511 imprecise conversion) is also performed and cached, to prevent
1512 requests for different numeric formats on the same SV causing
1513 lossy conversion chains. (lossless conversion chains are perfectly
1518 SvIOKp is true if the IV slot contains a valid value
1519 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1520 SvNOKp is true if the NV slot contains a valid value
1521 SvNOK is true only if the NV value is accurate
1524 while converting from PV to NV, check to see if converting that NV to an
1525 IV(or UV) would lose accuracy over a direct conversion from PV to
1526 IV(or UV). If it would, cache both conversions, return NV, but mark
1527 SV as IOK NOKp (ie not NOK).
1529 While converting from PV to IV, check to see if converting that IV to an
1530 NV would lose accuracy over a direct conversion from PV to NV. If it
1531 would, cache both conversions, flag similarly.
1533 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1534 correctly because if IV & NV were set NV *always* overruled.
1535 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1536 changes - now IV and NV together means that the two are interchangeable:
1537 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1539 The benefit of this is that operations such as pp_add know that if
1540 SvIOK is true for both left and right operands, then integer addition
1541 can be used instead of floating point (for cases where the result won't
1542 overflow). Before, floating point was always used, which could lead to
1543 loss of precision compared with integer addition.
1545 * making IV and NV equal status should make maths accurate on 64 bit
1547 * may speed up maths somewhat if pp_add and friends start to use
1548 integers when possible instead of fp. (Hopefully the overhead in
1549 looking for SvIOK and checking for overflow will not outweigh the
1550 fp to integer speedup)
1551 * will slow down integer operations (callers of SvIV) on "inaccurate"
1552 values, as the change from SvIOK to SvIOKp will cause a call into
1553 sv_2iv each time rather than a macro access direct to the IV slot
1554 * should speed up number->string conversion on integers as IV is
1555 favoured when IV and NV are equally accurate
1557 ####################################################################
1558 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1559 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1560 On the other hand, SvUOK is true iff UV.
1561 ####################################################################
1563 Your mileage will vary depending your CPU's relative fp to integer
1567 #ifndef NV_PRESERVES_UV
1568 # define IS_NUMBER_UNDERFLOW_IV 1
1569 # define IS_NUMBER_UNDERFLOW_UV 2
1570 # define IS_NUMBER_IV_AND_UV 2
1571 # define IS_NUMBER_OVERFLOW_IV 4
1572 # define IS_NUMBER_OVERFLOW_UV 5
1574 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1576 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1578 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1580 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
1581 if (SvNVX(sv) < (NV)IV_MIN) {
1582 (void)SvIOKp_on(sv);
1584 SvIV_set(sv, IV_MIN);
1585 return IS_NUMBER_UNDERFLOW_IV;
1587 if (SvNVX(sv) > (NV)UV_MAX) {
1588 (void)SvIOKp_on(sv);
1591 SvUV_set(sv, UV_MAX);
1592 return IS_NUMBER_OVERFLOW_UV;
1594 (void)SvIOKp_on(sv);
1596 /* Can't use strtol etc to convert this string. (See truth table in
1598 if (SvNVX(sv) <= (UV)IV_MAX) {
1599 SvIV_set(sv, I_V(SvNVX(sv)));
1600 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1601 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1603 /* Integer is imprecise. NOK, IOKp */
1605 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1608 SvUV_set(sv, U_V(SvNVX(sv)));
1609 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1610 if (SvUVX(sv) == UV_MAX) {
1611 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1612 possibly be preserved by NV. Hence, it must be overflow.
1614 return IS_NUMBER_OVERFLOW_UV;
1616 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1618 /* Integer is imprecise. NOK, IOKp */
1620 return IS_NUMBER_OVERFLOW_IV;
1622 #endif /* !NV_PRESERVES_UV*/
1625 S_sv_2iuv_common(pTHX_ SV *sv) {
1627 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1628 * without also getting a cached IV/UV from it at the same time
1629 * (ie PV->NV conversion should detect loss of accuracy and cache
1630 * IV or UV at same time to avoid this. */
1631 /* IV-over-UV optimisation - choose to cache IV if possible */
1633 if (SvTYPE(sv) == SVt_NV)
1634 sv_upgrade(sv, SVt_PVNV);
1636 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1637 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1638 certainly cast into the IV range at IV_MAX, whereas the correct
1639 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1641 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1642 SvIV_set(sv, I_V(SvNVX(sv)));
1643 if (SvNVX(sv) == (NV) SvIVX(sv)
1644 #ifndef NV_PRESERVES_UV
1645 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1646 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1647 /* Don't flag it as "accurately an integer" if the number
1648 came from a (by definition imprecise) NV operation, and
1649 we're outside the range of NV integer precision */
1652 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1653 DEBUG_c(PerlIO_printf(Perl_debug_log,
1654 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
1660 /* IV not precise. No need to convert from PV, as NV
1661 conversion would already have cached IV if it detected
1662 that PV->IV would be better than PV->NV->IV
1663 flags already correct - don't set public IOK. */
1664 DEBUG_c(PerlIO_printf(Perl_debug_log,
1665 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
1670 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1671 but the cast (NV)IV_MIN rounds to a the value less (more
1672 negative) than IV_MIN which happens to be equal to SvNVX ??
1673 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1674 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1675 (NV)UVX == NVX are both true, but the values differ. :-(
1676 Hopefully for 2s complement IV_MIN is something like
1677 0x8000000000000000 which will be exact. NWC */
1680 SvUV_set(sv, U_V(SvNVX(sv)));
1682 (SvNVX(sv) == (NV) SvUVX(sv))
1683 #ifndef NV_PRESERVES_UV
1684 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1685 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1686 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1687 /* Don't flag it as "accurately an integer" if the number
1688 came from a (by definition imprecise) NV operation, and
1689 we're outside the range of NV integer precision */
1694 DEBUG_c(PerlIO_printf(Perl_debug_log,
1695 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1701 else if (SvPOKp(sv) && SvLEN(sv)) {
1703 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
1704 /* We want to avoid a possible problem when we cache an IV/ a UV which
1705 may be later translated to an NV, and the resulting NV is not
1706 the same as the direct translation of the initial string
1707 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
1708 be careful to ensure that the value with the .456 is around if the
1709 NV value is requested in the future).
1711 This means that if we cache such an IV/a UV, we need to cache the
1712 NV as well. Moreover, we trade speed for space, and do not
1713 cache the NV if we are sure it's not needed.
1716 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
1717 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1718 == IS_NUMBER_IN_UV) {
1719 /* It's definitely an integer, only upgrade to PVIV */
1720 if (SvTYPE(sv) < SVt_PVIV)
1721 sv_upgrade(sv, SVt_PVIV);
1723 } else if (SvTYPE(sv) < SVt_PVNV)
1724 sv_upgrade(sv, SVt_PVNV);
1726 /* If NV preserves UV then we only use the UV value if we know that
1727 we aren't going to call atof() below. If NVs don't preserve UVs
1728 then the value returned may have more precision than atof() will
1729 return, even though value isn't perfectly accurate. */
1730 if ((numtype & (IS_NUMBER_IN_UV
1731 #ifdef NV_PRESERVES_UV
1734 )) == IS_NUMBER_IN_UV) {
1735 /* This won't turn off the public IOK flag if it was set above */
1736 (void)SvIOKp_on(sv);
1738 if (!(numtype & IS_NUMBER_NEG)) {
1740 if (value <= (UV)IV_MAX) {
1741 SvIV_set(sv, (IV)value);
1743 /* it didn't overflow, and it was positive. */
1744 SvUV_set(sv, value);
1748 /* 2s complement assumption */
1749 if (value <= (UV)IV_MIN) {
1750 SvIV_set(sv, -(IV)value);
1752 /* Too negative for an IV. This is a double upgrade, but
1753 I'm assuming it will be rare. */
1754 if (SvTYPE(sv) < SVt_PVNV)
1755 sv_upgrade(sv, SVt_PVNV);
1759 SvNV_set(sv, -(NV)value);
1760 SvIV_set(sv, IV_MIN);
1764 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
1765 will be in the previous block to set the IV slot, and the next
1766 block to set the NV slot. So no else here. */
1768 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1769 != IS_NUMBER_IN_UV) {
1770 /* It wasn't an (integer that doesn't overflow the UV). */
1771 SvNV_set(sv, Atof(SvPVX_const(sv)));
1773 if (! numtype && ckWARN(WARN_NUMERIC))
1776 #if defined(USE_LONG_DOUBLE)
1777 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1778 PTR2UV(sv), SvNVX(sv)));
1780 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
1781 PTR2UV(sv), SvNVX(sv)));
1784 #ifdef NV_PRESERVES_UV
1785 (void)SvIOKp_on(sv);
1787 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1788 SvIV_set(sv, I_V(SvNVX(sv)));
1789 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1792 /* Integer is imprecise. NOK, IOKp */
1794 /* UV will not work better than IV */
1796 if (SvNVX(sv) > (NV)UV_MAX) {
1798 /* Integer is inaccurate. NOK, IOKp, is UV */
1799 SvUV_set(sv, UV_MAX);
1801 SvUV_set(sv, U_V(SvNVX(sv)));
1802 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
1803 NV preservse UV so can do correct comparison. */
1804 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1807 /* Integer is imprecise. NOK, IOKp, is UV */
1812 #else /* NV_PRESERVES_UV */
1813 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1814 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
1815 /* The IV/UV slot will have been set from value returned by
1816 grok_number above. The NV slot has just been set using
1819 assert (SvIOKp(sv));
1821 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1822 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1823 /* Small enough to preserve all bits. */
1824 (void)SvIOKp_on(sv);
1826 SvIV_set(sv, I_V(SvNVX(sv)));
1827 if ((NV)(SvIVX(sv)) == SvNVX(sv))
1829 /* Assumption: first non-preserved integer is < IV_MAX,
1830 this NV is in the preserved range, therefore: */
1831 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1833 Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)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);
1837 0 0 already failed to read UV.
1838 0 1 already failed to read UV.
1839 1 0 you won't get here in this case. IV/UV
1840 slot set, public IOK, Atof() unneeded.
1841 1 1 already read UV.
1842 so there's no point in sv_2iuv_non_preserve() attempting
1843 to use atol, strtol, strtoul etc. */
1844 sv_2iuv_non_preserve (sv, numtype);
1847 #endif /* NV_PRESERVES_UV */
1851 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1852 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
1855 if (SvTYPE(sv) < SVt_IV)
1856 /* Typically the caller expects that sv_any is not NULL now. */
1857 sv_upgrade(sv, SVt_IV);
1858 /* Return 0 from the caller. */
1865 =for apidoc sv_2iv_flags
1867 Return the integer value of an SV, doing any necessary string
1868 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
1869 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
1875 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
1879 if (SvGMAGICAL(sv)) {
1880 if (flags & SV_GMAGIC)
1885 return I_V(SvNVX(sv));
1887 if (SvPOKp(sv) && SvLEN(sv))
1890 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1891 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
1897 if (SvTHINKFIRST(sv)) {
1900 SV * const tmpstr=AMG_CALLun(sv,numer);
1901 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
1902 return SvIV(tmpstr);
1905 return PTR2IV(SvRV(sv));
1908 sv_force_normal_flags(sv, 0);
1910 if (SvREADONLY(sv) && !SvOK(sv)) {
1911 if (ckWARN(WARN_UNINITIALIZED))
1917 if (S_sv_2iuv_common(aTHX_ sv))
1920 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1921 PTR2UV(sv),SvIVX(sv)));
1922 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1926 =for apidoc sv_2uv_flags
1928 Return the unsigned integer value of an SV, doing any necessary string
1929 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
1930 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
1936 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
1940 if (SvGMAGICAL(sv)) {
1941 if (flags & SV_GMAGIC)
1946 return U_V(SvNVX(sv));
1947 if (SvPOKp(sv) && SvLEN(sv))
1950 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1951 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
1957 if (SvTHINKFIRST(sv)) {
1960 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1961 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
1962 return SvUV(tmpstr);
1963 return PTR2UV(SvRV(sv));
1965 if (SvREADONLY(sv) && SvFAKE(sv)) {
1966 sv_force_normal(sv);
1968 if (SvREADONLY(sv) && !SvOK(sv)) {
1969 if (ckWARN(WARN_UNINITIALIZED))
1975 if (S_sv_2iuv_common(aTHX_ sv))
1979 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1980 PTR2UV(sv),SvUVX(sv)));
1981 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1987 Return the num value of an SV, doing any necessary string or integer
1988 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
1995 Perl_sv_2nv(pTHX_ register SV *sv)
1999 if (SvGMAGICAL(sv)) {
2003 if (SvPOKp(sv) && SvLEN(sv)) {
2004 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2005 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2007 return Atof(SvPVX_const(sv));
2011 return (NV)SvUVX(sv);
2013 return (NV)SvIVX(sv);
2016 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2017 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2023 if (SvTHINKFIRST(sv)) {
2026 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2027 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2028 return SvNV(tmpstr);
2029 return PTR2NV(SvRV(sv));
2031 if (SvREADONLY(sv) && SvFAKE(sv)) {
2032 sv_force_normal(sv);
2034 if (SvREADONLY(sv) && !SvOK(sv)) {
2035 if (ckWARN(WARN_UNINITIALIZED))
2040 if (SvTYPE(sv) < SVt_NV) {
2041 if (SvTYPE(sv) == SVt_IV)
2042 sv_upgrade(sv, SVt_PVNV);
2044 sv_upgrade(sv, SVt_NV);
2045 #ifdef USE_LONG_DOUBLE
2047 STORE_NUMERIC_LOCAL_SET_STANDARD();
2048 PerlIO_printf(Perl_debug_log,
2049 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2050 PTR2UV(sv), SvNVX(sv));
2051 RESTORE_NUMERIC_LOCAL();
2055 STORE_NUMERIC_LOCAL_SET_STANDARD();
2056 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2057 PTR2UV(sv), SvNVX(sv));
2058 RESTORE_NUMERIC_LOCAL();
2062 else if (SvTYPE(sv) < SVt_PVNV)
2063 sv_upgrade(sv, SVt_PVNV);
2068 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2069 #ifdef NV_PRESERVES_UV
2072 /* Only set the public NV OK flag if this NV preserves the IV */
2073 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2074 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2075 : (SvIVX(sv) == I_V(SvNVX(sv))))
2081 else if (SvPOKp(sv) && SvLEN(sv)) {
2083 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2084 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2086 #ifdef NV_PRESERVES_UV
2087 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2088 == IS_NUMBER_IN_UV) {
2089 /* It's definitely an integer */
2090 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2092 SvNV_set(sv, Atof(SvPVX_const(sv)));
2095 SvNV_set(sv, Atof(SvPVX_const(sv)));
2096 /* Only set the public NV OK flag if this NV preserves the value in
2097 the PV at least as well as an IV/UV would.
2098 Not sure how to do this 100% reliably. */
2099 /* if that shift count is out of range then Configure's test is
2100 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2102 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2103 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2104 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2105 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2106 /* Can't use strtol etc to convert this string, so don't try.
2107 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2110 /* value has been set. It may not be precise. */
2111 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2112 /* 2s complement assumption for (UV)IV_MIN */
2113 SvNOK_on(sv); /* Integer is too negative. */
2118 if (numtype & IS_NUMBER_NEG) {
2119 SvIV_set(sv, -(IV)value);
2120 } else if (value <= (UV)IV_MAX) {
2121 SvIV_set(sv, (IV)value);
2123 SvUV_set(sv, value);
2127 if (numtype & IS_NUMBER_NOT_INT) {
2128 /* I believe that even if the original PV had decimals,
2129 they are lost beyond the limit of the FP precision.
2130 However, neither is canonical, so both only get p
2131 flags. NWC, 2000/11/25 */
2132 /* Both already have p flags, so do nothing */
2134 const NV nv = SvNVX(sv);
2135 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2136 if (SvIVX(sv) == I_V(nv)) {
2141 /* It had no "." so it must be integer. */
2144 /* between IV_MAX and NV(UV_MAX).
2145 Could be slightly > UV_MAX */
2147 if (numtype & IS_NUMBER_NOT_INT) {
2148 /* UV and NV both imprecise. */
2150 const UV nv_as_uv = U_V(nv);
2152 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2163 #endif /* NV_PRESERVES_UV */
2166 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2168 if (SvTYPE(sv) < SVt_NV)
2169 /* Typically the caller expects that sv_any is not NULL now. */
2170 /* XXX Ilya implies that this is a bug in callers that assume this
2171 and ideally should be fixed. */
2172 sv_upgrade(sv, SVt_NV);
2175 #if defined(USE_LONG_DOUBLE)
2177 STORE_NUMERIC_LOCAL_SET_STANDARD();
2178 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2179 PTR2UV(sv), SvNVX(sv));
2180 RESTORE_NUMERIC_LOCAL();
2184 STORE_NUMERIC_LOCAL_SET_STANDARD();
2185 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2186 PTR2UV(sv), SvNVX(sv));
2187 RESTORE_NUMERIC_LOCAL();
2193 /* asIV(): extract an integer from the string value of an SV.
2194 * Caller must validate PVX */
2197 S_asIV(pTHX_ SV *sv)
2200 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2202 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2203 == IS_NUMBER_IN_UV) {
2204 /* It's definitely an integer */
2205 if (numtype & IS_NUMBER_NEG) {
2206 if (value < (UV)IV_MIN)
2209 if (value < (UV)IV_MAX)
2214 if (ckWARN(WARN_NUMERIC))
2217 return I_V(Atof(SvPVX_const(sv)));
2220 /* asUV(): extract an unsigned integer from the string value of an SV
2221 * Caller must validate PVX */
2224 S_asUV(pTHX_ SV *sv)
2227 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2229 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2230 == IS_NUMBER_IN_UV) {
2231 /* It's definitely an integer */
2232 if (!(numtype & IS_NUMBER_NEG))
2236 if (ckWARN(WARN_NUMERIC))
2239 return U_V(Atof(SvPVX_const(sv)));
2242 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2243 * UV as a string towards the end of buf, and return pointers to start and
2246 * We assume that buf is at least TYPE_CHARS(UV) long.
2250 S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2252 char *ptr = buf + TYPE_CHARS(UV);
2253 char * const ebuf = ptr;
2266 *--ptr = '0' + (char)(uv % 10);
2275 =for apidoc sv_2pv_flags
2277 Returns a pointer to the string value of an SV, and sets *lp to its length.
2278 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2280 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2281 usually end up here too.
2287 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2292 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2293 char *tmpbuf = tbuf;
2300 if (SvGMAGICAL(sv)) {
2301 if (flags & SV_GMAGIC)
2306 if (flags & SV_MUTABLE_RETURN)
2307 return SvPVX_mutable(sv);
2308 if (flags & SV_CONST_RETURN)
2309 return (char *)SvPVX_const(sv);
2314 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2316 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2321 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2326 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2327 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2335 if (SvTHINKFIRST(sv)) {
2338 register const char *typestr;
2339 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2340 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2342 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
2345 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2346 if (flags & SV_CONST_RETURN) {
2347 pv = (char *) SvPVX_const(tmpstr);
2349 pv = (flags & SV_MUTABLE_RETURN)
2350 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2353 *lp = SvCUR(tmpstr);
2355 pv = sv_2pv_flags(tmpstr, lp, flags);
2366 typestr = "NULLREF";
2370 switch (SvTYPE(sv)) {
2372 if ( ((SvFLAGS(sv) &
2373 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2374 == (SVs_OBJECT|SVs_SMG))
2375 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2376 const regexp *re = (regexp *)mg->mg_obj;
2379 const char *fptr = "msix";
2384 char need_newline = 0;
2385 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
2387 while((ch = *fptr++)) {
2389 reflags[left++] = ch;
2392 reflags[right--] = ch;
2397 reflags[left] = '-';
2401 mg->mg_len = re->prelen + 4 + left;
2403 * If /x was used, we have to worry about a regex
2404 * ending with a comment later being embedded
2405 * within another regex. If so, we don't want this
2406 * regex's "commentization" to leak out to the
2407 * right part of the enclosing regex, we must cap
2408 * it with a newline.
2410 * So, if /x was used, we scan backwards from the
2411 * end of the regex. If we find a '#' before we
2412 * find a newline, we need to add a newline
2413 * ourself. If we find a '\n' first (or if we
2414 * don't find '#' or '\n'), we don't need to add
2415 * anything. -jfriedl
2417 if (PMf_EXTENDED & re->reganch)
2419 const char *endptr = re->precomp + re->prelen;
2420 while (endptr >= re->precomp)
2422 const char c = *(endptr--);
2424 break; /* don't need another */
2426 /* we end while in a comment, so we
2428 mg->mg_len++; /* save space for it */
2429 need_newline = 1; /* note to add it */
2435 Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
2436 Copy("(?", mg->mg_ptr, 2, char);
2437 Copy(reflags, mg->mg_ptr+2, left, char);
2438 Copy(":", mg->mg_ptr+left+2, 1, char);
2439 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2441 mg->mg_ptr[mg->mg_len - 2] = '\n';
2442 mg->mg_ptr[mg->mg_len - 1] = ')';
2443 mg->mg_ptr[mg->mg_len] = 0;
2445 PL_reginterp_cnt += re->program[0].next_off;
2447 if (re->reganch & ROPT_UTF8)
2463 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
2464 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
2465 /* tied lvalues should appear to be
2466 * scalars for backwards compatitbility */
2467 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
2468 ? "SCALAR" : "LVALUE"; break;
2469 case SVt_PVAV: typestr = "ARRAY"; break;
2470 case SVt_PVHV: typestr = "HASH"; break;
2471 case SVt_PVCV: typestr = "CODE"; break;
2472 case SVt_PVGV: typestr = "GLOB"; break;
2473 case SVt_PVFM: typestr = "FORMAT"; break;
2474 case SVt_PVIO: typestr = "IO"; break;
2475 default: typestr = "UNKNOWN"; break;
2479 const char *name = HvNAME_get(SvSTASH(sv));
2480 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
2481 name ? name : "__ANON__" , typestr, PTR2UV(sv));
2484 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
2488 *lp = strlen(typestr);
2489 return (char *)typestr;
2491 if (SvREADONLY(sv) && !SvOK(sv)) {
2492 if (ckWARN(WARN_UNINITIALIZED))
2499 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2500 /* I'm assuming that if both IV and NV are equally valid then
2501 converting the IV is going to be more efficient */
2502 const U32 isIOK = SvIOK(sv);
2503 const U32 isUIOK = SvIsUV(sv);
2504 char buf[TYPE_CHARS(UV)];
2507 if (SvTYPE(sv) < SVt_PVIV)
2508 sv_upgrade(sv, SVt_PVIV);
2510 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2512 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2513 /* inlined from sv_setpvn */
2514 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
2515 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
2516 SvCUR_set(sv, ebuf - ptr);
2526 else if (SvNOKp(sv)) {
2527 if (SvTYPE(sv) < SVt_PVNV)
2528 sv_upgrade(sv, SVt_PVNV);
2529 /* The +20 is pure guesswork. Configure test needed. --jhi */
2530 s = SvGROW_mutable(sv, NV_DIG + 20);
2531 olderrno = errno; /* some Xenix systems wipe out errno here */
2533 if (SvNVX(sv) == 0.0)
2534 (void)strcpy(s,"0");
2538 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2541 #ifdef FIXNEGATIVEZERO
2542 if (*s == '-' && s[1] == '0' && !s[2])
2552 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2556 if (SvTYPE(sv) < SVt_PV)
2557 /* Typically the caller expects that sv_any is not NULL now. */
2558 sv_upgrade(sv, SVt_PV);
2562 const STRLEN len = s - SvPVX_const(sv);
2568 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2569 PTR2UV(sv),SvPVX_const(sv)));
2570 if (flags & SV_CONST_RETURN)
2571 return (char *)SvPVX_const(sv);
2572 if (flags & SV_MUTABLE_RETURN)
2573 return SvPVX_mutable(sv);
2577 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2578 /* Sneaky stuff here */
2582 tsv = newSVpv(tmpbuf, 0);
2594 t = SvPVX_const(tsv);
2599 len = strlen(tmpbuf);
2601 #ifdef FIXNEGATIVEZERO
2602 if (len == 2 && t[0] == '-' && t[1] == '0') {
2607 (void)SvUPGRADE(sv, SVt_PV);
2610 s = SvGROW_mutable(sv, len + 1);
2613 return memcpy(s, t, len + 1);
2618 =for apidoc sv_copypv
2620 Copies a stringified representation of the source SV into the
2621 destination SV. Automatically performs any necessary mg_get and
2622 coercion of numeric values into strings. Guaranteed to preserve
2623 UTF-8 flag even from overloaded objects. Similar in nature to
2624 sv_2pv[_flags] but operates directly on an SV instead of just the
2625 string. Mostly uses sv_2pv_flags to do its work, except when that
2626 would lose the UTF-8'ness of the PV.
2632 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
2635 const char * const s = SvPV_const(ssv,len);
2636 sv_setpvn(dsv,s,len);
2644 =for apidoc sv_2pvbyte
2646 Return a pointer to the byte-encoded representation of the SV, and set *lp
2647 to its length. May cause the SV to be downgraded from UTF-8 as a
2650 Usually accessed via the C<SvPVbyte> macro.
2656 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2658 sv_utf8_downgrade(sv,0);
2659 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2663 * =for apidoc sv_2pvutf8
2665 * Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
2666 * to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
2668 * Usually accessed via the C<SvPVutf8> macro.
2674 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2676 sv_utf8_upgrade(sv);
2677 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2682 =for apidoc sv_2bool
2684 This function is only called on magical items, and is only used by
2685 sv_true() or its macro equivalent.
2691 Perl_sv_2bool(pTHX_ register SV *sv)
2699 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2700 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2701 return (bool)SvTRUE(tmpsv);
2702 return SvRV(sv) != 0;
2705 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
2707 (*Xpvtmp->xpv_pv > '0' ||
2708 Xpvtmp->xpv_cur > 1 ||
2709 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2716 return SvIVX(sv) != 0;
2719 return SvNVX(sv) != 0.0;
2727 =for apidoc sv_utf8_upgrade
2729 Converts the PV of an SV to its UTF-8-encoded form.
2730 Forces the SV to string form if it is not already.
2731 Always sets the SvUTF8 flag to avoid future validity checks even
2732 if all the bytes have hibit clear.
2734 This is not as a general purpose byte encoding to Unicode interface:
2735 use the Encode extension for that.
2737 =for apidoc sv_utf8_upgrade_flags
2739 Converts the PV of an SV to its UTF-8-encoded form.
2740 Forces the SV to string form if it is not already.
2741 Always sets the SvUTF8 flag to avoid future validity checks even
2742 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
2743 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
2744 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
2746 This is not as a general purpose byte encoding to Unicode interface:
2747 use the Encode extension for that.
2753 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
2755 if (sv == &PL_sv_undef)
2759 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
2760 (void) sv_2pv_flags(sv,&len, flags);
2764 (void) SvPV_force(sv,len);
2772 if (SvREADONLY(sv) && SvFAKE(sv)) {
2773 sv_force_normal(sv);
2776 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
2777 sv_recode_to_utf8(sv, PL_encoding);
2778 else { /* Assume Latin-1/EBCDIC */
2779 /* This function could be much more efficient if we
2780 * had a FLAG in SVs to signal if there are any hibit
2781 * chars in the PV. Given that there isn't such a flag
2782 * make the loop as fast as possible. */
2783 const U8 *s = (U8 *) SvPVX_const(sv);
2784 const U8 *e = (U8 *) SvEND(sv);
2790 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
2794 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
2795 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
2797 SvPV_free(sv); /* No longer using what was there before. */
2799 SvPV_set(sv, (char*)recoded);
2800 SvCUR_set(sv, len - 1);
2801 SvLEN_set(sv, len); /* No longer know the real size. */
2803 /* Mark as UTF-8 even if no hibit - saves scanning loop */
2810 =for apidoc sv_utf8_downgrade
2812 Attempts to convert the PV of an SV from characters to bytes.
2813 If the PV contains a character beyond byte, this conversion will fail;
2814 in this case, either returns false or, if C<fail_ok> is not
2817 This is not as a general purpose Unicode to byte encoding interface:
2818 use the Encode extension for that.
2824 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2826 if (SvPOKp(sv) && SvUTF8(sv)) {
2831 if (SvREADONLY(sv) && SvFAKE(sv))
2832 sv_force_normal(sv);
2833 s = (U8 *) SvPV(sv, len);
2834 if (!utf8_to_bytes(s, &len)) {
2839 Perl_croak(aTHX_ "Wide character in %s",
2842 Perl_croak(aTHX_ "Wide character");
2853 =for apidoc sv_utf8_encode
2855 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
2856 flag off so that it looks like octets again.
2862 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2864 (void) sv_utf8_upgrade(sv);
2866 sv_force_normal_flags(sv, 0);
2868 if (SvREADONLY(sv)) {
2869 Perl_croak(aTHX_ PL_no_modify);
2875 =for apidoc sv_utf8_decode
2877 If the PV of the SV is an octet sequence in UTF-8
2878 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
2879 so that it looks like a character. If the PV contains only single-byte
2880 characters, the C<SvUTF8> flag stays being off.
2881 Scans PV for validity and returns false if the PV is invalid UTF-8.
2887 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2893 /* The octets may have got themselves encoded - get them back as
2896 if (!sv_utf8_downgrade(sv, TRUE))
2899 /* it is actually just a matter of turning the utf8 flag on, but
2900 * we want to make sure everything inside is valid utf8 first.
2902 c = (const U8 *) SvPVX_const(sv);
2903 if (!is_utf8_string((U8 *)c, SvCUR(sv)+1))
2905 e = (const U8 *) SvEND(sv);
2908 if (!UTF8_IS_INVARIANT(ch)) {
2918 =for apidoc sv_setsv
2920 Copies the contents of the source SV C<ssv> into the destination SV
2921 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
2922 function if the source SV needs to be reused. Does not handle 'set' magic.
2923 Loosely speaking, it performs a copy-by-value, obliterating any previous
2924 content of the destination.
2926 You probably want to use one of the assortment of wrappers, such as
2927 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
2928 C<SvSetMagicSV_nosteal>.
2930 =for apidoc sv_setsv_flags
2932 Copies the contents of the source SV C<ssv> into the destination SV
2933 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
2934 function if the source SV needs to be reused. Does not handle 'set' magic.
2935 Loosely speaking, it performs a copy-by-value, obliterating any previous
2936 content of the destination.
2937 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
2938 C<ssv> if appropriate, else not. If the C<flags> parameter has the
2939 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
2940 and C<sv_setsv_nomg> are implemented in terms of this function.
2942 You probably want to use one of the assortment of wrappers, such as
2943 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
2944 C<SvSetMagicSV_nosteal>.
2946 This is the primary function for copying scalars, and most other
2947 copy-ish functions and macros use this underneath.
2953 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
2955 register U32 sflags;
2961 SV_CHECK_THINKFIRST(dstr);
2963 sstr = &PL_sv_undef;
2964 stype = SvTYPE(sstr);
2965 dtype = SvTYPE(dstr);
2970 /* need to nuke the magic */
2972 SvRMAGICAL_off(dstr);
2975 /* There's a lot of redundancy below but we're going for speed here */
2980 if (dtype != SVt_PVGV) {
2981 (void)SvOK_off(dstr);
2989 sv_upgrade(dstr, SVt_IV);
2992 sv_upgrade(dstr, SVt_PVNV);
2996 sv_upgrade(dstr, SVt_PVIV);
2999 (void)SvIOK_only(dstr);
3000 SvIV_set(dstr, SvIVX(sstr));
3003 if (SvTAINTED(sstr))
3014 sv_upgrade(dstr, SVt_NV);
3019 sv_upgrade(dstr, SVt_PVNV);
3022 SvNV_set(dstr, SvNVX(sstr));
3023 (void)SvNOK_only(dstr);
3024 if (SvTAINTED(sstr))
3032 sv_upgrade(dstr, SVt_RV);
3033 else if (dtype == SVt_PVGV &&
3034 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3037 if (GvIMPORTED(dstr) != GVf_IMPORTED
3038 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3040 GvIMPORTED_on(dstr);
3051 sv_upgrade(dstr, SVt_PV);
3054 if (dtype < SVt_PVIV)
3055 sv_upgrade(dstr, SVt_PVIV);
3058 if (dtype < SVt_PVNV)
3059 sv_upgrade(dstr, SVt_PVNV);
3066 const char * const type = sv_reftype(sstr,0);
3068 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3070 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3075 if (dtype <= SVt_PVGV) {
3077 if (dtype != SVt_PVGV) {
3078 const char * const name = GvNAME(sstr);
3079 const STRLEN len = GvNAMELEN(sstr);
3080 sv_upgrade(dstr, SVt_PVGV);
3081 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3082 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3083 GvNAME(dstr) = savepvn(name, len);
3084 GvNAMELEN(dstr) = len;
3085 SvFAKE_on(dstr); /* can coerce to non-glob */
3087 /* ahem, death to those who redefine active sort subs */
3088 else if (PL_curstackinfo->si_type == PERLSI_SORT
3089 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3090 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3093 #ifdef GV_UNIQUE_CHECK
3094 if (GvUNIQUE((GV*)dstr)) {
3095 Perl_croak(aTHX_ PL_no_modify);
3099 (void)SvOK_off(dstr);
3100 GvINTRO_off(dstr); /* one-shot flag */
3102 GvGP(dstr) = gp_ref(GvGP(sstr));
3103 if (SvTAINTED(sstr))
3105 if (GvIMPORTED(dstr) != GVf_IMPORTED
3106 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3108 GvIMPORTED_on(dstr);
3116 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3118 if ((int)SvTYPE(sstr) != stype) {
3119 stype = SvTYPE(sstr);
3120 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3124 if (stype == SVt_PVLV)
3125 (void)SvUPGRADE(dstr, SVt_PVNV);
3127 (void)SvUPGRADE(dstr, (U32)stype);
3130 sflags = SvFLAGS(sstr);
3132 if (sflags & SVf_ROK) {
3133 if (dtype >= SVt_PV) {
3134 if (dtype == SVt_PVGV) {
3135 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3137 const int intro = GvINTRO(dstr);
3139 #ifdef GV_UNIQUE_CHECK
3140 if (GvUNIQUE((GV*)dstr)) {
3141 Perl_croak(aTHX_ PL_no_modify);
3146 GvINTRO_off(dstr); /* one-shot flag */
3147 GvLINE(dstr) = CopLINE(PL_curcop);
3148 GvEGV(dstr) = (GV*)dstr;
3151 switch (SvTYPE(sref)) {
3154 SAVEGENERICSV(GvAV(dstr));
3156 dref = (SV*)GvAV(dstr);
3157 GvAV(dstr) = (AV*)sref;
3158 if (!GvIMPORTED_AV(dstr)
3159 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3161 GvIMPORTED_AV_on(dstr);
3166 SAVEGENERICSV(GvHV(dstr));
3168 dref = (SV*)GvHV(dstr);
3169 GvHV(dstr) = (HV*)sref;
3170 if (!GvIMPORTED_HV(dstr)
3171 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3173 GvIMPORTED_HV_on(dstr);
3178 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3179 SvREFCNT_dec(GvCV(dstr));
3180 GvCV(dstr) = Nullcv;
3181 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3182 PL_sub_generation++;
3184 SAVEGENERICSV(GvCV(dstr));
3187 dref = (SV*)GvCV(dstr);
3188 if (GvCV(dstr) != (CV*)sref) {
3189 CV* const cv = GvCV(dstr);
3191 if (!GvCVGEN((GV*)dstr) &&
3192 (CvROOT(cv) || CvXSUB(cv)))
3194 /* ahem, death to those who redefine
3195 * active sort subs */
3196 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3197 PL_sortcop == CvSTART(cv))
3199 "Can't redefine active sort subroutine %s",
3200 GvENAME((GV*)dstr));
3201 /* Redefining a sub - warning is mandatory if
3202 it was a const and its value changed. */
3203 if (ckWARN(WARN_REDEFINE)
3205 && (!CvCONST((CV*)sref)
3206 || sv_cmp(cv_const_sv(cv),
3207 cv_const_sv((CV*)sref)))))
3209 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3211 ? "Constant subroutine %s::%s redefined"
3212 : "Subroutine %s::%s redefined",
3213 HvNAME_get(GvSTASH((GV*)dstr)),
3214 GvENAME((GV*)dstr));
3218 cv_ckproto(cv, (GV*)dstr,
3220 ? (char *)SvPVX_const(sref)
3223 GvCV(dstr) = (CV*)sref;
3224 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3225 GvASSUMECV_on(dstr);
3226 PL_sub_generation++;
3228 if (!GvIMPORTED_CV(dstr)
3229 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3231 GvIMPORTED_CV_on(dstr);
3236 SAVEGENERICSV(GvIOp(dstr));
3238 dref = (SV*)GvIOp(dstr);
3239 GvIOp(dstr) = (IO*)sref;
3243 SAVEGENERICSV(GvFORM(dstr));
3245 dref = (SV*)GvFORM(dstr);
3246 GvFORM(dstr) = (CV*)sref;
3250 SAVEGENERICSV(GvSV(dstr));
3252 dref = (SV*)GvSV(dstr);
3254 if (!GvIMPORTED_SV(dstr)
3255 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3257 GvIMPORTED_SV_on(dstr);
3263 if (SvTAINTED(sstr))
3267 if (SvPVX_const(dstr)) {
3273 (void)SvOK_off(dstr);
3274 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3276 if (sflags & SVp_NOK) {
3278 /* Only set the public OK flag if the source has public OK. */
3279 if (sflags & SVf_NOK)
3280 SvFLAGS(dstr) |= SVf_NOK;
3281 SvNV_set(dstr, SvNVX(sstr));
3283 if (sflags & SVp_IOK) {
3284 (void)SvIOKp_on(dstr);
3285 if (sflags & SVf_IOK)
3286 SvFLAGS(dstr) |= SVf_IOK;
3287 if (sflags & SVf_IVisUV)
3289 SvIV_set(dstr, SvIVX(sstr));
3291 if (SvAMAGIC(sstr)) {
3295 else if (sflags & SVp_POK) {
3298 * Check to see if we can just swipe the string. If so, it's a
3299 * possible small lose on short strings, but a big win on long ones.
3300 * It might even be a win on short strings if SvPVX_const(dstr)
3301 * has to be allocated and SvPVX_const(sstr) has to be freed.
3304 if (SvTEMP(sstr) && /* slated for free anyway? */
3305 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3306 (!(flags & SV_NOSTEAL)) && /* and we're allowed to steal temps */
3307 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3308 SvLEN(sstr) && /* and really is a string */
3309 /* and won't be needed again, potentially */
3310 !(PL_op && PL_op->op_type == OP_AASSIGN))
3312 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
3315 (void)SvPOK_only(dstr);
3316 SvPV_set(dstr, SvPVX(sstr));
3317 SvLEN_set(dstr, SvLEN(sstr));
3318 SvCUR_set(dstr, SvCUR(sstr));
3321 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3322 SvPV_set(sstr, Nullch);
3327 else { /* have to copy actual string */
3328 STRLEN len = SvCUR(sstr);
3329 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3330 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
3331 SvCUR_set(dstr, len);
3332 *SvEND(dstr) = '\0';
3333 (void)SvPOK_only(dstr);
3335 if (sflags & SVf_UTF8)
3337 if (sflags & SVp_NOK) {
3339 if (sflags & SVf_NOK)
3340 SvFLAGS(dstr) |= SVf_NOK;
3341 SvNV_set(dstr, SvNVX(sstr));
3343 if (sflags & SVp_IOK) {
3344 (void)SvIOKp_on(dstr);
3345 if (sflags & SVf_IOK)
3346 SvFLAGS(dstr) |= SVf_IOK;
3347 if (sflags & SVf_IVisUV)
3349 SvIV_set(dstr, SvIVX(sstr));
3351 if ( SvVOK(sstr) ) {
3352 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
3353 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
3354 smg->mg_ptr, smg->mg_len);
3355 SvRMAGICAL_on(dstr);
3358 else if (sflags & SVp_IOK) {
3359 if (sflags & SVf_IOK)
3360 (void)SvIOK_only(dstr);
3362 (void)SvOK_off(dstr);
3363 (void)SvIOKp_on(dstr);
3365 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3366 if (sflags & SVf_IVisUV)
3368 SvIV_set(dstr, SvIVX(sstr));
3369 if (sflags & SVp_NOK) {
3370 if (sflags & SVf_NOK)
3371 (void)SvNOK_on(dstr);
3373 (void)SvNOKp_on(dstr);
3374 SvNV_set(dstr, SvNVX(sstr));
3377 else if (sflags & SVp_NOK) {
3378 if (sflags & SVf_NOK)
3379 (void)SvNOK_only(dstr);
3381 (void)SvOK_off(dstr);
3384 SvNV_set(dstr, SvNVX(sstr));
3387 if (dtype == SVt_PVGV) {
3388 if (ckWARN(WARN_MISC))
3389 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
3392 (void)SvOK_off(dstr);
3394 if (SvTAINTED(sstr))
3399 =for apidoc sv_setsv_mg
3401 Like C<sv_setsv>, but also handles 'set' magic.
3407 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3409 sv_setsv(dstr,sstr);
3414 =for apidoc sv_setpvn
3416 Copies a string into an SV. The C<len> parameter indicates the number of
3417 bytes to be copied. If the C<ptr> argument is NULL the SV will become
3418 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3424 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3426 register char *dptr;
3428 SV_CHECK_THINKFIRST(sv);
3434 /* len is STRLEN which is unsigned, need to copy to signed */
3437 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3439 (void)SvUPGRADE(sv, SVt_PV);
3441 dptr = SvGROW(sv, len + 1);
3442 Move(ptr,dptr,len,char);
3445 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3450 =for apidoc sv_setpvn_mg
3452 Like C<sv_setpvn>, but also handles 'set' magic.
3458 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3460 sv_setpvn(sv,ptr,len);
3465 =for apidoc sv_setpv
3467 Copies a string into an SV. The string must be null-terminated. Does not
3468 handle 'set' magic. See C<sv_setpv_mg>.
3474 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3476 register STRLEN len;
3478 SV_CHECK_THINKFIRST(sv);
3484 (void)SvUPGRADE(sv, SVt_PV);
3486 SvGROW(sv, len + 1);
3487 Move(ptr,SvPVX(sv),len+1,char);
3489 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3494 =for apidoc sv_setpv_mg
3496 Like C<sv_setpv>, but also handles 'set' magic.
3502 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3509 =for apidoc sv_usepvn
3511 Tells an SV to use C<ptr> to find its string value. Normally the string is
3512 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3513 The C<ptr> should point to memory that was allocated by C<malloc>. The
3514 string length, C<len>, must be supplied. This function will realloc the
3515 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3516 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3517 See C<sv_usepvn_mg>.
3523 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3526 SV_CHECK_THINKFIRST(sv);
3527 (void)SvUPGRADE(sv, SVt_PV);
3532 if (SvPVX_const(sv))
3535 allocate = PERL_STRLEN_ROUNDUP(len + 1);
3536 ptr = saferealloc (ptr, allocate);
3539 SvLEN_set(sv, allocate);
3541 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3546 =for apidoc sv_usepvn_mg
3548 Like C<sv_usepvn>, but also handles 'set' magic.
3554 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3556 sv_usepvn(sv,ptr,len);
3561 =for apidoc sv_force_normal_flags
3563 Undo various types of fakery on an SV: if the PV is a shared string, make
3564 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
3565 an xpvmg. The C<flags> parameter gets passed to C<sv_unref_flags()>
3566 when unrefing. C<sv_force_normal> calls this function with flags set to 0.
3572 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3574 if (SvREADONLY(sv)) {
3576 const char * const pvx = SvPVX_const(sv);
3577 const STRLEN len = SvCUR(sv);
3578 const U32 hash = SvSHARED_HASH(sv);
3581 SvGROW(sv, len + 1);
3582 Move(pvx,SvPVX(sv),len,char);
3584 unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
3586 else if (IN_PERL_RUNTIME)
3587 Perl_croak(aTHX_ PL_no_modify);
3590 sv_unref_flags(sv, flags);
3591 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3598 Efficient removal of characters from the beginning of the string buffer.
3599 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3600 the string buffer. The C<ptr> becomes the first character of the adjusted
3601 string. Uses the "OOK hack".
3602 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
3603 refer to the same chunk of data.
3609 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
3611 register STRLEN delta;
3612 if (!ptr || !SvPOKp(sv))
3614 delta = ptr - SvPVX_const(sv);
3615 SV_CHECK_THINKFIRST(sv);
3616 if (SvTYPE(sv) < SVt_PVIV)
3617 sv_upgrade(sv,SVt_PVIV);
3620 if (!SvLEN(sv)) { /* make copy of shared string */
3621 const char *pvx = SvPVX_const(sv);
3622 const STRLEN len = SvCUR(sv);
3623 SvGROW(sv, len + 1);
3624 Move(pvx,SvPVX(sv),len,char);
3628 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
3629 and we do that anyway inside the SvNIOK_off
3631 SvFLAGS(sv) |= SVf_OOK;
3634 SvLEN_set(sv, SvLEN(sv) - delta);
3635 SvCUR_set(sv, SvCUR(sv) - delta);
3636 SvPV_set(sv, SvPVX(sv) + delta);
3637 SvIV_set(sv, SvIVX(sv) + delta);
3641 =for apidoc sv_catpvn
3643 Concatenates the string onto the end of the string which is in the SV. The
3644 C<len> indicates number of bytes to copy. If the SV has the UTF-8
3645 status set, then the bytes appended should be valid UTF-8.
3646 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
3648 =for apidoc sv_catpvn_flags
3650 Concatenates the string onto the end of the string which is in the SV. The
3651 C<len> indicates number of bytes to copy. If the SV has the UTF-8
3652 status set, then the bytes appended should be valid UTF-8.
3653 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
3654 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
3655 in terms of this function.
3661 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
3664 const char *dstr = SvPV_force_flags(dsv, dlen, flags);
3666 SvGROW(dsv, dlen + slen + 1);
3668 sstr = SvPVX_const(dsv);
3669 Move(sstr, SvPVX(dsv) + dlen, slen, char);
3670 SvCUR_set(dsv, SvCUR(dsv) + slen);
3672 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
3674 if (flags & SV_SMAGIC)
3679 =for apidoc sv_catsv
3681 Concatenates the string from SV C<ssv> onto the end of the string in
3682 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3683 not 'set' magic. See C<sv_catsv_mg>.
3685 =for apidoc sv_catsv_flags
3687 Concatenates the string from SV C<ssv> onto the end of the string in
3688 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
3689 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
3690 and C<sv_catsv_nomg> are implemented in terms of this function.
3695 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
3700 if ((spv = SvPV_const(ssv, slen))) {
3701 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
3702 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
3703 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
3704 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
3705 dsv->sv_flags doesn't have that bit set.
3706 Andy Dougherty 12 Oct 2001
3708 const I32 sutf8 = DO_UTF8(ssv);
3711 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
3713 dutf8 = DO_UTF8(dsv);
3715 if (dutf8 != sutf8) {
3717 /* Not modifying source SV, so taking a temporary copy. */
3718 SV* csv = sv_2mortal(newSVpvn(spv, slen));
3720 sv_utf8_upgrade(csv);
3721 spv = SvPV_const(csv, slen);
3724 sv_utf8_upgrade_nomg(dsv);
3726 sv_catpvn_nomg(dsv, spv, slen);
3729 if (flags & SV_SMAGIC)
3734 =for apidoc sv_catpv
3736 Concatenates the string onto the end of the string which is in the SV.
3737 If the SV has the UTF-8 status set, then the bytes appended should be
3738 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3743 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3745 register STRLEN len;
3751 junk = SvPV_force(sv, tlen);
3753 SvGROW(sv, tlen + len + 1);
3755 ptr = SvPVX_const(sv);
3756 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3757 SvCUR_set(sv, SvCUR(sv) + len);
3758 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3763 =for apidoc sv_catpv_mg
3765 Like C<sv_catpv>, but also handles 'set' magic.
3771 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3780 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
3781 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
3788 Perl_newSV(pTHX_ STRLEN len)
3794 sv_upgrade(sv, SVt_PV);
3795 SvGROW(sv, len + 1);
3800 =for apidoc sv_magicext
3802 Adds magic to an SV, upgrading it if necessary. Applies the
3803 supplied vtable and returns a pointer to the magic added.
3805 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
3806 In particular, you can add magic to SvREADONLY SVs, and add more than
3807 one instance of the same 'how'.
3809 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
3810 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
3811 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
3812 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
3814 (This is now used as a subroutine by C<sv_magic>.)
3819 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
3820 const char* name, I32 namlen)
3824 if (SvTYPE(sv) < SVt_PVMG) {
3825 (void)SvUPGRADE(sv, SVt_PVMG);
3827 Newxz(mg, 1, MAGIC);
3828 mg->mg_moremagic = SvMAGIC(sv);
3829 SvMAGIC_set(sv, mg);
3831 /* Sometimes a magic contains a reference loop, where the sv and
3832 object refer to each other. To prevent a reference loop that
3833 would prevent such objects being freed, we look for such loops
3834 and if we find one we avoid incrementing the object refcount.
3836 Note we cannot do this to avoid self-tie loops as intervening RV must
3837 have its REFCNT incremented to keep it in existence.
3840 if (!obj || obj == sv ||
3841 how == PERL_MAGIC_arylen ||
3842 how == PERL_MAGIC_qr ||
3843 (SvTYPE(obj) == SVt_PVGV &&
3844 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
3845 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
3846 GvFORM(obj) == (CV*)sv)))
3851 mg->mg_obj = SvREFCNT_inc_simple(obj);
3852 mg->mg_flags |= MGf_REFCOUNTED;
3855 /* Normal self-ties simply pass a null object, and instead of
3856 using mg_obj directly, use the SvTIED_obj macro to produce a
3857 new RV as needed. For glob "self-ties", we are tieing the PVIO
3858 with an RV obj pointing to the glob containing the PVIO. In
3859 this case, to avoid a reference loop, we need to weaken the
3863 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
3864 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
3870 mg->mg_len = namlen;
3873 mg->mg_ptr = savepvn(name, namlen);
3874 else if (namlen == HEf_SVKEY)
3875 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV*)name);
3877 mg->mg_ptr = (char *) name;
3879 mg->mg_virtual = vtable;
3883 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3888 =for apidoc sv_magic
3890 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
3891 then adds a new magic item of type C<how> to the head of the magic list.
3893 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
3894 handling of the C<name> and C<namlen> arguments.
3896 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
3897 to add more than one instance of the same 'how'.
3903 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3905 const MGVTBL *vtable;
3908 if (SvREADONLY(sv)) {
3910 /* its okay to attach magic to shared strings; the subsequent
3911 * upgrade to PVMG will unshare the string */
3912 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
3915 && how != PERL_MAGIC_regex_global
3916 && how != PERL_MAGIC_bm
3917 && how != PERL_MAGIC_fm
3918 && how != PERL_MAGIC_sv
3919 && how != PERL_MAGIC_backref
3922 Perl_croak(aTHX_ PL_no_modify);
3925 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
3926 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3927 /* sv_magic() refuses to add a magic of the same 'how' as an
3930 if (how == PERL_MAGIC_taint)
3938 vtable = &PL_vtbl_sv;
3940 case PERL_MAGIC_overload:
3941 vtable = &PL_vtbl_amagic;
3943 case PERL_MAGIC_overload_elem:
3944 vtable = &PL_vtbl_amagicelem;
3946 case PERL_MAGIC_overload_table:
3947 vtable = &PL_vtbl_ovrld;
3950 vtable = &PL_vtbl_bm;
3952 case PERL_MAGIC_regdata:
3953 vtable = &PL_vtbl_regdata;
3955 case PERL_MAGIC_regdatum:
3956 vtable = &PL_vtbl_regdatum;
3958 case PERL_MAGIC_env:
3959 vtable = &PL_vtbl_env;
3962 vtable = &PL_vtbl_fm;
3964 case PERL_MAGIC_envelem:
3965 vtable = &PL_vtbl_envelem;
3967 case PERL_MAGIC_regex_global:
3968 vtable = &PL_vtbl_mglob;
3970 case PERL_MAGIC_isa:
3971 vtable = &PL_vtbl_isa;
3973 case PERL_MAGIC_isaelem:
3974 vtable = &PL_vtbl_isaelem;
3976 case PERL_MAGIC_nkeys:
3977 vtable = &PL_vtbl_nkeys;
3979 case PERL_MAGIC_dbfile:
3982 case PERL_MAGIC_dbline:
3983 vtable = &PL_vtbl_dbline;
3985 #ifdef USE_5005THREADS
3986 case PERL_MAGIC_mutex:
3987 vtable = &PL_vtbl_mutex;
3989 #endif /* USE_5005THREADS */
3990 #ifdef USE_LOCALE_COLLATE
3991 case PERL_MAGIC_collxfrm:
3992 vtable = &PL_vtbl_collxfrm;
3994 #endif /* USE_LOCALE_COLLATE */
3995 case PERL_MAGIC_tied:
3996 vtable = &PL_vtbl_pack;
3998 case PERL_MAGIC_tiedelem:
3999 case PERL_MAGIC_tiedscalar:
4000 vtable = &PL_vtbl_packelem;
4003 vtable = &PL_vtbl_regexp;
4005 case PERL_MAGIC_sig:
4006 vtable = &PL_vtbl_sig;
4008 case PERL_MAGIC_sigelem:
4009 vtable = &PL_vtbl_sigelem;
4011 case PERL_MAGIC_taint:
4012 vtable = &PL_vtbl_taint;
4014 case PERL_MAGIC_uvar:
4015 vtable = &PL_vtbl_uvar;
4017 case PERL_MAGIC_vec:
4018 vtable = &PL_vtbl_vec;
4020 case PERL_MAGIC_vstring:
4023 case PERL_MAGIC_utf8:
4024 vtable = &PL_vtbl_utf8;
4026 case PERL_MAGIC_substr:
4027 vtable = &PL_vtbl_substr;
4029 case PERL_MAGIC_defelem:
4030 vtable = &PL_vtbl_defelem;
4032 case PERL_MAGIC_glob:
4033 vtable = &PL_vtbl_glob;
4035 case PERL_MAGIC_arylen:
4036 vtable = &PL_vtbl_arylen;
4038 case PERL_MAGIC_pos:
4039 vtable = &PL_vtbl_pos;
4041 case PERL_MAGIC_backref:
4042 vtable = &PL_vtbl_backref;
4044 case PERL_MAGIC_ext:
4045 /* Reserved for use by extensions not perl internals. */
4046 /* Useful for attaching extension internal data to perl vars. */
4047 /* Note that multiple extensions may clash if magical scalars */
4048 /* etc holding private data from one are passed to another. */
4052 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4055 /* Rest of work is done else where */
4056 mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen);
4059 case PERL_MAGIC_taint:
4062 case PERL_MAGIC_ext:
4063 case PERL_MAGIC_dbfile:
4070 =for apidoc sv_unmagic
4072 Removes all magic of type C<type> from an SV.
4078 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4082 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4085 for (mg = *mgp; mg; mg = *mgp) {
4086 if (mg->mg_type == type) {
4087 const MGVTBL* const vtbl = mg->mg_virtual;
4088 *mgp = mg->mg_moremagic;
4089 if (vtbl && vtbl->svt_free)
4090 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4091 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4093 Safefree(mg->mg_ptr);
4094 else if (mg->mg_len == HEf_SVKEY)
4095 SvREFCNT_dec((SV*)mg->mg_ptr);
4096 else if (mg->mg_type == PERL_MAGIC_utf8)
4097 Safefree(mg->mg_ptr);
4099 if (mg->mg_flags & MGf_REFCOUNTED)
4100 SvREFCNT_dec(mg->mg_obj);
4104 mgp = &mg->mg_moremagic;
4108 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4115 =for apidoc sv_rvweaken
4117 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4118 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4119 push a back-reference to this RV onto the array of backreferences
4120 associated with that magic.
4126 Perl_sv_rvweaken(pTHX_ SV *sv)
4129 if (!SvOK(sv)) /* let undefs pass */
4132 Perl_croak(aTHX_ "Can't weaken a nonreference");
4133 else if (SvWEAKREF(sv)) {
4134 if (ckWARN(WARN_MISC))
4135 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
4139 sv_add_backref(tsv, sv);
4145 /* Give tsv backref magic if it hasn't already got it, then push a
4146 * back-reference to sv onto the array associated with the backref magic.
4150 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4154 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4155 av = (AV*)mg->mg_obj;
4158 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4159 /* av now has a refcnt of 2, which avoids it getting freed
4160 * before us during global cleanup. The extra ref is removed
4161 * by magic_killbackrefs() when tsv is being freed */
4163 if (AvFILLp(av) >= AvMAX(av)) {
4164 av_extend(av, AvFILLp(av)+1);
4166 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
4169 /* delete a back-reference to ourselves from the backref magic associated
4170 * with the SV we point to.
4174 S_sv_del_backref(pTHX_ SV *sv)
4179 SV * const tsv = SvRV(sv);
4181 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4182 Perl_croak(aTHX_ "panic: del_backref");
4183 av = (AV *)mg->mg_obj;
4185 /* We shouldn't be in here more than once, but for paranoia reasons lets
4187 for (i = AvFILLp(av); i >= 0; i--) {
4189 const SSize_t fill = AvFILLp(av);
4191 /* We weren't the last entry.
4192 An unordered list has this property that you can take the
4193 last element off the end to fill the hole, and it's still
4194 an unordered list :-)
4199 AvFILLp(av) = fill - 1;
4205 =for apidoc sv_insert
4207 Inserts a string at the specified offset/length within the SV. Similar to
4208 the Perl substr() function.
4214 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4218 register char *midend;
4219 register char *bigend;
4225 Perl_croak(aTHX_ "Can't modify non-existent substring");
4226 SvPV_force(bigstr, curlen);
4227 (void)SvPOK_only_UTF8(bigstr);
4228 if (offset + len > curlen) {
4229 SvGROW(bigstr, offset+len+1);
4230 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4231 SvCUR_set(bigstr, offset+len);
4235 i = littlelen - len;
4236 if (i > 0) { /* string might grow */
4237 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4238 mid = big + offset + len;
4239 midend = bigend = big + SvCUR(bigstr);
4242 while (midend > mid) /* shove everything down */
4243 *--bigend = *--midend;
4244 Move(little,big+offset,littlelen,char);
4245 SvCUR_set(bigstr, SvCUR(bigstr) + i);
4250 Move(little,SvPVX(bigstr)+offset,len,char);
4255 big = SvPVX(bigstr);
4258 bigend = big + SvCUR(bigstr);
4260 if (midend > bigend)
4261 Perl_croak(aTHX_ "panic: sv_insert");
4263 if (mid - big > bigend - midend) { /* faster to shorten from end */
4265 Move(little, mid, littlelen,char);
4268 i = bigend - midend;
4270 Move(midend, mid, i,char);
4274 SvCUR_set(bigstr, mid - big);
4276 else if ((i = mid - big)) { /* faster from front */
4277 midend -= littlelen;
4279 sv_chop(bigstr,midend-i);
4284 Move(little, mid, littlelen,char);
4286 else if (littlelen) {
4287 midend -= littlelen;
4288 sv_chop(bigstr,midend);
4289 Move(little,midend,littlelen,char);
4292 sv_chop(bigstr,midend);
4298 =for apidoc sv_replace
4300 Make the first argument a copy of the second, then delete the original.
4301 The target SV physically takes over ownership of the body of the source SV
4302 and inherits its flags; however, the target keeps any magic it owns,
4303 and any magic in the source is discarded.
4304 Note that this is a rather specialist SV copying operation; most of the
4305 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
4311 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4313 const U32 refcnt = SvREFCNT(sv);
4314 SV_CHECK_THINKFIRST(sv);
4315 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4316 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
4317 if (SvMAGICAL(sv)) {
4321 sv_upgrade(nsv, SVt_PVMG);
4322 SvMAGIC_set(nsv, SvMAGIC(sv));
4323 SvFLAGS(nsv) |= SvMAGICAL(sv);
4325 SvMAGIC_set(sv, NULL);
4329 assert(!SvREFCNT(sv));
4330 StructCopy(nsv,sv,SV);
4331 SvREFCNT(sv) = refcnt;
4332 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4338 =for apidoc sv_clear
4340 Clear an SV: call any destructors, free up any memory used by the body,
4341 and free the body itself. The SV's head is I<not> freed, although
4342 its type is set to all 1's so that it won't inadvertently be assumed
4343 to be live during global destruction etc.
4344 This function should only be called when REFCNT is zero. Most of the time
4345 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
4352 Perl_sv_clear(pTHX_ register SV *sv)
4355 const U32 type = SvTYPE(sv);
4356 const struct body_details *const sv_type_details
4357 = bodies_by_type + type;
4360 assert(SvREFCNT(sv) == 0);
4366 if (PL_defstash) { /* Still have a symbol table? */
4370 stash = SvSTASH(sv);
4371 destructor = StashHANDLER(stash,DESTROY);
4373 SV* const tmpref = newRV(sv);
4374 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
4376 PUSHSTACKi(PERLSI_DESTROY);
4381 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
4387 if(SvREFCNT(tmpref) < 2) {
4388 /* tmpref is not kept alive! */
4390 SvRV_set(tmpref, NULL);
4393 SvREFCNT_dec(tmpref);
4395 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4399 if (PL_in_clean_objs)
4400 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4402 /* DESTROY gave object new lease on life */
4408 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4409 SvOBJECT_off(sv); /* Curse the object. */
4410 if (type != SVt_PVIO)
4411 --PL_sv_objcount; /* XXX Might want something more general */
4414 if (type >= SVt_PVMG) {
4417 if (type == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
4418 SvREFCNT_dec(SvSTASH(sv));
4424 IoIFP(sv) != PerlIO_stdin() &&
4425 IoIFP(sv) != PerlIO_stdout() &&
4426 IoIFP(sv) != PerlIO_stderr())
4428 io_close((IO*)sv, FALSE);
4430 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4431 PerlDir_close(IoDIRP(sv));
4432 IoDIRP(sv) = (DIR*)NULL;
4433 Safefree(IoTOP_NAME(sv));
4434 Safefree(IoFMT_NAME(sv));
4435 Safefree(IoBOTTOM_NAME(sv));
4450 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
4451 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
4452 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
4453 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
4455 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
4456 SvREFCNT_dec(LvTARG(sv));
4460 Safefree(GvNAME(sv));
4461 /* cannot decrease stash refcount yet, as we might recursively delete
4462 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4463 of stash until current sv is completely gone.
4464 -- JohnPC, 27 Mar 1998 */
4465 stash = GvSTASH(sv);
4470 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
4472 SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
4473 /* Don't even bother with turning off the OOK flag. */
4481 SvREFCNT_dec(SvRV(sv));
4483 else if (SvPVX_const(sv) && SvLEN(sv))
4484 Safefree(SvPVX_mutable(sv));
4485 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4486 unsharepvn(SvPVX_const(sv),
4487 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
4497 SvFLAGS(sv) &= SVf_BREAK;
4498 SvFLAGS(sv) |= SVTYPEMASK;
4500 if (sv_type_details->arena) {
4501 del_body(((char *)SvANY(sv) + sv_type_details->offset),
4502 &PL_body_roots[type]);
4504 else if (sv_type_details->size) {
4505 my_safefree(SvANY(sv));
4508 /* decrease refcount of the stash that owns this GV, if any */
4510 SvREFCNT_dec(stash);
4515 =for apidoc sv_newref
4517 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
4524 Perl_sv_newref(pTHX_ SV *sv)
4527 ATOMIC_INC(SvREFCNT(sv));
4534 Decrement an SV's reference count, and if it drops to zero, call
4535 C<sv_clear> to invoke destructors and free up any memory used by
4536 the body; finally, deallocate the SV's head itself.
4537 Normally called via a wrapper macro C<SvREFCNT_dec>.
4543 Perl_sv_free(pTHX_ SV *sv)
4545 int refcount_is_zero;
4549 if (SvREFCNT(sv) == 0) {
4550 if (SvFLAGS(sv) & SVf_BREAK)
4551 /* this SV's refcnt has been artificially decremented to
4552 * trigger cleanup */
4554 if (PL_in_clean_all) /* All is fair */
4556 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4557 /* make sure SvREFCNT(sv)==0 happens very seldom */
4558 SvREFCNT(sv) = (~(U32)0)/2;
4561 if (ckWARN_d(WARN_INTERNAL)) {
4562 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
4563 "Attempt to free unreferenced scalar: SV 0x%"UVxf
4564 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
4565 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
4566 Perl_dump_sv_child(aTHX_ sv);
4571 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4572 if (!refcount_is_zero)
4576 if (ckWARN_d(WARN_DEBUGGING))
4577 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
4578 "Attempt to free temp prematurely: SV 0x%"UVxf
4579 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
4583 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4584 /* make sure SvREFCNT(sv)==0 happens very seldom */
4585 SvREFCNT(sv) = (~(U32)0)/2;
4596 Returns the length of the string in the SV. Handles magic and type
4597 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
4603 Perl_sv_len(pTHX_ register SV *sv)
4611 len = mg_length(sv);
4613 (void)SvPV_const(sv, len);
4618 =for apidoc sv_len_utf8
4620 Returns the number of characters in the string in an SV, counting wide
4621 UTF-8 bytes as a single character. Handles magic and type coercion.
4627 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
4628 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
4629 * (Note that the mg_len is not the length of the mg_ptr field.
4630 * This allows the cache to store the character length of the string without
4631 * needing to malloc() extra storage to attach to the mg_ptr.)
4636 Perl_sv_len_utf8(pTHX_ register SV *sv)
4642 return mg_length(sv);
4646 const U8 *s = (U8*)SvPV_const(sv, len);
4650 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
4652 if (mg && mg->mg_len != -1) {
4654 if (PL_utf8cache < 0) {
4655 const STRLEN real = Perl_utf8_length(aTHX_ (U8 *)s,
4658 /* Need to turn the assertions off otherwise we may
4659 recurse infinitely while printing error messages.
4661 SAVEI8(PL_utf8cache);
4663 Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVf
4664 " real %"UVf" for %"SVf,
4665 (UV) ulen, (UV) real, sv);
4670 ulen = Perl_utf8_length(aTHX_ (U8 *)s, (U8 *)s + len);
4671 if (!SvREADONLY(sv)) {
4673 mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
4674 &PL_vtbl_utf8, 0, 0);
4682 return Perl_utf8_length(aTHX_ (U8 *)s, (U8 *)s + len);
4686 /* Walk forwards to find the byte corresponding to the passed in UTF-8
4689 S_sv_pos_u2b_forwards(pTHX_ const U8 *const start, const U8 *const send,
4692 const U8 *s = start;
4694 while (s < send && uoffset--)
4697 /* This is the existing behaviour. Possibly it should be a croak, as
4698 it's actually a bounds error */
4704 /* Given the length of the string in both bytes and UTF-8 characters, decide
4705 whether to walk forwards or backwards to find the byte corresponding to
4706 the passed in UTF-8 offset. */
4708 S_sv_pos_u2b_midway(pTHX_ const U8 *const start, const U8 *send,
4709 STRLEN uoffset, STRLEN uend)
4711 STRLEN backw = uend - uoffset;
4712 if (uoffset < 2 * backw) {
4713 /* The assumption is that going forwards is twice the speed of going
4714 forward (that's where the 2 * backw comes from).
4715 (The real figure of course depends on the UTF-8 data.) */
4716 return S_sv_pos_u2b_forwards(aTHX_ start, send, uoffset);
4721 while (UTF8_IS_CONTINUATION(*send))
4724 return send - start;
4727 /* For the string representation of the given scalar, find the byte
4728 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
4729 give another position in the string, *before* the sought offset, which
4730 (which is always true, as 0, 0 is a valid pair of positions), which should
4731 help reduce the amount of linear searching.
4732 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
4733 will be used to reduce the amount of linear searching. The cache will be
4734 created if necessary, and the found value offered to it for update. */
4736 S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start,
4737 const U8 *const send, STRLEN uoffset,
4738 STRLEN uoffset0, STRLEN boffset0) {
4739 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
4742 assert (uoffset >= uoffset0);
4744 if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
4745 && (*mgp || (*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
4746 if ((*mgp)->mg_ptr) {
4747 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
4748 if (cache[0] == uoffset) {
4749 /* An exact match. */
4752 if (cache[2] == uoffset) {
4753 /* An exact match. */
4757 if (cache[0] < uoffset) {
4758 /* The cache already knows part of the way. */
4759 if (cache[0] > uoffset0) {
4760 /* The cache knows more than the passed in pair */
4761 uoffset0 = cache[0];
4762 boffset0 = cache[1];
4764 if ((*mgp)->mg_len != -1) {
4765 /* And we know the end too. */
4767 + S_sv_pos_u2b_midway(aTHX_ start + boffset0, send,
4769 (*mgp)->mg_len - uoffset0);
4772 + S_sv_pos_u2b_forwards(aTHX_ start + boffset0,
4773 send, uoffset - uoffset0);
4776 else if (cache[2] < uoffset) {
4777 /* We're between the two cache entries. */
4778 if (cache[2] > uoffset0) {
4779 /* and the cache knows more than the passed in pair */
4780 uoffset0 = cache[2];
4781 boffset0 = cache[3];
4785 + S_sv_pos_u2b_midway(aTHX_ start + boffset0,
4788 cache[0] - uoffset0);
4791 + S_sv_pos_u2b_midway(aTHX_ start + boffset0,
4794 cache[2] - uoffset0);
4798 else if ((*mgp)->mg_len != -1) {
4799 /* If we can take advantage of a passed in offset, do so. */
4800 /* In fact, offset0 is either 0, or less than offset, so don't
4801 need to worry about the other possibility. */
4803 + S_sv_pos_u2b_midway(aTHX_ start + boffset0, send,
4805 (*mgp)->mg_len - uoffset0);
4810 if (!found || PL_utf8cache < 0) {
4811 const STRLEN real_boffset
4812 = boffset0 + S_sv_pos_u2b_forwards(aTHX_ start + boffset0,
4813 send, uoffset - uoffset0);
4815 if (found && PL_utf8cache < 0) {
4816 if (real_boffset != boffset) {
4817 /* Need to turn the assertions off otherwise we may recurse
4818 infinitely while printing error messages. */
4819 SAVEI8(PL_utf8cache);
4821 Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVf
4822 " real %"UVf" for %"SVf,
4823 (UV) boffset, (UV) real_boffset, sv);
4826 boffset = real_boffset;
4829 S_utf8_mg_pos_cache_update(aTHX_ sv, mgp, boffset, uoffset, send - start);
4835 =for apidoc sv_pos_u2b
4837 Converts the value pointed to by offsetp from a count of UTF-8 chars from
4838 the start of the string, to a count of the equivalent number of bytes; if
4839 lenp is non-zero, it does the same to lenp, but this time starting from
4840 the offset, rather than from the start of the string. Handles magic and
4847 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
4848 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
4849 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
4854 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4862 start = (U8*)SvPV_const(sv, len);
4864 STRLEN uoffset = (STRLEN) *offsetp;
4865 const U8 * const send = start + len;
4867 STRLEN boffset = S_sv_pos_u2b_cached(aTHX_ sv, &mg, start, send,
4870 *offsetp = (I32) boffset;
4873 /* Convert the relative offset to absolute. */
4874 STRLEN uoffset2 = uoffset + (STRLEN) *lenp;
4876 = S_sv_pos_u2b_cached(aTHX_ sv, &mg, start, send, uoffset2,
4877 uoffset, boffset) - boffset;
4890 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
4891 byte length pairing. The (byte) length of the total SV is passed in too,
4892 as blen, because for some (more esoteric) SVs, the call to SvPV_const()
4893 may not have updated SvCUR, so we can't rely on reading it directly.
4895 The proffered utf8/byte length pairing isn't used if the cache already has
4896 two pairs, and swapping either for the proffered pair would increase the
4897 RMS of the intervals between known byte offsets.
4899 The cache itself consists of 4 STRLEN values
4900 0: larger UTF-8 offset
4901 1: corresponding byte offset
4902 2: smaller UTF-8 offset
4903 3: corresponding byte offset
4905 Unused cache pairs have the value 0, 0.
4906 Keeping the cache "backwards" means that the invariant of
4907 cache[0] >= cache[2] is maintained even with empty slots, which means that
4908 the code that uses it doesn't need to worry if only 1 entry has actually
4909 been set to non-zero. It also makes the "position beyond the end of the
4910 cache" logic much simpler, as the first slot is always the one to start
4914 S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8,
4922 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
4924 (*mgp)->mg_len = -1;
4928 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
4929 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
4930 (*mgp)->mg_ptr = (char *) cache;
4934 if (PL_utf8cache < 0) {
4935 const U8 *start = (const U8 *) SvPVX_const(sv);
4936 const U8 *const end = start + byte;
4937 STRLEN realutf8 = 0;
4939 while (start < end) {
4940 start += UTF8SKIP(start);
4944 /* Can't use S_sv_pos_b2u_forwards as it will scream warnings on
4945 surrogates. FIXME - is it inconsistent that b2u warns, but u2b
4946 doesn't? I don't know whether this difference was introduced with
4947 the caching code in 5.8.1. */
4949 if (realutf8 != utf8) {
4950 /* Need to turn the assertions off otherwise we may recurse
4951 infinitely while printing error messages. */
4952 SAVEI8(PL_utf8cache);
4954 Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVf
4955 " real %"UVf" for %"SVf, (UV) utf8, (UV) realutf8, sv);
4959 /* Cache is held with the later position first, to simplify the code
4960 that deals with unbounded ends. */
4962 ASSERT_UTF8_CACHE(cache);
4963 if (cache[1] == 0) {
4964 /* Cache is totally empty */
4967 } else if (cache[3] == 0) {
4968 if (byte > cache[1]) {
4969 /* New one is larger, so goes first. */
4970 cache[2] = cache[0];
4971 cache[3] = cache[1];
4979 #define THREEWAY_SQUARE(a,b,c,d) \
4980 ((float)((d) - (c))) * ((float)((d) - (c))) \
4981 + ((float)((c) - (b))) * ((float)((c) - (b))) \
4982 + ((float)((b) - (a))) * ((float)((b) - (a)))
4984 /* Cache has 2 slots in use, and we know three potential pairs.
4985 Keep the two that give the lowest RMS distance. Do the
4986 calcualation in bytes simply because we always know the byte
4987 length. squareroot has the same ordering as the positive value,
4988 so don't bother with the actual square root. */
4989 const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
4990 if (byte > cache[1]) {
4991 /* New position is after the existing pair of pairs. */
4992 const float keep_earlier
4993 = THREEWAY_SQUARE(0, cache[3], byte, blen);
4994 const float keep_later
4995 = THREEWAY_SQUARE(0, cache[1], byte, blen);
4997 if (keep_later < keep_earlier) {
4998 if (keep_later < existing) {
4999 cache[2] = cache[0];
5000 cache[3] = cache[1];
5006 if (keep_earlier < existing) {
5012 else if (byte > cache[3]) {
5013 /* New position is between the existing pair of pairs. */
5014 const float keep_earlier
5015 = THREEWAY_SQUARE(0, cache[3], byte, blen);
5016 const float keep_later
5017 = THREEWAY_SQUARE(0, byte, cache[1], blen);
5019 if (keep_later < keep_earlier) {
5020 if (keep_later < existing) {
5026 if (keep_earlier < existing) {
5033 /* New position is before the existing pair of pairs. */
5034 const float keep_earlier
5035 = THREEWAY_SQUARE(0, byte, cache[3], blen);
5036 const float keep_later
5037 = THREEWAY_SQUARE(0, byte, cache[1], blen);
5039 if (keep_later < keep_earlier) {
5040 if (keep_later < existing) {
5046 if (keep_earlier < existing) {
5047 cache[0] = cache[2];
5048 cache[1] = cache[3];
5055 ASSERT_UTF8_CACHE(cache);
5058 /* If we don't know the character offset of the end of a region, our only
5059 option is to walk forwards to the target byte offset. */
5061 S_sv_pos_b2u_forwards(pTHX_ const U8 *s, const U8 *const target)
5064 while (s < target) {
5067 /* Call utf8n_to_uvchr() to validate the sequence
5068 * (unless a simple non-UTF character) */
5069 if (!UTF8_IS_INVARIANT(*s))
5070 utf8n_to_uvchr((U8 *)s, UTF8SKIP(s), &n, 0);
5081 /* We already know all of the way, now we may be able to walk back. The same
5082 assumption is made as in S_sv_pos_u2b_midway(), namely that walking
5083 backward is half the speed of walking forward. */
5085 S_sv_pos_b2u_midway(pTHX_ const U8 *s, const U8 *const target, const U8 *end,
5088 const STRLEN forw = target - s;
5089 STRLEN backw = end - target;
5091 if (forw < 2 * backw) {
5092 return S_sv_pos_b2u_forwards(aTHX_ s, target);
5095 while (end > target) {
5097 while (UTF8_IS_CONTINUATION(*end)) {
5106 =for apidoc sv_pos_b2u
5108 Converts the value pointed to by offsetp from a count of bytes from the
5109 start of the string, to a count of the equivalent number of UTF-8 chars.
5110 Handles magic and type coercion.
5116 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
5117 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5122 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
5125 const STRLEN byte = *offsetp;
5126 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
5135 s = (const U8*)SvPV_const(sv, blen);
5138 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5142 if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
5143 && (mg = mg_find(sv, PERL_MAGIC_utf8))) {
5145 STRLEN *cache = (STRLEN *) mg->mg_ptr;
5146 if (cache[1] == byte) {
5147 /* An exact match. */
5148 *offsetp = cache[0];
5151 if (cache[3] == byte) {
5152 /* An exact match. */
5153 *offsetp = cache[2];
5157 if (cache[1] < byte) {
5158 /* We already know part of the way. */
5159 if (mg->mg_len != -1) {
5160 /* Actually, we know the end too. */
5162 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
5163 s + blen, mg->mg_len - cache[0]);
5166 + S_sv_pos_b2u_forwards(aTHX_ s + cache[1], send);
5169 else if (cache[3] < byte) {
5170 /* We're between the two cached pairs, so we do the calculation
5171 offset by the byte/utf-8 positions for the earlier pair,
5172 then add the utf-8 characters from the string start to
5174 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
5175 s + cache[1], cache[0] - cache[2])
5179 else { /* cache[3] > byte */
5180 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
5184 ASSERT_UTF8_CACHE(cache);
5186 } else if (mg->mg_len != -1) {
5187 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
5191 if (!found || PL_utf8cache < 0) {
5192 const STRLEN real_len = S_sv_pos_b2u_forwards(aTHX_ s, send);
5194 if (found && PL_utf8cache < 0) {
5195 if (len != real_len) {
5196 /* Need to turn the assertions off otherwise we may recurse
5197 infinitely while printing error messages. */
5198 SAVEI8(PL_utf8cache);
5200 Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVf
5201 " real %"UVf" for %"SVf,
5202 (UV) len, (UV) real_len, sv);
5209 S_utf8_mg_pos_cache_update(aTHX_ sv, &mg, byte, len, blen);
5215 Returns a boolean indicating whether the strings in the two SVs are
5216 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5217 coerce its args to strings if necessary.
5223 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5231 SV* svrecode = NULL;
5238 pv1 = SvPV_const(sv1, cur1);
5245 pv2 = SvPV_const(sv2, cur2);
5247 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5248 /* Differing utf8ness.
5249 * Do not UTF8size the comparands as a side-effect. */
5252 svrecode = newSVpvn(pv2, cur2);
5253 sv_recode_to_utf8(svrecode, PL_encoding);
5254 pv2 = SvPV_const(svrecode, cur2);
5257 svrecode = newSVpvn(pv1, cur1);
5258 sv_recode_to_utf8(svrecode, PL_encoding);
5259 pv1 = SvPV_const(svrecode, cur1);
5261 /* Now both are in UTF-8. */
5263 SvREFCNT_dec(svrecode);
5268 bool is_utf8 = TRUE;
5271 /* sv1 is the UTF-8 one,
5272 * if is equal it must be downgrade-able */
5273 char * const pv = (char*)bytes_from_utf8((U8*)pv1,
5279 /* sv2 is the UTF-8 one,
5280 * if is equal it must be downgrade-able */
5281 char * const pv = (char *)bytes_from_utf8((U8*)pv2,
5287 /* Downgrade not possible - cannot be eq */
5295 eq = memEQ(pv1, pv2, cur1);
5297 SvREFCNT_dec(svrecode);
5307 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
5308 string in C<sv1> is less than, equal to, or greater than the string in
5309 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5310 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
5316 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5319 const char *pv1, *pv2;
5322 SV *svrecode = NULL;
5329 pv1 = SvPV_const(sv1, cur1);
5336 pv2 = SvPV_const(sv2, cur2);
5338 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5339 /* Differing utf8ness.
5340 * Do not UTF8size the comparands as a side-effect. */
5343 svrecode = newSVpvn(pv2, cur2);
5344 sv_recode_to_utf8(svrecode, PL_encoding);
5345 pv2 = SvPV_const(svrecode, cur2);
5348 pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2);
5353 svrecode = newSVpvn(pv1, cur1);
5354 sv_recode_to_utf8(svrecode, PL_encoding);
5355 pv1 = SvPV_const(svrecode, cur1);
5358 pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1);
5364 cmp = cur2 ? -1 : 0;
5368 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
5371 cmp = retval < 0 ? -1 : 1;
5372 } else if (cur1 == cur2) {
5375 cmp = cur1 < cur2 ? -1 : 1;
5379 SvREFCNT_dec(svrecode);
5387 =for apidoc sv_cmp_locale
5389 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5390 'use bytes' aware, handles get magic, and will coerce its args to strings
5391 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
5397 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5399 #ifdef USE_LOCALE_COLLATE
5405 if (PL_collation_standard)
5409 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5411 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5413 if (!pv1 || !len1) {
5424 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5427 return retval < 0 ? -1 : 1;
5430 * When the result of collation is equality, that doesn't mean
5431 * that there are no differences -- some locales exclude some
5432 * characters from consideration. So to avoid false equalities,
5433 * we use the raw string as a tiebreaker.
5439 #endif /* USE_LOCALE_COLLATE */
5441 return sv_cmp(sv1, sv2);
5445 #ifdef USE_LOCALE_COLLATE
5448 =for apidoc sv_collxfrm
5450 Add Collate Transform magic to an SV if it doesn't already have it.
5452 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5453 scalar data of the variable, but transformed to such a format that a normal
5454 memory comparison can be used to compare the data according to the locale
5461 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5465 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5466 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5472 Safefree(mg->mg_ptr);
5473 s = SvPV_const(sv, len);
5474 if ((xf = mem_collxfrm(s, len, &xlen))) {
5475 if (SvREADONLY(sv)) {
5478 return xf + sizeof(PL_collation_ix);
5481 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5482 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5495 if (mg && mg->mg_ptr) {
5497 return mg->mg_ptr + sizeof(PL_collation_ix);
5505 #endif /* USE_LOCALE_COLLATE */
5510 Get a line from the filehandle and store it into the SV, optionally
5511 appending to the currently-stored string.
5517 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5521 register STDCHAR rslast;
5522 register STDCHAR *bp;
5528 if (SvTHINKFIRST(sv))
5529 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
5530 /* XXX. If you make this PVIV, then copy on write can copy scalars read
5532 However, perlbench says it's slower, because the existing swipe code
5533 is faster than copy on write.
5534 Swings and roundabouts. */
5535 (void)SvUPGRADE(sv, SVt_PV);
5540 if (PerlIO_isutf8(fp)) {
5542 sv_utf8_upgrade_nomg(sv);
5543 sv_pos_u2b(sv,&append,0);
5545 } else if (SvUTF8(sv)) {
5546 SV * const tsv = NEWSV(0,0);
5547 sv_gets(tsv, fp, 0);
5548 sv_utf8_upgrade_nomg(tsv);
5549 SvCUR_set(sv,append);
5552 goto return_string_or_null;
5557 if (PerlIO_isutf8(fp))
5560 if (IN_PERL_COMPILETIME) {
5561 /* we always read code in line mode */
5565 else if (RsSNARF(PL_rs)) {
5566 /* If it is a regular disk file use size from stat() as estimate
5567 of amount we are going to read - may result in malloc-ing
5568 more memory than we realy need if layers bellow reduce
5569 size we read (e.g. CRLF or a gzip layer)
5572 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
5573 const Off_t offset = PerlIO_tell(fp);
5574 if (offset != (Off_t) -1 && st.st_size + append > offset) {
5575 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
5581 else if (RsRECORD(PL_rs)) {
5585 /* Grab the size of the record we're getting */
5586 recsize = SvIV(SvRV(PL_rs));
5587 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
5590 /* VMS wants read instead of fread, because fread doesn't respect */
5591 /* RMS record boundaries. This is not necessarily a good thing to be */
5592 /* doing, but we've got no other real choice - except avoid stdio
5593 as implementation - perhaps write a :vms layer ?
5595 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5597 bytesread = PerlIO_read(fp, buffer, recsize);
5601 SvCUR_set(sv, bytesread += append);
5602 buffer[bytesread] = '\0';
5603 goto return_string_or_null;
5605 else if (RsPARA(PL_rs)) {
5611 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5612 if (PerlIO_isutf8(fp)) {
5613 rsptr = SvPVutf8(PL_rs, rslen);
5616 if (SvUTF8(PL_rs)) {
5617 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5618 Perl_croak(aTHX_ "Wide character in $/");
5621 rsptr = SvPV_const(PL_rs, rslen);
5625 rslast = rslen ? rsptr[rslen - 1] : '\0';
5627 if (rspara) { /* have to do this both before and after */
5628 do { /* to make sure file boundaries work right */
5631 i = PerlIO_getc(fp);
5635 PerlIO_ungetc(fp,i);
5641 /* See if we know enough about I/O mechanism to cheat it ! */
5643 /* This used to be #ifdef test - it is made run-time test for ease
5644 of abstracting out stdio interface. One call should be cheap
5645 enough here - and may even be a macro allowing compile
5649 if (PerlIO_fast_gets(fp)) {
5652 * We're going to steal some values from the stdio struct
5653 * and put EVERYTHING in the innermost loop into registers.
5655 register STDCHAR *ptr;
5659 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5660 /* An ungetc()d char is handled separately from the regular
5661 * buffer, so we getc() it back out and stuff it in the buffer.
5663 i = PerlIO_getc(fp);
5664 if (i == EOF) return 0;
5665 *(--((*fp)->_ptr)) = (unsigned char) i;
5669 /* Here is some breathtakingly efficient cheating */
5671 cnt = PerlIO_get_cnt(fp); /* get count into register */
5672 /* make sure we have the room */
5673 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
5674 /* Not room for all of it
5675 if we are looking for a separator and room for some
5677 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
5678 /* just process what we have room for */
5679 shortbuffered = cnt - SvLEN(sv) + append + 1;
5680 cnt -= shortbuffered;
5684 /* remember that cnt can be negative */
5685 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
5690 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
5691 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5692 DEBUG_P(PerlIO_printf(Perl_debug_log,
5693 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5694 DEBUG_P(PerlIO_printf(Perl_debug_log,
5695 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5696 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5697 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5702 while (cnt > 0) { /* this | eat */
5704 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5705 goto thats_all_folks; /* screams | sed :-) */
5709 Copy(ptr, bp, cnt, char); /* this | eat */
5710 bp += cnt; /* screams | dust */
5711 ptr += cnt; /* louder | sed :-) */
5716 if (shortbuffered) { /* oh well, must extend */
5717 cnt = shortbuffered;
5719 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
5721 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5722 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
5726 DEBUG_P(PerlIO_printf(Perl_debug_log,
5727 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5728 PTR2UV(ptr),(long)cnt));
5729 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
5731 DEBUG_P(PerlIO_printf(Perl_debug_log,
5732 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5733 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5734 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5736 /* This used to call 'filbuf' in stdio form, but as that behaves like
5737 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5738 another abstraction. */
5739 i = PerlIO_getc(fp); /* get more characters */
5741 DEBUG_P(PerlIO_printf(Perl_debug_log,
5742 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5743 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5744 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5746 cnt = PerlIO_get_cnt(fp);
5747 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5748 DEBUG_P(PerlIO_printf(Perl_debug_log,
5749 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5751 if (i == EOF) /* all done for ever? */
5752 goto thats_really_all_folks;
5754 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
5756 SvGROW(sv, bpx + cnt + 2);
5757 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
5759 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
5761 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5762 goto thats_all_folks;
5766 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
5767 memNE((char*)bp - rslen, rsptr, rslen))
5768 goto screamer; /* go back to the fray */
5769 thats_really_all_folks:
5771 cnt += shortbuffered;
5772 DEBUG_P(PerlIO_printf(Perl_debug_log,
5773 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5774 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
5775 DEBUG_P(PerlIO_printf(Perl_debug_log,
5776 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5777 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5778 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5780 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
5781 DEBUG_P(PerlIO_printf(Perl_debug_log,
5782 "Screamer: done, len=%ld, string=|%.*s|\n",
5783 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
5787 /*The big, slow, and stupid way. */
5788 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
5790 Newx(buf, 8192, STDCHAR);
5798 register const STDCHAR *bpe = buf + sizeof(buf);
5800 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
5801 ; /* keep reading */
5805 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5806 /* Accomodate broken VAXC compiler, which applies U8 cast to
5807 * both args of ?: operator, causing EOF to change into 255
5810 i = (U8)buf[cnt - 1];
5816 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
5818 sv_catpvn(sv, (char *) buf, cnt);
5820 sv_setpvn(sv, (char *) buf, cnt);
5822 if (i != EOF && /* joy */
5824 SvCUR(sv) < rslen ||
5825 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5829 * If we're reading from a TTY and we get a short read,
5830 * indicating that the user hit his EOF character, we need
5831 * to notice it now, because if we try to read from the TTY
5832 * again, the EOF condition will disappear.
5834 * The comparison of cnt to sizeof(buf) is an optimization
5835 * that prevents unnecessary calls to feof().
5839 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5843 #ifdef USE_HEAP_INSTEAD_OF_STACK
5848 if (rspara) { /* have to do this both before and after */
5849 while (i != EOF) { /* to make sure file boundaries work right */
5850 i = PerlIO_getc(fp);
5852 PerlIO_ungetc(fp,i);
5858 return_string_or_null:
5859 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
5865 Auto-increment of the value in the SV, doing string to numeric conversion
5866 if necessary. Handles 'get' magic.
5872 Perl_sv_inc(pTHX_ register SV *sv)
5880 if (SvTHINKFIRST(sv)) {
5881 if (SvREADONLY(sv) && SvFAKE(sv))
5882 sv_force_normal(sv);
5883 if (SvREADONLY(sv)) {
5884 if (IN_PERL_RUNTIME)
5885 Perl_croak(aTHX_ PL_no_modify);
5889 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5891 i = PTR2IV(SvRV(sv));
5896 flags = SvFLAGS(sv);
5897 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5898 /* It's (privately or publicly) a float, but not tested as an
5899 integer, so test it to see. */
5901 flags = SvFLAGS(sv);
5903 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5904 /* It's publicly an integer, or privately an integer-not-float */
5905 #ifdef PERL_PRESERVE_IVUV
5909 if (SvUVX(sv) == UV_MAX)
5910 sv_setnv(sv, UV_MAX_P1);
5912 (void)SvIOK_only_UV(sv);
5913 SvUV_set(sv, SvUVX(sv) + 1);
5915 if (SvIVX(sv) == IV_MAX)
5916 sv_setuv(sv, (UV)IV_MAX + 1);
5918 (void)SvIOK_only(sv);
5919 SvIV_set(sv, SvIVX(sv) + 1);
5924 if (flags & SVp_NOK) {
5925 (void)SvNOK_only(sv);
5926 SvNV_set(sv, SvNVX(sv) + 1.0);
5930 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
5931 if ((flags & SVTYPEMASK) < SVt_PVIV)
5932 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
5933 (void)SvIOK_only(sv);
5938 while (isALPHA(*d)) d++;
5939 while (isDIGIT(*d)) d++;
5941 #ifdef PERL_PRESERVE_IVUV
5942 /* Got to punt this as an integer if needs be, but we don't issue
5943 warnings. Probably ought to make the sv_iv_please() that does
5944 the conversion if possible, and silently. */
5945 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
5946 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5947 /* Need to try really hard to see if it's an integer.
5948 9.22337203685478e+18 is an integer.
5949 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5950 so $a="9.22337203685478e+18"; $a+0; $a++
5951 needs to be the same as $a="9.22337203685478e+18"; $a++
5958 /* sv_2iv *should* have made this an NV */
5959 if (flags & SVp_NOK) {
5960 (void)SvNOK_only(sv);
5961 SvNV_set(sv, SvNVX(sv) + 1.0);
5964 /* I don't think we can get here. Maybe I should assert this
5965 And if we do get here I suspect that sv_setnv will croak. NWC
5967 #if defined(USE_LONG_DOUBLE)
5968 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",
5969 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
5971 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
5972 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
5975 #endif /* PERL_PRESERVE_IVUV */
5976 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
5980 while (d >= SvPVX_const(sv)) {
5988 /* MKS: The original code here died if letters weren't consecutive.
5989 * at least it didn't have to worry about non-C locales. The
5990 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5991 * arranged in order (although not consecutively) and that only
5992 * [A-Za-z] are accepted by isALPHA in the C locale.
5994 if (*d != 'z' && *d != 'Z') {
5995 do { ++*d; } while (!isALPHA(*d));
5998 *(d--) -= 'z' - 'a';
6003 *(d--) -= 'z' - 'a' + 1;
6007 /* oh,oh, the number grew */
6008 SvGROW(sv, SvCUR(sv) + 2);
6009 SvCUR_set(sv, SvCUR(sv) + 1);
6010 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
6021 Auto-decrement of the value in the SV, doing string to numeric conversion
6022 if necessary. Handles 'get' magic.
6028 Perl_sv_dec(pTHX_ register SV *sv)
6035 if (SvTHINKFIRST(sv)) {
6036 if (SvREADONLY(sv) && SvFAKE(sv))
6037 sv_force_normal(sv);
6038 if (SvREADONLY(sv)) {
6039 if (IN_PERL_RUNTIME)
6040 Perl_croak(aTHX_ PL_no_modify);
6044 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6046 i = PTR2IV(SvRV(sv));
6051 /* Unlike sv_inc we don't have to worry about string-never-numbers
6052 and keeping them magic. But we mustn't warn on punting */
6053 flags = SvFLAGS(sv);
6054 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6055 /* It's publicly an integer, or privately an integer-not-float */
6056 #ifdef PERL_PRESERVE_IVUV
6060 if (SvUVX(sv) == 0) {
6061 (void)SvIOK_only(sv);
6065 (void)SvIOK_only_UV(sv);
6066 SvUV_set(sv, SvUVX(sv) - 1);
6069 if (SvIVX(sv) == IV_MIN)
6070 sv_setnv(sv, (NV)IV_MIN - 1.0);
6072 (void)SvIOK_only(sv);
6073 SvIV_set(sv, SvIVX(sv) - 1);
6078 if (flags & SVp_NOK) {
6079 SvNV_set(sv, SvNVX(sv) - 1.0);
6080 (void)SvNOK_only(sv);
6083 if (!(flags & SVp_POK)) {
6084 if ((flags & SVTYPEMASK) < SVt_PVIV)
6085 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
6087 (void)SvIOK_only(sv);
6090 #ifdef PERL_PRESERVE_IVUV
6092 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6093 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6094 /* Need to try really hard to see if it's an integer.
6095 9.22337203685478e+18 is an integer.
6096 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6097 so $a="9.22337203685478e+18"; $a+0; $a--
6098 needs to be the same as $a="9.22337203685478e+18"; $a--
6105 /* sv_2iv *should* have made this an NV */
6106 if (flags & SVp_NOK) {
6107 (void)SvNOK_only(sv);
6108 SvNV_set(sv, SvNVX(sv) - 1.0);
6111 /* I don't think we can get here. Maybe I should assert this
6112 And if we do get here I suspect that sv_setnv will croak. NWC
6114 #if defined(USE_LONG_DOUBLE)
6115 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",
6116 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6118 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6119 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6123 #endif /* PERL_PRESERVE_IVUV */
6124 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
6128 =for apidoc sv_mortalcopy
6130 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6131 The new SV is marked as mortal. It will be destroyed "soon", either by an
6132 explicit call to FREETMPS, or by an implicit call at places such as
6133 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
6138 /* Make a string that will exist for the duration of the expression
6139 * evaluation. Actually, it may have to last longer than that, but
6140 * hopefully we won't free it until it has been assigned to a
6141 * permanent location. */
6144 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6149 sv_setsv(sv,oldstr);
6151 PL_tmps_stack[++PL_tmps_ix] = sv;
6157 =for apidoc sv_newmortal
6159 Creates a new null SV which is mortal. The reference count of the SV is
6160 set to 1. It will be destroyed "soon", either by an explicit call to
6161 FREETMPS, or by an implicit call at places such as statement boundaries.
6162 See also C<sv_mortalcopy> and C<sv_2mortal>.
6168 Perl_sv_newmortal(pTHX)
6173 SvFLAGS(sv) = SVs_TEMP;
6175 PL_tmps_stack[++PL_tmps_ix] = sv;
6180 =for apidoc sv_2mortal
6182 Marks an existing SV as mortal. The SV will be destroyed "soon", either
6183 by an explicit call to FREETMPS, or by an implicit call at places such as
6184 statement boundaries. SvTEMP() is turned on which means that the SV's
6185 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
6186 and C<sv_mortalcopy>.
6192 Perl_sv_2mortal(pTHX_ register SV *sv)
6196 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6199 PL_tmps_stack[++PL_tmps_ix] = sv;
6207 Creates a new SV and copies a string into it. The reference count for the
6208 SV is set to 1. If C<len> is zero, Perl will compute the length using
6209 strlen(). For efficiency, consider using C<newSVpvn> instead.
6215 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6220 sv_setpvn(sv,s,len ? len : strlen(s));
6225 =for apidoc newSVpvn
6227 Creates a new SV and copies a string into it. The reference count for the
6228 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
6229 string. You are responsible for ensuring that the source string is at least
6230 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
6236 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6241 sv_setpvn(sv,s,len);
6247 =for apidoc newSVhek
6249 Creates a new SV from the hash key structure. It will generate scalars that
6250 point to the shared string table where possible. Returns a new (undefined)
6251 SV if the hek is NULL.
6257 Perl_newSVhek(pTHX_ const HEK *hek)
6266 if (HEK_LEN(hek) == HEf_SVKEY) {
6267 return newSVsv(*(SV**)HEK_KEY(hek));
6269 const int flags = HEK_FLAGS(hek);
6270 if (flags & HVhek_WASUTF8) {
6272 Andreas would like keys he put in as utf8 to come back as utf8
6274 STRLEN utf8_len = HEK_LEN(hek);
6275 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
6276 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
6279 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
6281 } else if (flags & HVhek_REHASH) {
6282 /* We don't have a pointer to the hv, so we have to replicate the
6283 flag into every HEK. This hv is using custom a hasing
6284 algorithm. Hence we can't return a shared string scalar, as
6285 that would contain the (wrong) hash value, and might get passed
6286 into an hv routine with a regular hash */
6288 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
6293 /* This will be overwhelminly the most common case. */
6294 return newSVpvn_share(HEK_KEY(hek),
6295 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
6301 =for apidoc newSVpvn_share
6303 Creates a new SV with its SvPVX_const pointing to a shared string in the string
6304 table. If the string does not already exist in the table, it is created
6305 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
6306 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6307 otherwise the hash is computed. The idea here is that as the string table
6308 is used for shared hash keys these strings will have SvPVX_const == HeKEY and
6309 hash lookup will avoid string compare.
6315 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6318 bool is_utf8 = FALSE;
6320 STRLEN tmplen = -len;
6322 /* See the note in hv.c:hv_fetch() --jhi */
6323 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
6327 PERL_HASH(hash, src, len);
6329 sv_upgrade(sv, SVt_PVIV);
6330 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
6343 #if defined(PERL_IMPLICIT_CONTEXT)
6345 /* pTHX_ magic can't cope with varargs, so this is a no-context
6346 * version of the main function, (which may itself be aliased to us).
6347 * Don't access this version directly.
6351 Perl_newSVpvf_nocontext(const char* pat, ...)
6356 va_start(args, pat);
6357 sv = vnewSVpvf(pat, &args);
6364 =for apidoc newSVpvf
6366 Creates a new SV and initializes it with the string formatted like
6373 Perl_newSVpvf(pTHX_ const char* pat, ...)
6377 va_start(args, pat);
6378 sv = vnewSVpvf(pat, &args);
6383 /* backend for newSVpvf() and newSVpvf_nocontext() */
6386 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6390 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
6397 Creates a new SV and copies a floating point value into it.
6398 The reference count for the SV is set to 1.
6404 Perl_newSVnv(pTHX_ NV n)
6416 Creates a new SV and copies an integer into it. The reference count for the
6423 Perl_newSViv(pTHX_ IV i)
6435 Creates a new SV and copies an unsigned integer into it.
6436 The reference count for the SV is set to 1.
6442 Perl_newSVuv(pTHX_ UV u)
6452 =for apidoc newRV_noinc
6454 Creates an RV wrapper for an SV. The reference count for the original
6455 SV is B<not> incremented.
6461 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6466 sv_upgrade(sv, SVt_RV);
6468 SvRV_set(sv, tmpRef);
6473 /* newRV_inc is the official function name to use now.
6474 * newRV_inc is in fact #defined to newRV in sv.h
6478 Perl_newRV(pTHX_ SV *tmpRef)
6480 return newRV_noinc(SvREFCNT_inc_simple(tmpRef));
6486 Creates a new SV which is an exact duplicate of the original SV.
6493 Perl_newSVsv(pTHX_ register SV *old)
6499 if (SvTYPE(old) == SVTYPEMASK) {
6500 if (ckWARN_d(WARN_INTERNAL))
6501 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
6505 /* SV_GMAGIC is the default for sv_setv()
6506 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
6507 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
6508 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
6513 =for apidoc sv_reset
6515 Underlying implementation for the C<reset> Perl function.
6516 Note that the perl-level function is vaguely deprecated.
6522 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6525 char todo[PERL_UCHAR_MAX+1];
6530 if (!*s) { /* reset ?? searches */
6531 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6532 pm->op_pmdynflags &= ~PMdf_USED;
6537 /* reset variables */
6539 if (!HvARRAY(stash))
6542 Zero(todo, 256, char);
6545 I32 i = (unsigned char)*s;
6549 max = (unsigned char)*s++;
6550 for ( ; i <= max; i++) {
6553 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6555 for (entry = HvARRAY(stash)[i];
6557 entry = HeNEXT(entry))
6562 if (!todo[(U8)*HeKEY(entry)])
6564 gv = (GV*)HeVAL(entry);
6567 if (SvTHINKFIRST(sv)) {
6568 if (!SvREADONLY(sv) && SvROK(sv))
6570 /* XXX Is this continue a bug? Why should THINKFIRST
6571 exempt us from resetting arrays and hashes? */
6575 if (SvTYPE(sv) >= SVt_PV) {
6577 if (SvPVX_const(sv) != NULL)
6585 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
6587 Perl_die(aTHX_ "Can't reset %%ENV on this system");
6590 # if defined(USE_ENVIRON_ARRAY)
6593 # endif /* USE_ENVIRON_ARRAY */
6604 Using various gambits, try to get an IO from an SV: the IO slot if its a
6605 GV; or the recursive result if we're an RV; or the IO slot of the symbol
6606 named after the PV if we're a string.
6612 Perl_sv_2io(pTHX_ SV *sv)
6618 switch (SvTYPE(sv)) {
6626 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6630 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6632 return sv_2io(SvRV(sv));
6633 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6639 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
6648 Using various gambits, try to get a CV from an SV; in addition, try if
6649 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
6655 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6662 return *gvp = NULL, NULL;
6663 switch (SvTYPE(sv)) {
6681 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6682 tryAMAGICunDEREF(to_cv);
6685 if (SvTYPE(sv) == SVt_PVCV) {
6694 Perl_croak(aTHX_ "Not a subroutine reference");
6699 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6705 if (lref && !GvCVu(gv)) {
6708 tmpsv = NEWSV(704,0);
6709 gv_efullname3(tmpsv, gv, NULL);
6710 /* XXX this is probably not what they think they're getting.
6711 * It has the same effect as "sub name;", i.e. just a forward
6713 newSUB(start_subparse(FALSE, 0),
6714 newSVOP(OP_CONST, 0, tmpsv),
6719 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
6729 Returns true if the SV has a true value by Perl's rules.
6730 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
6731 instead use an in-line version.
6737 Perl_sv_true(pTHX_ register SV *sv)
6742 register const XPV* const tXpv = (XPV*)SvANY(sv);
6744 (tXpv->xpv_cur > 1 ||
6745 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6752 return SvIVX(sv) != 0;
6755 return SvNVX(sv) != 0.0;
6757 return sv_2bool(sv);
6763 =for apidoc sv_pvn_force
6765 Get a sensible string out of the SV somehow.
6766 A private implementation of the C<SvPV_force> macro for compilers which
6767 can't cope with complex macro expressions. Always use the macro instead.
6769 =for apidoc sv_pvn_force_flags
6771 Get a sensible string out of the SV somehow.
6772 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6773 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6774 implemented in terms of this function.
6775 You normally want to use the various wrapper macros instead: see
6776 C<SvPV_force> and C<SvPV_force_nomg>
6782 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6785 if (SvTHINKFIRST(sv) && !SvROK(sv))
6786 sv_force_normal(sv);
6796 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
6797 const char * const ref = sv_reftype(sv,0);
6799 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
6800 ref, OP_NAME(PL_op));
6802 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
6804 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
6805 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6807 s = sv_2pv_flags(sv, &len, flags);
6811 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
6814 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6815 SvGROW(sv, len + 1);
6816 Move(s,SvPVX(sv),len,char);
6821 SvPOK_on(sv); /* validate pointer */
6823 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6824 PTR2UV(sv),SvPVX_const(sv)));
6827 return SvPVX_mutable(sv);
6831 =for apidoc sv_pvbyten_force
6833 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
6839 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6841 sv_pvn_force(sv,lp);
6842 sv_utf8_downgrade(sv,0);
6848 =for apidoc sv_pvutf8n_force
6850 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
6856 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6858 sv_pvn_force(sv,lp);
6859 sv_utf8_upgrade(sv);
6865 =for apidoc sv_reftype
6867 Returns a string describing what the SV is a reference to.
6873 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6875 /* The fact that I don't need to downcast to char * everywhere, only in ?:
6876 inside return suggests a const propagation bug in g++. */
6877 if (ob && SvOBJECT(sv)) {
6878 char * const name = HvNAME_get(SvSTASH(sv));
6879 return name ? name : (char *) "__ANON__";
6882 switch (SvTYPE(sv)) {
6897 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
6898 /* tied lvalues should appear to be
6899 * scalars for backwards compatitbility */
6900 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
6901 ? "SCALAR" : "LVALUE");
6902 case SVt_PVAV: return "ARRAY";
6903 case SVt_PVHV: return "HASH";
6904 case SVt_PVCV: return "CODE";
6905 case SVt_PVGV: return "GLOB";
6906 case SVt_PVFM: return "FORMAT";
6907 case SVt_PVIO: return "IO";
6908 default: return "UNKNOWN";
6914 =for apidoc sv_isobject
6916 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6917 object. If the SV is not an RV, or if the object is not blessed, then this
6924 Perl_sv_isobject(pTHX_ SV *sv)
6940 Returns a boolean indicating whether the SV is blessed into the specified
6941 class. This does not check for subtypes; use C<sv_derived_from> to verify
6942 an inheritance relationship.
6948 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6959 hvname = HvNAME_get(SvSTASH(sv));
6963 return strEQ(hvname, name);
6969 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6970 it will be upgraded to one. If C<classname> is non-null then the new SV will
6971 be blessed in the specified package. The new SV is returned and its
6972 reference count is 1.
6978 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6984 SV_CHECK_THINKFIRST(rv);
6987 if (SvTYPE(rv) >= SVt_PVMG) {
6988 const U32 refcnt = SvREFCNT(rv);
6992 SvREFCNT(rv) = refcnt;
6995 if (SvTYPE(rv) < SVt_RV)
6996 sv_upgrade(rv, SVt_RV);
6997 else if (SvTYPE(rv) > SVt_RV) {
7008 HV* const stash = gv_stashpv(classname, TRUE);
7009 (void)sv_bless(rv, stash);
7015 =for apidoc sv_setref_pv
7017 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7018 argument will be upgraded to an RV. That RV will be modified to point to
7019 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7020 into the SV. The C<classname> argument indicates the package for the
7021 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7022 will have a reference count of 1, and the RV will be returned.
7024 Do not use with other Perl types such as HV, AV, SV, CV, because those
7025 objects will become corrupted by the pointer copy process.
7027 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7033 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7036 sv_setsv(rv, &PL_sv_undef);
7040 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7045 =for apidoc sv_setref_iv
7047 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7048 argument will be upgraded to an RV. That RV will be modified to point to
7049 the new SV. The C<classname> argument indicates the package for the
7050 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7051 will have a reference count of 1, and the RV will be returned.
7057 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7059 sv_setiv(newSVrv(rv,classname), iv);
7064 =for apidoc sv_setref_uv
7066 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7067 argument will be upgraded to an RV. That RV will be modified to point to
7068 the new SV. The C<classname> argument indicates the package for the
7069 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7070 will have a reference count of 1, and the RV will be returned.
7076 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7078 sv_setuv(newSVrv(rv,classname), uv);
7083 =for apidoc sv_setref_nv
7085 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7086 argument will be upgraded to an RV. That RV will be modified to point to
7087 the new SV. The C<classname> argument indicates the package for the
7088 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7089 will have a reference count of 1, and the RV will be returned.
7095 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7097 sv_setnv(newSVrv(rv,classname), nv);
7102 =for apidoc sv_setref_pvn
7104 Copies a string into a new SV, optionally blessing the SV. The length of the
7105 string must be specified with C<n>. The C<rv> argument will be upgraded to
7106 an RV. That RV will be modified to point to the new SV. The C<classname>
7107 argument indicates the package for the blessing. Set C<classname> to
7108 C<NULL> to avoid the blessing. The new SV will have a reference count
7109 of 1, and the RV will be returned.
7111 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7117 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
7119 sv_setpvn(newSVrv(rv,classname), pv, n);
7123 /* This is a hack to cope with reblessing from class with overloading magic to
7124 one without (or the other way). Search for every reference pointing to the
7125 object. Can't use S_visit() because we would need to pass a parameter to
7128 S_reset_amagic(pTHX_ SV *rv, const bool on) {
7129 /* It is assumed that you've already turned magic on/off on rv */
7131 SV *const target = SvRV(rv);
7132 /* Less 1 for the reference we've already dealt with. */
7133 U32 how_many = SvREFCNT(target) - 1;
7136 if (SvMAGICAL(target) && (mg = mg_find(target, PERL_MAGIC_backref))) {
7137 /* Back referneces also need to be found, but aren't part of the
7138 target's reference count. */
7139 how_many += 1 + av_len((AV*)mg->mg_obj);
7143 /* There was only 1 reference to this object. */
7147 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
7148 register const SV * const svend = &sva[SvREFCNT(sva)];
7150 for (sv = sva + 1; sv < svend; ++sv) {
7151 if (SvTYPE(sv) != SVTYPEMASK
7152 && (sv->sv_flags & SVf_ROK) == SVf_ROK
7154 && SvRV(sv) == target
7160 if (--how_many == 0) {
7161 /* We have found them all. */
7170 =for apidoc sv_bless
7172 Blesses an SV into a specified package. The SV must be an RV. The package
7173 must be designated by its stash (see C<gv_stashpv()>). The reference count
7174 of the SV is unaffected.
7180 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7184 Perl_croak(aTHX_ "Can't bless non-reference value");
7186 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7187 if (SvREADONLY(tmpRef))
7188 Perl_croak(aTHX_ PL_no_modify);
7189 if (SvOBJECT(tmpRef)) {
7190 if (SvTYPE(tmpRef) != SVt_PVIO)
7192 SvREFCNT_dec(SvSTASH(tmpRef));
7195 SvOBJECT_on(tmpRef);
7196 if (SvTYPE(tmpRef) != SVt_PVIO)
7198 (void)SvUPGRADE(tmpRef, SVt_PVMG);
7199 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc_simple(stash));
7201 if (Gv_AMG(stash)) {
7202 if (!SvAMAGIC(sv)) {
7204 S_reset_amagic(aTHX_ sv, TRUE);
7209 S_reset_amagic(aTHX_ sv, FALSE);
7213 if(SvSMAGICAL(tmpRef))
7214 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
7222 /* Downgrades a PVGV to a PVMG.
7226 S_sv_unglob(pTHX_ SV *sv)
7230 assert(SvTYPE(sv) == SVt_PVGV);
7235 SvREFCNT_dec(GvSTASH(sv));
7238 sv_unmagic(sv, PERL_MAGIC_glob);
7239 Safefree(GvNAME(sv));
7242 /* need to keep SvANY(sv) in the right arena */
7243 xpvmg = new_XPVMG();
7244 StructCopy(SvANY(sv), xpvmg, XPVMG);
7245 del_XPVGV(SvANY(sv));
7248 SvFLAGS(sv) &= ~SVTYPEMASK;
7249 SvFLAGS(sv) |= SVt_PVMG;
7253 =for apidoc sv_unref_flags
7255 Unsets the RV status of the SV, and decrements the reference count of
7256 whatever was being referenced by the RV. This can almost be thought of
7257 as a reversal of C<newSVrv>. The C<cflags> argument can contain
7258 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7259 (otherwise the decrementing is conditional on the reference count being
7260 different from one or the reference being a readonly SV).
7267 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
7269 SV const * rv = SvRV(sv);
7271 if (SvWEAKREF(sv)) {
7279 /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
7280 assigned to as BEGIN {$a = \"Foo"} will fail. */
7281 if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
7283 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7284 sv_2mortal((SV *)rv); /* Schedule for freeing later */
7288 =for apidoc sv_untaint
7290 Untaint an SV. Use C<SvTAINTED_off> instead.
7295 Perl_sv_untaint(pTHX_ SV *sv)
7297 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7298 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
7305 =for apidoc sv_tainted
7307 Test an SV for taintedness. Use C<SvTAINTED> instead.
7312 Perl_sv_tainted(pTHX_ SV *sv)
7314 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7315 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
7316 if (mg && (mg->mg_len & 1) )
7323 =for apidoc sv_setpviv
7325 Copies an integer into the given SV, also updating its string value.
7326 Does not handle 'set' magic. See C<sv_setpviv_mg>.
7332 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
7334 char buf[TYPE_CHARS(UV)];
7336 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7338 sv_setpvn(sv, ptr, ebuf - ptr);
7342 =for apidoc sv_setpviv_mg
7344 Like C<sv_setpviv>, but also handles 'set' magic.
7350 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
7356 #if defined(PERL_IMPLICIT_CONTEXT)
7358 /* pTHX_ magic can't cope with varargs, so this is a no-context
7359 * version of the main function, (which may itself be aliased to us).
7360 * Don't access this version directly.
7364 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
7368 va_start(args, pat);
7369 sv_vsetpvf(sv, pat, &args);
7373 /* pTHX_ magic can't cope with varargs, so this is a no-context
7374 * version of the main function, (which may itself be aliased to us).
7375 * Don't access this version directly.
7379 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7383 va_start(args, pat);
7384 sv_vsetpvf_mg(sv, pat, &args);
7390 =for apidoc sv_setpvf
7392 Works like C<sv_catpvf> but copies the text into the SV instead of
7393 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
7399 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7402 va_start(args, pat);
7403 sv_vsetpvf(sv, pat, &args);
7408 =for apidoc sv_vsetpvf
7410 Works like C<sv_vcatpvf> but copies the text into the SV instead of
7411 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
7413 Usually used via its frontend C<sv_setpvf>.
7419 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7421 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7425 =for apidoc sv_setpvf_mg
7427 Like C<sv_setpvf>, but also handles 'set' magic.
7433 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7436 va_start(args, pat);
7437 sv_vsetpvf_mg(sv, pat, &args);
7442 =for apidoc sv_vsetpvf_mg
7444 Like C<sv_vsetpvf>, but also handles 'set' magic.
7446 Usually used via its frontend C<sv_setpvf_mg>.
7452 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7454 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7458 #if defined(PERL_IMPLICIT_CONTEXT)
7460 /* pTHX_ magic can't cope with varargs, so this is a no-context
7461 * version of the main function, (which may itself be aliased to us).
7462 * Don't access this version directly.
7466 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
7470 va_start(args, pat);
7471 sv_vcatpvf(sv, pat, &args);
7475 /* pTHX_ magic can't cope with varargs, so this is a no-context
7476 * version of the main function, (which may itself be aliased to us).
7477 * Don't access this version directly.
7481 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
7485 va_start(args, pat);
7486 sv_vcatpvf_mg(sv, pat, &args);
7492 =for apidoc sv_catpvf
7494 Processes its arguments like C<sprintf> and appends the formatted
7495 output to an SV. If the appended data contains "wide" characters
7496 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
7497 and characters >255 formatted with %c), the original SV might get
7498 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
7499 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
7500 valid UTF-8; if the original SV was bytes, the pattern should be too.
7505 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
7508 va_start(args, pat);
7509 sv_vcatpvf(sv, pat, &args);
7514 =for apidoc sv_vcatpvf
7516 Processes its arguments like C<vsprintf> and appends the formatted output
7517 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
7519 Usually used via its frontend C<sv_catpvf>.
7525 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7527 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7531 =for apidoc sv_catpvf_mg
7533 Like C<sv_catpvf>, but also handles 'set' magic.
7539 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7542 va_start(args, pat);
7543 sv_vcatpvf_mg(sv, pat, &args);
7548 =for apidoc sv_vcatpvf_mg
7550 Like C<sv_vcatpvf>, but also handles 'set' magic.
7552 Usually used via its frontend C<sv_catpvf_mg>.
7558 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7560 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7565 =for apidoc sv_vsetpvfn
7567 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
7570 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
7576 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7578 sv_setpvn(sv, "", 0);
7579 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
7582 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
7585 S_expect_number(pTHX_ char** pattern)
7588 switch (**pattern) {
7589 case '1': case '2': case '3':
7590 case '4': case '5': case '6':
7591 case '7': case '8': case '9':
7592 while (isDIGIT(**pattern))
7593 var = var * 10 + (*(*pattern)++ - '0');
7597 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
7600 F0convert(NV nv, char *endbuf, STRLEN *len)
7602 const int neg = nv < 0;
7611 if (uv & 1 && uv == nv)
7612 uv--; /* Round to even */
7614 const unsigned dig = uv % 10;
7627 =for apidoc sv_vcatpvfn
7629 Processes its arguments like C<vsprintf> and appends the formatted output
7630 to an SV. Uses an array of SVs if the C style variable argument list is
7631 missing (NULL). When running with taint checks enabled, indicates via
7632 C<maybe_tainted> if results are untrustworthy (often due to the use of
7635 XXX Except that it maybe_tainted is never assigned to.
7637 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
7642 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
7645 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7652 static const char nullstr[] = "(null)";
7654 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
7655 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
7657 /* Times 4: a decimal digit takes more than 3 binary digits.
7658 * NV_DIG: mantissa takes than many decimal digits.
7659 * Plus 32: Playing safe. */
7660 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7661 /* large enough for "%#.#f" --chip */
7662 /* what about long double NVs? --jhi */
7664 PERL_UNUSED_ARG(maybe_tainted);
7666 /* no matter what, this is a string now */
7667 (void)SvPV_force(sv, origlen);
7669 /* special-case "", "%s", and "%_" */
7672 if (patlen == 2 && pat[0] == '%') {
7676 const char * const s = va_arg(*args, char*);
7677 sv_catpv(sv, s ? s : nullstr);
7679 else if (svix < svmax) {
7680 sv_catsv(sv, *svargs);
7681 if (DO_UTF8(*svargs))
7687 argsv = va_arg(*args, SV*);
7688 sv_catsv(sv, argsv);
7693 /* See comment on '_' below */
7698 #ifndef USE_LONG_DOUBLE
7699 /* special-case "%.<number>[gf]" */
7700 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
7701 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
7702 unsigned digits = 0;
7706 while (*pp >= '0' && *pp <= '9')
7707 digits = 10 * digits + (*pp++ - '0');
7708 if (pp - pat == (int)patlen - 1) {
7716 /* Add check for digits != 0 because it seems that some
7717 gconverts are buggy in this case, and we don't yet have
7718 a Configure test for this. */
7719 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
7720 /* 0, point, slack */
7721 Gconvert(nv, (int)digits, 0, ebuf);
7723 if (*ebuf) /* May return an empty string for digits==0 */
7726 } else if (!digits) {
7729 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
7730 sv_catpvn(sv, p, l);
7736 #endif /* !USE_LONG_DOUBLE */
7738 if (!args && svix < svmax && DO_UTF8(*svargs))
7741 patend = (char*)pat + patlen;
7742 for (p = (char*)pat; p < patend; p = q) {
7745 bool vectorize = FALSE;
7746 bool vectorarg = FALSE;
7747 bool vec_utf8 = FALSE;
7753 bool has_precis = FALSE;
7756 bool is_utf8 = FALSE; /* is this item utf8? */
7757 #ifdef HAS_LDBL_SPRINTF_BUG
7758 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
7759 with sfio - Allen <allens@cpan.org> */
7760 bool fix_ldbl_sprintf_bug = FALSE;
7764 U8 utf8buf[UTF8_MAXBYTES+1];
7765 STRLEN esignlen = 0;
7767 const char *eptr = NULL;
7770 const U8 *vecstr = NULL;
7777 /* we need a long double target in case HAS_LONG_DOUBLE but
7780 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
7788 const char *dotstr = ".";
7789 STRLEN dotstrlen = 1;
7790 I32 efix = 0; /* explicit format parameter index */
7791 I32 ewix = 0; /* explicit width index */
7792 I32 epix = 0; /* explicit precision index */
7793 I32 evix = 0; /* explicit vector index */
7794 bool asterisk = FALSE;
7796 /* echo everything up to the next format specification */
7797 for (q = p; q < patend && *q != '%'; ++q) ;
7799 if (has_utf8 && !pat_utf8)
7800 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
7802 sv_catpvn(sv, p, q - p);
7809 We allow format specification elements in this order:
7810 \d+\$ explicit format parameter index
7812 v|\*(\d+\$)?v vector with optional (optionally specified) arg
7813 0 flag (as above): repeated to allow "v02"
7814 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7815 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7817 [%bcdefginopsux_DFOUX] format (mandatory)
7819 if (EXPECT_NUMBER(q, width)) {
7860 if (EXPECT_NUMBER(q, ewix))
7869 if ((vectorarg = asterisk)) {
7882 EXPECT_NUMBER(q, width);
7886 if ((*q == 'p') && left) {
7887 vectorize = (width == 1);
7893 vecsv = va_arg(*args, SV*);
7895 vecsv = (evix > 0 && evix <= svmax)
7896 ? svargs[evix-1] : &PL_sv_undef;
7898 vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
7900 dotstr = SvPV_const(vecsv, dotstrlen);
7901 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
7902 bad with tied or overloaded values that return UTF8. */
7905 else if (has_utf8) {
7906 vecsv = sv_mortalcopy(vecsv);
7907 sv_utf8_upgrade(vecsv);
7908 dotstr = SvPV_const(vecsv, dotstrlen);
7913 vecsv = va_arg(*args, SV*);
7914 vecstr = (U8*)SvPV_const(vecsv,veclen);
7915 vec_utf8 = DO_UTF8(vecsv);
7917 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
7918 vecsv = svargs[efix ? efix-1 : svix++];
7919 vecstr = (U8*)SvPV_const(vecsv,veclen);
7920 vec_utf8 = DO_UTF8(vecsv);
7923 vecsv = &PL_sv_undef;
7931 i = va_arg(*args, int);
7933 i = (ewix ? ewix <= svmax : svix < svmax) ?
7934 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7936 width = (i < 0) ? -i : i;
7946 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7948 /* XXX: todo, support specified precision parameter */
7952 i = va_arg(*args, int);
7954 i = (ewix ? ewix <= svmax : svix < svmax)
7955 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7956 precis = (i < 0) ? 0 : i;
7961 precis = precis * 10 + (*q++ - '0');
7970 case 'I': /* Ix, I32x, and I64x */
7972 if (q[1] == '6' && q[2] == '4') {
7978 if (q[1] == '3' && q[2] == '2') {
7988 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
7999 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8000 if (*(q + 1) == 'l') { /* lld, llf */
8026 const I32 i = efix-1;
8027 argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
8029 argsv = (svix >= 0 && svix < svmax)
8030 ? svargs[svix++] : &PL_sv_undef;
8039 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
8041 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8043 eptr = (char*)utf8buf;
8044 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
8055 if (args && !vectorize) {
8056 eptr = va_arg(*args, char*);
8058 #ifdef MACOS_TRADITIONAL
8059 /* On MacOS, %#s format is used for Pascal strings */
8064 elen = strlen(eptr);
8066 eptr = (char *)nullstr;
8067 elen = sizeof nullstr - 1;
8071 eptr = SvPVx_const(argsv, elen);
8072 if (DO_UTF8(argsv)) {
8073 if (has_precis && precis < elen) {
8075 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
8078 if (width) { /* fudge width (can't fudge elen) */
8079 width += elen - sv_len_utf8(argsv);
8091 * The "%_" hack might have to be changed someday,
8092 * if ISO or ANSI decide to use '_' for something.
8093 * So we keep it hidden from users' code.
8095 if (!args || vectorize)
8097 argsv = va_arg(*args, SV*);
8098 eptr = SvPVx(argsv, elen);
8104 if (has_precis && elen > precis)
8115 goto format_sv; /* %-p -> %_ */
8118 goto format_vd; /* %-1p -> %vd */
8123 goto format_sv; /* %-Np -> %.N_ */
8126 if (alt || vectorize)
8128 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
8149 uv = utf8n_to_uvchr((U8 *)vecstr, veclen, &ulen,
8158 esignbuf[esignlen++] = plus;
8162 case 'h': iv = (short)va_arg(*args, int); break;
8163 case 'l': iv = va_arg(*args, long); break;
8164 case 'V': iv = va_arg(*args, IV); break;
8165 default: iv = va_arg(*args, int); break;
8167 case 'q': iv = va_arg(*args, Quad_t); break;
8172 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
8174 case 'h': iv = (short)tiv; break;
8175 case 'l': iv = (long)tiv; break;
8177 default: iv = tiv; break;
8179 case 'q': iv = (Quad_t)tiv; break;
8183 if ( !vectorize ) /* we already set uv above */
8188 esignbuf[esignlen++] = plus;
8192 esignbuf[esignlen++] = '-';
8235 uv = utf8n_to_uvchr((U8 *)vecstr, veclen, &ulen,
8246 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
8247 case 'l': uv = va_arg(*args, unsigned long); break;
8248 case 'V': uv = va_arg(*args, UV); break;
8249 default: uv = va_arg(*args, unsigned); break;
8251 case 'q': uv = va_arg(*args, Uquad_t); break;
8256 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
8258 case 'h': uv = (unsigned short)tuv; break;
8259 case 'l': uv = (unsigned long)tuv; break;
8261 default: uv = tuv; break;
8263 case 'q': uv = (Uquad_t)tuv; break;
8270 char *ptr = ebuf + sizeof ebuf;
8276 p = (char*)((c == 'X')
8277 ? "0123456789ABCDEF" : "0123456789abcdef");
8283 esignbuf[esignlen++] = '0';
8284 esignbuf[esignlen++] = c; /* 'x' or 'X' */
8292 if (alt && *ptr != '0')
8303 esignbuf[esignlen++] = '0';
8304 esignbuf[esignlen++] = 'b';
8307 default: /* it had better be ten or less */
8308 #if defined(PERL_Y2KWARN)
8309 if (ckWARN(WARN_Y2K)) {
8311 const char *const s = SvPV_const(sv,n);
8312 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
8313 && (n == 2 || !isDIGIT(s[n-3])))
8315 Perl_warner(aTHX_ packWARN(WARN_Y2K),
8316 "Possible Y2K bug: %%%c %s",
8317 c, "format string following '19'");
8324 } while (uv /= base);
8327 elen = (ebuf + sizeof ebuf) - ptr;
8331 zeros = precis - elen;
8332 else if (precis == 0 && elen == 1 && *ptr == '0')
8338 /* FLOATING POINT */
8341 c = 'f'; /* maybe %F isn't supported here */
8347 /* This is evil, but floating point is even more evil */
8349 /* for SV-style calling, we can only get NV
8350 for C-style calling, we assume %f is double;
8351 for simplicity we allow any of %Lf, %llf, %qf for long double
8355 #if defined(USE_LONG_DOUBLE)
8359 /* [perl #20339] - we should accept and ignore %lf rather than die */
8363 #if defined(USE_LONG_DOUBLE)
8364 intsize = args ? 0 : 'q';
8368 #if defined(HAS_LONG_DOUBLE)
8377 /* now we need (long double) if intsize == 'q', else (double) */
8378 nv = (args && !vectorize) ?
8379 #if LONG_DOUBLESIZE > DOUBLESIZE
8381 va_arg(*args, long double) :
8382 va_arg(*args, double)
8384 va_arg(*args, double)
8390 if (c != 'e' && c != 'E') {
8392 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
8393 will cast our (long double) to (double) */
8394 (void)Perl_frexp(nv, &i);
8395 if (i == PERL_INT_MIN)
8396 Perl_die(aTHX_ "panic: frexp");
8398 need = BIT_DIGITS(i);
8400 need += has_precis ? precis : 6; /* known default */
8405 #ifdef HAS_LDBL_SPRINTF_BUG
8406 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8407 with sfio - Allen <allens@cpan.org> */
8410 # define MY_DBL_MAX DBL_MAX
8411 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
8412 # if DOUBLESIZE >= 8
8413 # define MY_DBL_MAX 1.7976931348623157E+308L
8415 # define MY_DBL_MAX 3.40282347E+38L
8419 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
8420 # define MY_DBL_MAX_BUG 1L
8422 # define MY_DBL_MAX_BUG MY_DBL_MAX
8426 # define MY_DBL_MIN DBL_MIN
8427 # else /* XXX guessing! -Allen */
8428 # if DOUBLESIZE >= 8
8429 # define MY_DBL_MIN 2.2250738585072014E-308L
8431 # define MY_DBL_MIN 1.17549435E-38L
8435 if ((intsize == 'q') && (c == 'f') &&
8436 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
8438 /* it's going to be short enough that
8439 * long double precision is not needed */
8441 if ((nv <= 0L) && (nv >= -0L))
8442 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
8444 /* would use Perl_fp_class as a double-check but not
8445 * functional on IRIX - see perl.h comments */
8447 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
8448 /* It's within the range that a double can represent */
8449 #if defined(DBL_MAX) && !defined(DBL_MIN)
8450 if ((nv >= ((long double)1/DBL_MAX)) ||
8451 (nv <= (-(long double)1/DBL_MAX)))
8453 fix_ldbl_sprintf_bug = TRUE;
8456 if (fix_ldbl_sprintf_bug == TRUE) {
8466 # undef MY_DBL_MAX_BUG
8469 #endif /* HAS_LDBL_SPRINTF_BUG */
8471 need += 20; /* fudge factor */
8472 if (PL_efloatsize < need) {
8473 Safefree(PL_efloatbuf);
8474 PL_efloatsize = need + 20; /* more fudge */
8475 Newx(PL_efloatbuf, PL_efloatsize, char);
8476 PL_efloatbuf[0] = '\0';
8479 if ( !(width || left || plus || alt) && fill != '0'
8480 && has_precis && intsize != 'q' ) { /* Shortcuts */
8481 /* See earlier comment about buggy Gconvert when digits,
8483 if ( c == 'g' && precis) {
8484 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
8485 if (*PL_efloatbuf) /* May return an empty string for digits==0 */
8486 goto float_converted;
8487 } else if ( c == 'f' && !precis) {
8488 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
8493 char *ptr = ebuf + sizeof ebuf;
8496 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
8497 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
8498 if (intsize == 'q') {
8499 /* Copy the one or more characters in a long double
8500 * format before the 'base' ([efgEFG]) character to
8501 * the format string. */
8502 static char const prifldbl[] = PERL_PRIfldbl;
8503 char const *p = prifldbl + sizeof(prifldbl) - 3;
8504 while (p >= prifldbl) { *--ptr = *p--; }
8509 do { *--ptr = '0' + (base % 10); } while (base /= 10);
8514 do { *--ptr = '0' + (base % 10); } while (base /= 10);
8526 /* No taint. Otherwise we are in the strange situation
8527 * where printf() taints but print($float) doesn't.
8529 #if defined(HAS_LONG_DOUBLE)
8531 (void)sprintf(PL_efloatbuf, ptr, nv);
8533 (void)sprintf(PL_efloatbuf, ptr, (double)nv);
8535 (void)sprintf(PL_efloatbuf, ptr, nv);
8539 eptr = PL_efloatbuf;
8540 elen = strlen(PL_efloatbuf);
8546 i = SvCUR(sv) - origlen;
8547 if (args && !vectorize) {
8549 case 'h': *(va_arg(*args, short*)) = i; break;
8550 default: *(va_arg(*args, int*)) = i; break;
8551 case 'l': *(va_arg(*args, long*)) = i; break;
8552 case 'V': *(va_arg(*args, IV*)) = i; break;
8554 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
8559 sv_setuv_mg(argsv, (UV)i);
8561 continue; /* not "break" */
8568 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
8569 && ckWARN(WARN_PRINTF))
8571 SV *msg = sv_newmortal();
8572 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
8573 (PL_op->op_type == OP_PRTF) ? "" : "s");
8576 Perl_sv_catpvf(aTHX_ msg,
8577 "\"%%%c\"", c & 0xFF);
8579 Perl_sv_catpvf(aTHX_ msg,
8580 "\"%%\\%03"UVof"\"",
8583 sv_catpv(msg, "end of string");
8584 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
8587 /* output mangled stuff ... */
8593 /* ... right here, because formatting flags should not apply */
8594 SvGROW(sv, SvCUR(sv) + elen + 1);
8596 Copy(eptr, p, elen, char);
8599 SvCUR_set(sv, p - SvPVX_const(sv));
8601 continue; /* not "break" */
8604 /* calculate width before utf8_upgrade changes it */
8605 have = esignlen + zeros + elen;
8607 Perl_croak_nocontext(PL_memory_wrap);
8609 if (is_utf8 != has_utf8) {
8612 sv_utf8_upgrade(sv);
8615 SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
8616 sv_utf8_upgrade(nsv);
8617 eptr = SvPVX_const(nsv);
8620 SvGROW(sv, SvCUR(sv) + elen + 1);
8624 /* Use memchr() instead of strchr(), as eptr is not guaranteed */
8625 /* to point to a null-terminated string. */
8626 if (left && ckWARN(WARN_PRINTF) && memchr(eptr, '\n', elen) &&
8627 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF))
8628 Perl_warner(aTHX_ packWARN(WARN_PRINTF),
8629 "Newline in left-justified string for %sprintf",
8630 (PL_op->op_type == OP_PRTF) ? "" : "s");
8632 need = (have > width ? have : width);
8635 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
8636 Perl_croak_nocontext(PL_memory_wrap);
8637 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
8639 if (esignlen && fill == '0') {
8641 for (i = 0; i < (int)esignlen; i++)
8645 memset(p, fill, gap);
8648 if (esignlen && fill != '0') {
8650 for (i = 0; i < (int)esignlen; i++)
8655 for (i = zeros; i; i--)
8659 Copy(eptr, p, elen, char);
8663 memset(p, ' ', gap);
8668 Copy(dotstr, p, dotstrlen, char);
8672 vectorize = FALSE; /* done iterating over vecstr */
8679 SvCUR_set(sv, p - SvPVX_const(sv));
8687 /* =========================================================================
8689 =head1 Cloning an interpreter
8691 All the macros and functions in this section are for the private use of
8692 the main function, perl_clone().
8694 The foo_dup() functions make an exact copy of an existing foo thinngy.
8695 During the course of a cloning, a hash table is used to map old addresses
8696 to new addresses. The table is created and manipulated with the
8697 ptr_table_* functions.
8701 ============================================================================*/
8704 #if defined(USE_ITHREADS)
8706 #if defined(USE_5005THREADS)
8707 # include "error: USE_5005THREADS and USE_ITHREADS are incompatible"
8710 #ifndef GpREFCNT_inc
8711 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
8715 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8716 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
8717 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8718 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
8719 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8720 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
8721 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8722 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
8723 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
8724 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
8725 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8726 #define SAVEPV(p) (p ? savepv(p) : Nullch)
8727 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
8730 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
8731 regcomp.c. AMS 20010712 */
8734 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
8738 struct reg_substr_datum *s;
8741 return (REGEXP *)NULL;
8743 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8746 len = r->offsets[0];
8747 npar = r->nparens+1;
8749 Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
8750 Copy(r->program, ret->program, len+1, regnode);
8752 Newx(ret->startp, npar, I32);
8753 Copy(r->startp, ret->startp, npar, I32);
8754 Newx(ret->endp, npar, I32);
8755 Copy(r->startp, ret->startp, npar, I32);
8757 Newx(ret->substrs, 1, struct reg_substr_data);
8758 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8759 s->min_offset = r->substrs->data[i].min_offset;
8760 s->max_offset = r->substrs->data[i].max_offset;
8761 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
8762 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
8765 ret->regstclass = NULL;
8768 const int count = r->data->count;
8771 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
8772 char, struct reg_data);
8773 Newx(d->what, count, U8);
8776 for (i = 0; i < count; i++) {
8777 d->what[i] = r->data->what[i];
8778 switch (d->what[i]) {
8780 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
8783 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
8786 /* This is cheating. */
8787 Newx(d->data[i], 1, struct regnode_charclass_class);
8788 StructCopy(r->data->data[i], d->data[i],
8789 struct regnode_charclass_class);
8790 ret->regstclass = (regnode*)d->data[i];
8793 /* Compiled op trees are readonly, and can thus be
8794 shared without duplication. */
8796 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
8800 d->data[i] = r->data->data[i];
8810 Newx(ret->offsets, 2*len+1, U32);
8811 Copy(r->offsets, ret->offsets, 2*len+1, U32);
8813 ret->precomp = SAVEPVN(r->precomp, r->prelen);
8814 ret->refcnt = r->refcnt;
8815 ret->minlen = r->minlen;
8816 ret->prelen = r->prelen;
8817 ret->nparens = r->nparens;
8818 ret->lastparen = r->lastparen;
8819 ret->lastcloseparen = r->lastcloseparen;
8820 ret->reganch = r->reganch;
8822 ret->sublen = r->sublen;
8824 if (RX_MATCH_COPIED(ret))
8825 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
8829 ptr_table_store(PL_ptr_table, r, ret);
8833 /* duplicate a file handle */
8836 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
8840 PERL_UNUSED_ARG(type);
8843 return (PerlIO*)NULL;
8845 /* look for it in the table first */
8846 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
8850 /* create anew and remember what it is */
8851 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
8852 ptr_table_store(PL_ptr_table, fp, ret);
8856 /* duplicate a directory handle */
8859 Perl_dirp_dup(pTHX_ DIR *dp)
8867 /* duplicate a typeglob */
8870 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
8876 /* look for it in the table first */
8877 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
8881 /* create anew and remember what it is */
8883 ptr_table_store(PL_ptr_table, gp, ret);
8886 ret->gp_refcnt = 0; /* must be before any other dups! */
8887 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
8888 ret->gp_io = io_dup_inc(gp->gp_io, param);
8889 ret->gp_form = cv_dup_inc(gp->gp_form, param);
8890 ret->gp_av = av_dup_inc(gp->gp_av, param);
8891 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
8892 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
8893 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
8894 ret->gp_cvgen = gp->gp_cvgen;
8895 ret->gp_flags = gp->gp_flags;
8896 ret->gp_line = gp->gp_line;
8897 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
8901 /* duplicate a chain of magic */
8904 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
8906 MAGIC *mgprev = (MAGIC*)NULL;
8909 return (MAGIC*)NULL;
8910 /* look for it in the table first */
8911 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
8915 for (; mg; mg = mg->mg_moremagic) {
8917 Newxz(nmg, 1, MAGIC);
8919 mgprev->mg_moremagic = nmg;
8922 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
8923 nmg->mg_private = mg->mg_private;
8924 nmg->mg_type = mg->mg_type;
8925 nmg->mg_flags = mg->mg_flags;
8926 if (mg->mg_type == PERL_MAGIC_qr) {
8927 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
8929 else if(mg->mg_type == PERL_MAGIC_backref) {
8930 const AV * const av = (AV*) mg->mg_obj;
8933 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
8935 for (i = AvFILLp(av); i >= 0; i--) {
8936 if (!svp[i]) continue;
8937 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
8941 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
8942 ? sv_dup_inc(mg->mg_obj, param)
8943 : sv_dup(mg->mg_obj, param);
8945 nmg->mg_len = mg->mg_len;
8946 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
8947 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
8948 if (mg->mg_len > 0) {
8949 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
8950 if (mg->mg_type == PERL_MAGIC_overload_table &&
8951 AMT_AMAGIC((AMT*)mg->mg_ptr))
8953 AMT *amtp = (AMT*)mg->mg_ptr;
8954 AMT *namtp = (AMT*)nmg->mg_ptr;
8956 for (i = 1; i < NofAMmeth; i++) {
8957 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
8961 else if (mg->mg_len == HEf_SVKEY)
8962 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
8964 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
8965 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
8972 /* create a new pointer-mapping table */
8975 Perl_ptr_table_new(pTHX)
8978 Newxz(tbl, 1, PTR_TBL_t);
8981 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
8985 #define PTR_TABLE_HASH(ptr) \
8986 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
8989 we use the PTE_SVSLOT 'reservation' made above, both here (in the
8990 following define) and at call to new_body_inline made below in
8991 Perl_ptr_table_store()
8994 #define del_pte(p) del_body_type(p, PTE_SVSLOT)
8996 /* map an existing pointer using a table */
8999 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
9001 PTR_TBL_ENT_t *tblent;
9002 const UV hash = PTR_TABLE_HASH(sv);
9004 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9005 for (; tblent; tblent = tblent->next) {
9006 if (tblent->oldval == sv)
9007 return tblent->newval;
9012 /* add a new entry to a pointer-mapping table */
9015 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldsv, void *newsv)
9017 PTR_TBL_ENT_t *tblent, **otblent;
9018 /* XXX this may be pessimal on platforms where pointers aren't good
9019 * hash values e.g. if they grow faster in the most significant
9021 const UV hash = PTR_TABLE_HASH(oldsv);
9025 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
9026 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
9027 if (tblent->oldval == oldsv) {
9028 tblent->newval = newsv;
9032 new_body_inline(tblent, sizeof(struct ptr_tbl_ent), PTE_SVSLOT);
9033 tblent->oldval = oldsv;
9034 tblent->newval = newsv;
9035 tblent->next = *otblent;
9038 if (!empty && tbl->tbl_items > tbl->tbl_max)
9039 ptr_table_split(tbl);
9042 /* double the hash bucket size of an existing ptr table */
9045 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9047 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9048 const UV oldsize = tbl->tbl_max + 1;
9049 UV newsize = oldsize * 2;
9052 Renew(ary, newsize, PTR_TBL_ENT_t*);
9053 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9054 tbl->tbl_max = --newsize;
9056 for (i=0; i < oldsize; i++, ary++) {
9057 PTR_TBL_ENT_t **curentp, **entp, *ent;
9060 curentp = ary + oldsize;
9061 for (entp = ary, ent = *ary; ent; ent = *entp) {
9062 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
9064 ent->next = *curentp;
9074 /* remove all the entries from a ptr table */
9077 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9079 register PTR_TBL_ENT_t **array;
9080 register PTR_TBL_ENT_t *entry;
9084 if (!tbl || !tbl->tbl_items) {
9088 array = tbl->tbl_ary;
9094 PTR_TBL_ENT_t *oentry = entry;
9095 entry = entry->next;
9099 if (++riter > max) {
9102 entry = array[riter];
9109 /* clear and free a ptr table */
9112 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
9117 ptr_table_clear(tbl);
9118 Safefree(tbl->tbl_ary);
9128 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
9131 SvRV_set(dstr, SvWEAKREF(sstr)
9132 ? sv_dup(SvRV(sstr), param)
9133 : sv_dup_inc(SvRV(sstr), param));
9136 else if (SvPVX_const(sstr)) {
9137 /* Has something there */
9139 /* Normal PV - clone whole allocated space */
9140 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
9143 /* Special case - not normally malloced for some reason */
9144 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9145 /* A "shared" PV - clone it as unshared string */
9146 if(SvPADTMP(sstr)) {
9147 /* However, some of them live in the pad
9148 and they should not have these flags
9151 SvPV_set(dstr, sharepvn(SvPVX_const(sstr), SvCUR(sstr),
9153 SvUV_set(dstr, SvUVX(sstr));
9156 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvCUR(sstr)));
9158 SvREADONLY_off(dstr);
9162 /* Some other special case - random pointer */
9163 SvPV_set(dstr, SvPVX(sstr));
9169 if (SvTYPE(dstr) == SVt_RV)
9170 SvRV_set(dstr, NULL);
9176 /* duplicate an SV of any type (including AV, HV etc) */
9179 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
9183 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
9185 /* look for it in the table first */
9186 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
9190 if(param->flags & CLONEf_JOIN_IN) {
9191 /** We are joining here so we don't want do clone
9192 something that is bad **/
9195 if(SvTYPE(sstr) == SVt_PVHV &&
9196 (hvname = HvNAME_get(sstr))) {
9197 /** don't clone stashes if they already exist **/
9198 return (SV*)gv_stashpv(hvname,0);
9202 /* create anew and remember what it is */
9204 ptr_table_store(PL_ptr_table, sstr, dstr);
9207 SvFLAGS(dstr) = SvFLAGS(sstr);
9208 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
9209 SvREFCNT(dstr) = 0; /* must be before any other dups! */
9212 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
9213 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
9214 PL_watch_pvx, SvPVX_const(sstr));
9217 /* don't clone objects whose class has asked us not to */
9218 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
9219 SvFLAGS(dstr) &= ~SVTYPEMASK;
9224 switch (SvTYPE(sstr)) {
9232 /* These are all the types that need simple bodies allocating. */
9234 const svtype sv_type = SvTYPE(sstr);
9235 const struct body_details *const sv_type_details
9236 = bodies_by_type + sv_type;
9238 assert(sv_type_details->size);
9240 assert(sv_type_details->arena);
9241 new_body_inline(new_body, sv_type_details->size, sv_type);
9242 new_body = (void*)((char*)new_body - sv_type_details->offset);
9244 assert(!sv_type_details->arena);
9245 new_body = new_NOARENA(sv_type_details);
9249 SvANY(dstr) = new_body;
9251 if (sv_type == SVt_RV) {
9252 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9255 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
9256 ((char*)SvANY(dstr)) + sv_type_details->offset,
9257 sv_type_details->copy, char);
9259 Copy(((char*)SvANY(sstr)),
9260 ((char*)SvANY(dstr)),
9261 sv_type_details->size + sv_type_details->offset, char);
9268 /* These are all the types that need complex bodies allocating. */
9270 const svtype sv_type = SvTYPE(sstr);
9271 const struct body_details *const sv_type_details
9272 = bodies_by_type + sv_type;
9276 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]",
9281 if (GvUNIQUE((GV*)sstr)) {
9282 /* Do sharing here, and fall through */
9295 assert(sv_type_details->size);
9296 if (sv_type_details->arena) {
9297 new_body_inline(new_body, sv_type_details->size, sv_type);
9299 = (void*)((char*)new_body - sv_type_details->offset);
9301 new_body = new_NOARENA(sv_type_details);
9305 SvANY(dstr) = new_body;
9308 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
9309 ((char*)SvANY(dstr)) + sv_type_details->offset,
9310 sv_type_details->copy, char);
9312 Copy(((char*)SvANY(sstr)),
9313 ((char*)SvANY(dstr)),
9314 sv_type_details->size + sv_type_details->offset, char);
9317 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV)
9318 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9320 /* The Copy above means that all the source (unduplicated) pointers
9321 are now in the destination. We can check the flags and the
9322 pointers in either, but it's possible that there's less cache
9323 missing by always going for the destination.
9324 FIXME - instrument and check that assumption */
9325 if (sv_type >= SVt_PVMG) {
9327 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
9329 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
9332 /* The cast silences a GCC warning about unhandled types. */
9333 switch ((int)sv_type) {
9345 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
9346 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
9347 LvTARG(dstr) = dstr;
9348 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
9349 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
9351 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
9354 GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
9355 GvSTASH(dstr) = hv_dup_inc(GvSTASH(dstr), param);
9356 GvGP(dstr) = gp_dup(GvGP(dstr), param);
9357 (void)GpREFCNT_inc(GvGP(dstr));
9360 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
9361 if (IoOFP(dstr) == IoIFP(sstr))
9362 IoOFP(dstr) = IoIFP(dstr);
9364 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
9365 /* PL_rsfp_filters entries have fake IoDIRP() */
9366 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
9367 /* I have no idea why fake dirp (rsfps)
9368 should be treated differently but otherwise
9369 we end up with leaks -- sky*/
9370 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
9371 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
9372 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
9374 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
9375 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
9376 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
9378 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
9380 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
9383 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
9384 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
9385 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
9388 if (AvARRAY((AV*)sstr)) {
9389 SV **dst_ary, **src_ary;
9390 SSize_t items = AvFILLp((AV*)sstr) + 1;
9392 src_ary = AvARRAY((AV*)sstr);
9393 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
9394 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
9395 SvPV_set(dstr, (char*)dst_ary);
9396 AvALLOC((AV*)dstr) = dst_ary;
9397 if (AvREAL((AV*)sstr)) {
9399 *dst_ary++ = sv_dup_inc(*src_ary++, param);
9403 *dst_ary++ = sv_dup(*src_ary++, param);
9405 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
9406 while (items-- > 0) {
9407 *dst_ary++ = &PL_sv_undef;
9411 SvPV_set(dstr, NULL);
9412 AvALLOC((AV*)dstr) = (SV**)NULL;
9414 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
9417 if (HvARRAY((HV*)sstr)) {
9418 bool sharekeys = !!HvSHAREKEYS(sstr);
9420 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
9421 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
9422 Newx(dxhv->xhv_array,
9423 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
9424 while (i <= sxhv->xhv_max) {
9425 HE *source = HvARRAY(sstr)[i];
9427 = source ? he_dup(source, sharekeys, param) : 0;
9430 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
9431 (bool)!!HvSHAREKEYS(sstr), param);
9434 SvPV_set(dstr, NULL);
9435 HvEITER_set((HV*)dstr, (HE*)NULL);
9437 /* HvPMROOT is a plain assignment, not a clone. Bug? */
9438 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
9439 /* Record stashes for possible cloning in Perl_clone(). */
9440 if(HvNAME((HV*)dstr))
9441 av_push(param->stashes, dstr);
9445 /* NOTE: not refcounted */
9446 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
9448 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
9450 if (CvCONST(dstr)) {
9451 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
9452 SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
9453 sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
9455 /* don't dup if copying back - CvGV isn't refcounted, so the
9456 * duped GV may never be freed. A bit of a hack! DAPM */
9457 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
9458 NULL : gv_dup(CvGV(dstr), param) ;
9459 if (!(param->flags & CLONEf_COPY_STACKS)) {
9462 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
9465 ? cv_dup( CvOUTSIDE(dstr), param)
9466 : cv_dup_inc(CvOUTSIDE(dstr), param);
9468 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
9474 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9480 /* duplicate a context */
9483 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
9488 return (PERL_CONTEXT*)NULL;
9490 /* look for it in the table first */
9491 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
9495 /* create anew and remember what it is */
9496 Newxz(ncxs, max + 1, PERL_CONTEXT);
9497 ptr_table_store(PL_ptr_table, cxs, ncxs);
9500 PERL_CONTEXT *cx = &cxs[ix];
9501 PERL_CONTEXT *ncx = &ncxs[ix];
9502 ncx->cx_type = cx->cx_type;
9503 if (CxTYPE(cx) == CXt_SUBST) {
9504 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
9507 ncx->blk_oldsp = cx->blk_oldsp;
9508 ncx->blk_oldcop = cx->blk_oldcop;
9509 ncx->blk_oldretsp = cx->blk_oldretsp;
9510 ncx->blk_oldmarksp = cx->blk_oldmarksp;
9511 ncx->blk_oldscopesp = cx->blk_oldscopesp;
9512 ncx->blk_oldpm = cx->blk_oldpm;
9513 ncx->blk_gimme = cx->blk_gimme;
9514 switch (CxTYPE(cx)) {
9516 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
9517 ? cv_dup_inc(cx->blk_sub.cv, param)
9518 : cv_dup(cx->blk_sub.cv,param));
9519 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
9520 ? av_dup_inc(cx->blk_sub.argarray, param)
9522 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
9523 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
9524 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9525 ncx->blk_sub.lval = cx->blk_sub.lval;
9528 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
9529 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
9530 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
9531 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
9532 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
9535 ncx->blk_loop.label = cx->blk_loop.label;
9536 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
9537 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
9538 ncx->blk_loop.next_op = cx->blk_loop.next_op;
9539 ncx->blk_loop.last_op = cx->blk_loop.last_op;
9540 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
9541 ? cx->blk_loop.iterdata
9542 : gv_dup((GV*)cx->blk_loop.iterdata, param));
9543 ncx->blk_loop.oldcomppad
9544 = (PAD*)ptr_table_fetch(PL_ptr_table,
9545 cx->blk_loop.oldcomppad);
9546 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
9547 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
9548 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
9549 ncx->blk_loop.iterix = cx->blk_loop.iterix;
9550 ncx->blk_loop.itermax = cx->blk_loop.itermax;
9553 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
9554 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
9555 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
9556 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9568 /* duplicate a stack info structure */
9571 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
9576 return (PERL_SI*)NULL;
9578 /* look for it in the table first */
9579 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
9583 /* create anew and remember what it is */
9584 Newxz(nsi, 1, PERL_SI);
9585 ptr_table_store(PL_ptr_table, si, nsi);
9587 nsi->si_stack = av_dup_inc(si->si_stack, param);
9588 nsi->si_cxix = si->si_cxix;
9589 nsi->si_cxmax = si->si_cxmax;
9590 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
9591 nsi->si_type = si->si_type;
9592 nsi->si_prev = si_dup(si->si_prev, param);
9593 nsi->si_next = si_dup(si->si_next, param);
9594 nsi->si_markoff = si->si_markoff;
9599 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
9600 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
9601 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
9602 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
9603 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
9604 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
9605 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
9606 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
9607 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
9608 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
9609 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
9610 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
9611 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
9612 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
9615 #define pv_dup_inc(p) SAVEPV(p)
9616 #define pv_dup(p) SAVEPV(p)
9617 #define svp_dup_inc(p,pp) any_dup(p,pp)
9619 /* map any object to the new equivent - either something in the
9620 * ptr table, or something in the interpreter structure
9624 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
9631 /* look for it in the table first */
9632 ret = ptr_table_fetch(PL_ptr_table, v);
9636 /* see if it is part of the interpreter structure */
9637 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
9638 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
9646 /* duplicate the save stack */
9649 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
9651 ANY * const ss = proto_perl->Tsavestack;
9652 const I32 max = proto_perl->Tsavestack_max;
9653 I32 ix = proto_perl->Tsavestack_ix;
9665 void (*dptr) (void*);
9666 void (*dxptr) (pTHX_ void*);
9668 Newxz(nss, max, ANY);
9671 I32 i = POPINT(ss,ix);
9674 case SAVEt_ITEM: /* normal string */
9675 sv = (SV*)POPPTR(ss,ix);
9676 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9677 sv = (SV*)POPPTR(ss,ix);
9678 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9680 case SAVEt_SV: /* scalar reference */
9681 sv = (SV*)POPPTR(ss,ix);
9682 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9683 gv = (GV*)POPPTR(ss,ix);
9684 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9686 case SAVEt_GENERIC_PVREF: /* generic char* */
9687 c = (char*)POPPTR(ss,ix);
9688 TOPPTR(nss,ix) = pv_dup(c);
9689 ptr = POPPTR(ss,ix);
9690 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9692 case SAVEt_SHARED_PVREF: /* char* in shared space */
9693 c = (char*)POPPTR(ss,ix);
9694 TOPPTR(nss,ix) = savesharedpv(c);
9695 ptr = POPPTR(ss,ix);
9696 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9698 case SAVEt_GENERIC_SVREF: /* generic sv */
9699 case SAVEt_SVREF: /* scalar reference */
9700 sv = (SV*)POPPTR(ss,ix);
9701 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9702 ptr = POPPTR(ss,ix);
9703 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
9705 case SAVEt_AV: /* array reference */
9706 av = (AV*)POPPTR(ss,ix);
9707 TOPPTR(nss,ix) = av_dup_inc(av, param);
9708 gv = (GV*)POPPTR(ss,ix);
9709 TOPPTR(nss,ix) = gv_dup(gv, param);
9711 case SAVEt_HV: /* hash reference */
9712 hv = (HV*)POPPTR(ss,ix);
9713 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9714 gv = (GV*)POPPTR(ss,ix);
9715 TOPPTR(nss,ix) = gv_dup(gv, param);
9717 case SAVEt_INT: /* int reference */
9718 ptr = POPPTR(ss,ix);
9719 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9720 intval = (int)POPINT(ss,ix);
9721 TOPINT(nss,ix) = intval;
9723 case SAVEt_LONG: /* long reference */
9724 ptr = POPPTR(ss,ix);
9725 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9726 longval = (long)POPLONG(ss,ix);
9727 TOPLONG(nss,ix) = longval;
9729 case SAVEt_I32: /* I32 reference */
9730 case SAVEt_I16: /* I16 reference */
9731 case SAVEt_I8: /* I8 reference */
9732 ptr = POPPTR(ss,ix);
9733 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9737 case SAVEt_IV: /* IV reference */
9738 ptr = POPPTR(ss,ix);
9739 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9743 case SAVEt_SPTR: /* SV* reference */
9744 ptr = POPPTR(ss,ix);
9745 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9746 sv = (SV*)POPPTR(ss,ix);
9747 TOPPTR(nss,ix) = sv_dup(sv, param);
9749 case SAVEt_VPTR: /* random* reference */
9750 ptr = POPPTR(ss,ix);
9751 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9752 ptr = POPPTR(ss,ix);
9753 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9755 case SAVEt_PPTR: /* char* reference */
9756 ptr = POPPTR(ss,ix);
9757 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9758 c = (char*)POPPTR(ss,ix);
9759 TOPPTR(nss,ix) = pv_dup(c);
9761 case SAVEt_HPTR: /* HV* reference */
9762 ptr = POPPTR(ss,ix);
9763 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9764 hv = (HV*)POPPTR(ss,ix);
9765 TOPPTR(nss,ix) = hv_dup(hv, param);
9767 case SAVEt_APTR: /* AV* reference */
9768 ptr = POPPTR(ss,ix);
9769 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9770 av = (AV*)POPPTR(ss,ix);
9771 TOPPTR(nss,ix) = av_dup(av, param);
9774 gv = (GV*)POPPTR(ss,ix);
9775 TOPPTR(nss,ix) = gv_dup(gv, param);
9777 case SAVEt_GP: /* scalar reference */
9778 gp = (GP*)POPPTR(ss,ix);
9779 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
9780 (void)GpREFCNT_inc(gp);
9781 gv = (GV*)POPPTR(ss,ix);
9782 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9783 c = (char*)POPPTR(ss,ix);
9784 TOPPTR(nss,ix) = pv_dup(c);
9791 case SAVEt_MORTALIZESV:
9792 sv = (SV*)POPPTR(ss,ix);
9793 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9796 ptr = POPPTR(ss,ix);
9797 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
9798 /* these are assumed to be refcounted properly */
9800 switch (((OP*)ptr)->op_type) {
9807 TOPPTR(nss,ix) = ptr;
9812 TOPPTR(nss,ix) = Nullop;
9817 TOPPTR(nss,ix) = Nullop;
9820 c = (char*)POPPTR(ss,ix);
9821 TOPPTR(nss,ix) = pv_dup_inc(c);
9824 longval = POPLONG(ss,ix);
9825 TOPLONG(nss,ix) = longval;
9828 hv = (HV*)POPPTR(ss,ix);
9829 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9830 c = (char*)POPPTR(ss,ix);
9831 TOPPTR(nss,ix) = pv_dup_inc(c);
9835 case SAVEt_DESTRUCTOR:
9836 ptr = POPPTR(ss,ix);
9837 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9838 dptr = POPDPTR(ss,ix);
9839 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
9840 any_dup(FPTR2DPTR(void *, dptr),
9843 case SAVEt_DESTRUCTOR_X:
9844 ptr = POPPTR(ss,ix);
9845 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9846 dxptr = POPDXPTR(ss,ix);
9847 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
9848 any_dup(FPTR2DPTR(void *, dxptr),
9851 case SAVEt_REGCONTEXT:
9857 case SAVEt_STACK_POS: /* Position on Perl stack */
9861 case SAVEt_AELEM: /* array element */
9862 sv = (SV*)POPPTR(ss,ix);
9863 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9866 av = (AV*)POPPTR(ss,ix);
9867 TOPPTR(nss,ix) = av_dup_inc(av, param);
9869 case SAVEt_HELEM: /* hash element */
9870 sv = (SV*)POPPTR(ss,ix);
9871 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9872 sv = (SV*)POPPTR(ss,ix);
9873 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9874 hv = (HV*)POPPTR(ss,ix);
9875 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9878 ptr = POPPTR(ss,ix);
9879 TOPPTR(nss,ix) = ptr;
9886 av = (AV*)POPPTR(ss,ix);
9887 TOPPTR(nss,ix) = av_dup(av, param);
9890 longval = (long)POPLONG(ss,ix);
9891 TOPLONG(nss,ix) = longval;
9892 ptr = POPPTR(ss,ix);
9893 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9894 sv = (SV*)POPPTR(ss,ix);
9895 TOPPTR(nss,ix) = sv_dup(sv, param);
9898 ptr = POPPTR(ss,ix);
9899 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9900 longval = (long)POPBOOL(ss,ix);
9901 TOPBOOL(nss,ix) = (bool)longval;
9903 case SAVEt_RE_STATE:
9905 const struct re_save_state *const old_state
9906 = (struct re_save_state *)
9907 (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
9908 struct re_save_state *const new_state
9909 = (struct re_save_state *)
9910 (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
9912 Copy(old_state, new_state, 1, struct re_save_state);
9913 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
9915 new_state->re_state_bostr
9916 = pv_dup(old_state->re_state_bostr);
9917 new_state->re_state_reginput
9918 = pv_dup(old_state->re_state_reginput);
9919 new_state->re_state_regbol
9920 = pv_dup(old_state->re_state_regbol);
9921 new_state->re_state_regeol
9922 = pv_dup(old_state->re_state_regeol);
9923 new_state->re_state_regstartp
9924 = any_dup(old_state->re_state_regstartp, proto_perl);
9925 new_state->re_state_regendp
9926 = any_dup(old_state->re_state_regendp, proto_perl);
9927 new_state->re_state_reglastparen
9928 = any_dup(old_state->re_state_reglastparen, proto_perl);
9929 new_state->re_state_reglastcloseparen
9930 = any_dup(old_state->re_state_reglastcloseparen,
9932 new_state->re_state_regtill
9933 = pv_dup(old_state->re_state_regtill);
9934 /* XXX This just has to be broken. The old save_re_context
9935 code did SAVEGENERICPV(PL_reg_start_tmp);
9936 PL_reg_start_tmp is char **.
9937 Look above to what the dup code does for
9939 It can never have worked.
9940 So this is merely a faithful copy of the exiting bug: */
9941 new_state->re_state_reg_start_tmp
9942 = (char **) pv_dup((char *)
9943 old_state->re_state_reg_start_tmp);
9944 /* I assume that it only ever "worked" because no-one called
9945 (pseudo)fork while the regexp engine had re-entered itself.
9947 new_state->re_state_reg_call_cc
9948 = any_dup(old_state->re_state_reg_call_cc, proto_perl);
9949 new_state->re_state_reg_re
9950 = any_dup(old_state->re_state_reg_re, proto_perl);
9951 new_state->re_state_reg_ganch
9952 = pv_dup(old_state->re_state_reg_ganch);
9953 new_state->re_state_reg_sv
9954 = sv_dup(old_state->re_state_reg_sv, param);
9955 #ifdef PERL_OLD_COPY_ON_WRITE
9956 new_state->re_state_nrs
9957 = sv_dup(old_state->re_state_nrs, param);
9959 new_state->re_state_reg_magic
9960 = any_dup(old_state->re_state_reg_magic, proto_perl);
9961 new_state->re_state_reg_oldcurpm
9962 = any_dup(old_state->re_state_reg_oldcurpm, proto_perl);
9963 new_state->re_state_reg_curpm
9964 = any_dup(old_state->re_state_reg_curpm, proto_perl);
9965 new_state->re_state_reg_oldsaved
9966 = pv_dup(old_state->re_state_reg_oldsaved);
9967 new_state->re_state_reg_poscache
9968 = pv_dup(old_state->re_state_reg_poscache);
9969 new_state->re_state_reg_starttry
9970 = pv_dup(old_state->re_state_reg_starttry);
9974 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
9982 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
9983 * flag to the result. This is done for each stash before cloning starts,
9984 * so we know which stashes want their objects cloned */
9987 do_mark_cloneable_stash(pTHX_ SV *sv)
9989 const char *const hvname = HvNAME_get((HV*)sv);
9991 GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
9992 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
9993 if (cloner && GvCV(cloner)) {
10000 XPUSHs(sv_2mortal(newSVpv(hvname, 0)));
10002 call_sv((SV*)GvCV(cloner), G_SCALAR);
10009 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
10017 =for apidoc perl_clone
10019 Create and return a new interpreter by cloning the current one.
10021 perl_clone takes these flags as parameters:
10023 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
10024 without it we only clone the data and zero the stacks,
10025 with it we copy the stacks and the new perl interpreter is
10026 ready to run at the exact same point as the previous one.
10027 The pseudo-fork code uses COPY_STACKS while the
10028 threads->new doesn't.
10030 CLONEf_KEEP_PTR_TABLE
10031 perl_clone keeps a ptr_table with the pointer of the old
10032 variable as a key and the new variable as a value,
10033 this allows it to check if something has been cloned and not
10034 clone it again but rather just use the value and increase the
10035 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
10036 the ptr_table using the function
10037 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
10038 reason to keep it around is if you want to dup some of your own
10039 variable who are outside the graph perl scans, example of this
10040 code is in threads.xs create
10043 This is a win32 thing, it is ignored on unix, it tells perls
10044 win32host code (which is c++) to clone itself, this is needed on
10045 win32 if you want to run two threads at the same time,
10046 if you just want to do some stuff in a separate perl interpreter
10047 and then throw it away and return to the original one,
10048 you don't need to do anything.
10053 /* XXX the above needs expanding by someone who actually understands it ! */
10054 EXTERN_C PerlInterpreter *
10055 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10058 perl_clone(PerlInterpreter *proto_perl, UV flags)
10060 #ifdef PERL_IMPLICIT_SYS
10062 /* perlhost.h so we need to call into it
10063 to clone the host, CPerlHost should have a c interface, sky */
10065 if (flags & CLONEf_CLONE_HOST) {
10066 return perl_clone_host(proto_perl,flags);
10068 return perl_clone_using(proto_perl, flags,
10070 proto_perl->IMemShared,
10071 proto_perl->IMemParse,
10073 proto_perl->IStdIO,
10077 proto_perl->IProc);
10081 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10082 struct IPerlMem* ipM, struct IPerlMem* ipMS,
10083 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10084 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10085 struct IPerlDir* ipD, struct IPerlSock* ipS,
10086 struct IPerlProc* ipP)
10088 /* XXX many of the string copies here can be optimized if they're
10089 * constants; they need to be allocated as common memory and just
10090 * their pointers copied. */
10093 CLONE_PARAMS clone_params;
10094 CLONE_PARAMS* param = &clone_params;
10096 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10097 /* for each stash, determine whether its objects should be cloned */
10098 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10099 PERL_SET_THX(my_perl);
10102 Poison(my_perl, 1, PerlInterpreter);
10104 PL_curcop = (COP *)Nullop;
10108 PL_savestack_ix = 0;
10109 PL_savestack_max = -1;
10111 PL_sig_pending = 0;
10112 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10113 # else /* !DEBUGGING */
10114 Zero(my_perl, 1, PerlInterpreter);
10115 # endif /* DEBUGGING */
10117 /* host pointers */
10119 PL_MemShared = ipMS;
10120 PL_MemParse = ipMP;
10127 #else /* !PERL_IMPLICIT_SYS */
10129 CLONE_PARAMS clone_params;
10130 CLONE_PARAMS* param = &clone_params;
10131 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10132 /* for each stash, determine whether its objects should be cloned */
10133 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10134 PERL_SET_THX(my_perl);
10137 Poison(my_perl, 1, PerlInterpreter);
10139 PL_curcop = (COP *)Nullop;
10143 PL_savestack_ix = 0;
10144 PL_savestack_max = -1;
10146 PL_sig_pending = 0;
10147 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10148 # else /* !DEBUGGING */
10149 Zero(my_perl, 1, PerlInterpreter);
10150 # endif /* DEBUGGING */
10151 #endif /* PERL_IMPLICIT_SYS */
10152 param->flags = flags;
10153 param->proto_perl = proto_perl;
10157 PL_body_arenas = NULL;
10158 Zero(&PL_body_roots, 1, PL_body_roots);
10160 /* old arena roots */
10161 PL_xiv_arenaroot = NULL;
10162 PL_xiv_root = NULL;
10163 PL_xnv_arenaroot = NULL;
10164 PL_xnv_root = NULL;
10165 PL_xrv_arenaroot = NULL;
10166 PL_xrv_root = NULL;
10167 PL_xpv_arenaroot = NULL;
10168 PL_xpv_root = NULL;
10169 PL_xpviv_arenaroot = NULL;
10170 PL_xpviv_root = NULL;
10171 PL_xpvnv_arenaroot = NULL;
10172 PL_xpvnv_root = NULL;
10173 PL_xpvcv_arenaroot = NULL;
10174 PL_xpvcv_root = NULL;
10175 PL_xpvav_arenaroot = NULL;
10176 PL_xpvav_root = NULL;
10177 PL_xpvhv_arenaroot = NULL;
10178 PL_xpvhv_root = NULL;
10179 PL_xpvmg_arenaroot = NULL;
10180 PL_xpvmg_root = NULL;
10181 PL_xpvlv_arenaroot = NULL;
10182 PL_xpvlv_root = NULL;
10183 PL_xpvbm_arenaroot = NULL;
10184 PL_xpvbm_root = NULL;
10185 PL_nice_chunk = NULL;
10186 PL_nice_chunk_size = 0;
10188 PL_sv_objcount = 0;
10190 PL_sv_arenaroot = NULL;
10192 PL_debug = proto_perl->Idebug;
10194 PL_hash_seed = proto_perl->Ihash_seed;
10195 PL_rehash_seed = proto_perl->Irehash_seed;
10197 #ifdef USE_REENTRANT_API
10198 /* XXX: things like -Dm will segfault here in perlio, but doing
10199 * PERL_SET_CONTEXT(proto_perl);
10200 * breaks too many other things
10202 Perl_reentrant_init(aTHX);
10205 /* create SV map for pointer relocation */
10206 PL_ptr_table = ptr_table_new();
10208 /* initialize these special pointers as early as possible */
10209 SvANY(&PL_sv_undef) = NULL;
10210 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
10211 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
10212 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
10214 SvANY(&PL_sv_no) = new_XPVNV();
10215 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
10216 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
10217 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10218 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
10219 SvCUR_set(&PL_sv_no, 0);
10220 SvLEN_set(&PL_sv_no, 1);
10221 SvIV_set(&PL_sv_no, 0);
10222 SvNV_set(&PL_sv_no, 0);
10223 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
10225 SvANY(&PL_sv_yes) = new_XPVNV();
10226 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
10227 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
10228 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10229 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
10230 SvCUR_set(&PL_sv_yes, 1);
10231 SvLEN_set(&PL_sv_yes, 2);
10232 SvIV_set(&PL_sv_yes, 1);
10233 SvNV_set(&PL_sv_yes, 1);
10234 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
10236 /* create (a non-shared!) shared string table */
10237 PL_strtab = newHV();
10238 HvSHAREKEYS_off(PL_strtab);
10239 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
10240 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
10242 PL_compiling = proto_perl->Icompiling;
10244 /* These two PVs will be free'd special way so must set them same way op.c does */
10245 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
10246 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
10248 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
10249 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
10251 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
10252 if (!specialWARN(PL_compiling.cop_warnings))
10253 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
10254 if (!specialCopIO(PL_compiling.cop_io))
10255 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
10256 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
10258 /* pseudo environmental stuff */
10259 PL_origargc = proto_perl->Iorigargc;
10260 PL_origargv = proto_perl->Iorigargv;
10262 param->stashes = newAV(); /* Setup array of objects to call clone on */
10264 #ifdef PERLIO_LAYERS
10265 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
10266 PerlIO_clone(aTHX_ proto_perl, param);
10269 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
10270 PL_incgv = gv_dup(proto_perl->Iincgv, param);
10271 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
10272 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
10273 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
10274 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
10277 PL_minus_c = proto_perl->Iminus_c;
10278 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
10279 PL_localpatches = proto_perl->Ilocalpatches;
10280 PL_splitstr = proto_perl->Isplitstr;
10281 PL_preprocess = proto_perl->Ipreprocess;
10282 PL_minus_n = proto_perl->Iminus_n;
10283 PL_minus_p = proto_perl->Iminus_p;
10284 PL_minus_l = proto_perl->Iminus_l;
10285 PL_minus_a = proto_perl->Iminus_a;
10286 PL_minus_F = proto_perl->Iminus_F;
10287 PL_doswitches = proto_perl->Idoswitches;
10288 PL_dowarn = proto_perl->Idowarn;
10289 PL_doextract = proto_perl->Idoextract;
10290 PL_sawampersand = proto_perl->Isawampersand;
10291 PL_unsafe = proto_perl->Iunsafe;
10292 PL_inplace = SAVEPV(proto_perl->Iinplace);
10293 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
10294 PL_perldb = proto_perl->Iperldb;
10295 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
10296 PL_exit_flags = proto_perl->Iexit_flags;
10298 /* magical thingies */
10299 /* XXX time(&PL_basetime) when asked for? */
10300 PL_basetime = proto_perl->Ibasetime;
10301 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
10303 PL_maxsysfd = proto_perl->Imaxsysfd;
10304 PL_multiline = proto_perl->Imultiline;
10305 PL_statusvalue = proto_perl->Istatusvalue;
10307 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
10309 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
10311 PL_encoding = sv_dup(proto_perl->Iencoding, param);
10313 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
10314 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
10315 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
10317 /* Clone the regex array */
10318 PL_regex_padav = newAV();
10320 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
10321 SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
10323 av_push(PL_regex_padav,
10324 sv_dup_inc(regexen[0],param));
10325 for(i = 1; i <= len; i++) {
10326 if(SvREPADTMP(regexen[i])) {
10327 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
10329 av_push(PL_regex_padav,
10331 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
10332 SvIVX(regexen[i])), param)))
10337 PL_regex_pad = AvARRAY(PL_regex_padav);
10339 /* shortcuts to various I/O objects */
10340 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
10341 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
10342 PL_defgv = gv_dup(proto_perl->Idefgv, param);
10343 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
10344 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
10345 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
10347 /* shortcuts to regexp stuff */
10348 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
10350 /* shortcuts to misc objects */
10351 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
10353 /* shortcuts to debugging objects */
10354 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
10355 PL_DBline = gv_dup(proto_perl->IDBline, param);
10356 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
10357 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
10358 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
10359 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
10360 PL_lineary = av_dup(proto_perl->Ilineary, param);
10361 PL_dbargs = av_dup(proto_perl->Idbargs, param);
10363 /* symbol tables */
10364 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
10365 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
10366 PL_nullstash = hv_dup(proto_perl->Inullstash, param);
10367 PL_debstash = hv_dup(proto_perl->Idebstash, param);
10368 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
10369 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
10371 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
10372 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
10373 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
10374 PL_endav = av_dup_inc(proto_perl->Iendav, param);
10375 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
10376 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
10378 PL_sub_generation = proto_perl->Isub_generation;
10380 /* funky return mechanisms */
10381 PL_forkprocess = proto_perl->Iforkprocess;
10383 /* subprocess state */
10384 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
10386 /* internal state */
10387 PL_tainting = proto_perl->Itainting;
10388 PL_taint_warn = proto_perl->Itaint_warn;
10389 PL_maxo = proto_perl->Imaxo;
10390 if (proto_perl->Iop_mask)
10391 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
10395 /* current interpreter roots */
10396 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
10397 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
10398 PL_main_start = proto_perl->Imain_start;
10399 PL_eval_root = proto_perl->Ieval_root;
10400 PL_eval_start = proto_perl->Ieval_start;
10402 /* runtime control stuff */
10403 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
10404 PL_copline = proto_perl->Icopline;
10406 PL_filemode = proto_perl->Ifilemode;
10407 PL_lastfd = proto_perl->Ilastfd;
10408 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
10411 PL_gensym = proto_perl->Igensym;
10412 PL_preambled = proto_perl->Ipreambled;
10413 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
10414 PL_laststatval = proto_perl->Ilaststatval;
10415 PL_laststype = proto_perl->Ilaststype;
10418 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
10419 PL_ofmt = SAVEPV(proto_perl->Iofmt);
10421 /* interpreter atexit processing */
10422 PL_exitlistlen = proto_perl->Iexitlistlen;
10423 if (PL_exitlistlen) {
10424 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10425 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10428 PL_exitlist = (PerlExitListEntry*)NULL;
10429 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
10430 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
10431 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
10433 PL_profiledata = NULL;
10434 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
10435 /* PL_rsfp_filters entries have fake IoDIRP() */
10436 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
10438 PL_compcv = cv_dup(proto_perl->Icompcv, param);
10440 PAD_CLONE_VARS(proto_perl, param);
10442 #ifdef HAVE_INTERP_INTERN
10443 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
10446 /* more statics moved here */
10447 PL_generation = proto_perl->Igeneration;
10448 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
10450 PL_in_clean_objs = proto_perl->Iin_clean_objs;
10451 PL_in_clean_all = proto_perl->Iin_clean_all;
10453 PL_uid = proto_perl->Iuid;
10454 PL_euid = proto_perl->Ieuid;
10455 PL_gid = proto_perl->Igid;
10456 PL_egid = proto_perl->Iegid;
10457 PL_nomemok = proto_perl->Inomemok;
10458 PL_an = proto_perl->Ian;
10459 PL_op_seqmax = proto_perl->Iop_seqmax;
10460 PL_evalseq = proto_perl->Ievalseq;
10461 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
10462 PL_origalen = proto_perl->Iorigalen;
10463 PL_pidstatus = newHV(); /* XXX flag for cloning? */
10464 PL_osname = SAVEPV(proto_perl->Iosname);
10465 PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */
10466 PL_sighandlerp = proto_perl->Isighandlerp;
10469 PL_runops = proto_perl->Irunops;
10471 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
10474 PL_cshlen = proto_perl->Icshlen;
10475 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
10478 PL_lex_state = proto_perl->Ilex_state;
10479 PL_lex_defer = proto_perl->Ilex_defer;
10480 PL_lex_expect = proto_perl->Ilex_expect;
10481 PL_lex_formbrack = proto_perl->Ilex_formbrack;
10482 PL_lex_dojoin = proto_perl->Ilex_dojoin;
10483 PL_lex_starts = proto_perl->Ilex_starts;
10484 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
10485 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
10486 PL_lex_op = proto_perl->Ilex_op;
10487 PL_lex_inpat = proto_perl->Ilex_inpat;
10488 PL_lex_inwhat = proto_perl->Ilex_inwhat;
10489 PL_lex_brackets = proto_perl->Ilex_brackets;
10490 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
10491 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
10492 PL_lex_casemods = proto_perl->Ilex_casemods;
10493 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
10494 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
10496 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
10497 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
10498 PL_nexttoke = proto_perl->Inexttoke;
10500 /* XXX This is probably masking the deeper issue of why
10501 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
10502 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
10503 * (A little debugging with a watchpoint on it may help.)
10505 if (SvANY(proto_perl->Ilinestr)) {
10506 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
10507 i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
10508 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10509 i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
10510 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10511 i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
10512 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10513 i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
10514 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10517 PL_linestr = NEWSV(65,79);
10518 sv_upgrade(PL_linestr,SVt_PVIV);
10519 sv_setpvn(PL_linestr,"",0);
10520 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
10522 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10523 PL_pending_ident = proto_perl->Ipending_ident;
10524 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
10526 PL_expect = proto_perl->Iexpect;
10528 PL_multi_start = proto_perl->Imulti_start;
10529 PL_multi_end = proto_perl->Imulti_end;
10530 PL_multi_open = proto_perl->Imulti_open;
10531 PL_multi_close = proto_perl->Imulti_close;
10533 PL_error_count = proto_perl->Ierror_count;
10534 PL_subline = proto_perl->Isubline;
10535 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
10537 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
10538 if (SvANY(proto_perl->Ilinestr)) {
10539 i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
10540 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10541 i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
10542 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10543 PL_last_lop_op = proto_perl->Ilast_lop_op;
10546 PL_last_uni = SvPVX(PL_linestr);
10547 PL_last_lop = SvPVX(PL_linestr);
10548 PL_last_lop_op = 0;
10550 PL_in_my = proto_perl->Iin_my;
10551 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
10553 PL_cryptseen = proto_perl->Icryptseen;
10556 PL_hints = proto_perl->Ihints;
10558 PL_amagic_generation = proto_perl->Iamagic_generation;
10560 #ifdef USE_LOCALE_COLLATE
10561 PL_collation_ix = proto_perl->Icollation_ix;
10562 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
10563 PL_collation_standard = proto_perl->Icollation_standard;
10564 PL_collxfrm_base = proto_perl->Icollxfrm_base;
10565 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
10566 #endif /* USE_LOCALE_COLLATE */
10568 #ifdef USE_LOCALE_NUMERIC
10569 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
10570 PL_numeric_standard = proto_perl->Inumeric_standard;
10571 PL_numeric_local = proto_perl->Inumeric_local;
10572 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
10573 #endif /* !USE_LOCALE_NUMERIC */
10575 /* utf8 character classes */
10576 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
10577 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
10578 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
10579 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
10580 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
10581 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
10582 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
10583 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
10584 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
10585 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
10586 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
10587 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
10588 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
10589 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
10590 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
10591 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
10592 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
10593 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
10594 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
10595 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
10597 /* Did the locale setup indicate UTF-8? */
10598 PL_utf8locale = proto_perl->Iutf8locale;
10599 /* Unicode features (see perlrun/-C) */
10600 PL_unicode = proto_perl->Iunicode;
10602 /* Pre-5.8 signals control */
10603 PL_signals = proto_perl->Isignals;
10605 /* times() ticks per second */
10606 PL_clocktick = proto_perl->Iclocktick;
10608 /* Recursion stopper for PerlIO_find_layer */
10609 PL_in_load_module = proto_perl->Iin_load_module;
10611 /* sort() routine */
10612 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
10614 /* Not really needed/useful since the reenrant_retint is "volatile",
10615 * but do it for consistency's sake. */
10616 PL_reentrant_retint = proto_perl->Ireentrant_retint;
10618 /* Hooks to shared SVs and locks. */
10619 PL_sharehook = proto_perl->Isharehook;
10620 PL_lockhook = proto_perl->Ilockhook;
10621 PL_unlockhook = proto_perl->Iunlockhook;
10622 PL_threadhook = proto_perl->Ithreadhook;
10624 PL_runops_std = proto_perl->Irunops_std;
10625 PL_runops_dbg = proto_perl->Irunops_dbg;
10627 #ifdef THREADS_HAVE_PIDS
10628 PL_ppid = proto_perl->Ippid;
10632 PL_last_swash_hv = NULL; /* reinits on demand */
10633 PL_last_swash_klen = 0;
10634 PL_last_swash_key[0]= '\0';
10635 PL_last_swash_tmps = (U8*)NULL;
10636 PL_last_swash_slen = 0;
10638 /* perly.c globals */
10639 PL_yydebug = proto_perl->Iyydebug;
10640 PL_yynerrs = proto_perl->Iyynerrs;
10641 PL_yyerrflag = proto_perl->Iyyerrflag;
10642 PL_yychar = proto_perl->Iyychar;
10643 PL_yyval = proto_perl->Iyyval;
10644 PL_yylval = proto_perl->Iyylval;
10646 PL_glob_index = proto_perl->Iglob_index;
10647 PL_srand_called = proto_perl->Isrand_called;
10648 PL_uudmap['M'] = 0; /* reinits on demand */
10649 PL_bitcount = NULL; /* reinits on demand */
10651 if (proto_perl->Ipsig_pend) {
10652 Newxz(PL_psig_pend, SIG_SIZE, int);
10655 PL_psig_pend = (int*)NULL;
10658 if (proto_perl->Ipsig_ptr) {
10659 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
10660 Newxz(PL_psig_name, SIG_SIZE, SV*);
10661 for (i = 1; i < SIG_SIZE; i++) {
10662 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
10663 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
10667 PL_psig_ptr = (SV**)NULL;
10668 PL_psig_name = (SV**)NULL;
10671 /* thrdvar.h stuff */
10673 if (flags & CLONEf_COPY_STACKS) {
10674 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
10675 PL_tmps_ix = proto_perl->Ttmps_ix;
10676 PL_tmps_max = proto_perl->Ttmps_max;
10677 PL_tmps_floor = proto_perl->Ttmps_floor;
10678 Newxz(PL_tmps_stack, PL_tmps_max, SV*);
10680 while (i <= PL_tmps_ix) {
10681 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
10685 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
10686 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
10687 Newxz(PL_markstack, i, I32);
10688 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
10689 - proto_perl->Tmarkstack);
10690 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
10691 - proto_perl->Tmarkstack);
10692 Copy(proto_perl->Tmarkstack, PL_markstack,
10693 PL_markstack_ptr - PL_markstack + 1, I32);
10695 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
10696 * NOTE: unlike the others! */
10697 PL_scopestack_ix = proto_perl->Tscopestack_ix;
10698 PL_scopestack_max = proto_perl->Tscopestack_max;
10699 Newxz(PL_scopestack, PL_scopestack_max, I32);
10700 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
10702 /* next push_return() sets PL_retstack[PL_retstack_ix]
10703 * NOTE: unlike the others! */
10704 PL_retstack_ix = proto_perl->Tretstack_ix;
10705 PL_retstack_max = proto_perl->Tretstack_max;
10706 Newz(54, PL_retstack, PL_retstack_max, OP*);
10707 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*);
10709 /* NOTE: si_dup() looks at PL_markstack */
10710 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
10712 /* PL_curstack = PL_curstackinfo->si_stack; */
10713 PL_curstack = av_dup(proto_perl->Tcurstack, param);
10714 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
10716 /* next PUSHs() etc. set *(PL_stack_sp+1) */
10717 PL_stack_base = AvARRAY(PL_curstack);
10718 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
10719 - proto_perl->Tstack_base);
10720 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
10722 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
10723 * NOTE: unlike the others! */
10724 PL_savestack_ix = proto_perl->Tsavestack_ix;
10725 PL_savestack_max = proto_perl->Tsavestack_max;
10726 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
10727 PL_savestack = ss_dup(proto_perl, param);
10731 ENTER; /* perl_destruct() wants to LEAVE; */
10733 /* although we're not duplicating the tmps stack, we should still
10734 * add entries for any SVs on the tmps stack that got cloned by a
10735 * non-refcount means (eg a temp in @_); otherwise they will be
10738 for (i = 0; i<= proto_perl->Ttmps_ix; i++) {
10739 SV *nsv = (SV*)ptr_table_fetch(PL_ptr_table,
10740 proto_perl->Ttmps_stack[i]);
10741 if (nsv && !SvREFCNT(nsv)) {
10743 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv);
10748 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
10749 PL_top_env = &PL_start_env;
10751 PL_op = proto_perl->Top;
10754 PL_Xpv = (XPV*)NULL;
10755 PL_na = proto_perl->Tna;
10757 PL_statbuf = proto_perl->Tstatbuf;
10758 PL_statcache = proto_perl->Tstatcache;
10759 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
10760 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
10762 PL_timesbuf = proto_perl->Ttimesbuf;
10765 PL_tainted = proto_perl->Ttainted;
10766 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
10767 PL_rs = sv_dup_inc(proto_perl->Trs, param);
10768 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
10769 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
10770 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
10771 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
10772 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
10773 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
10774 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
10776 PL_restartop = proto_perl->Trestartop;
10777 PL_in_eval = proto_perl->Tin_eval;
10778 PL_delaymagic = proto_perl->Tdelaymagic;
10779 PL_dirty = proto_perl->Tdirty;
10780 PL_localizing = proto_perl->Tlocalizing;
10782 #ifdef PERL_FLEXIBLE_EXCEPTIONS
10783 PL_protect = proto_perl->Tprotect;
10785 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
10786 PL_hv_fetch_ent_mh = NULL;
10787 PL_modcount = proto_perl->Tmodcount;
10788 PL_lastgotoprobe = Nullop;
10789 PL_dumpindent = proto_perl->Tdumpindent;
10791 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
10792 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
10793 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
10794 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
10795 PL_sortcxix = proto_perl->Tsortcxix;
10796 PL_efloatbuf = NULL; /* reinits on demand */
10797 PL_efloatsize = 0; /* reinits on demand */
10801 PL_screamfirst = NULL;
10802 PL_screamnext = NULL;
10803 PL_maxscream = -1; /* reinits on demand */
10804 PL_lastscream = NULL;
10806 PL_watchaddr = NULL;
10809 PL_regdummy = proto_perl->Tregdummy;
10810 PL_regcomp_parse = Nullch;
10811 PL_regxend = Nullch;
10812 PL_regcode = (regnode*)NULL;
10815 PL_regprecomp = NULL;
10820 PL_seen_zerolen = 0;
10822 PL_regcomp_rx = (regexp*)NULL;
10824 PL_colorset = 0; /* reinits PL_colors[] */
10825 /*PL_colors[6] = {0,0,0,0,0,0};*/
10826 PL_reg_whilem_seen = 0;
10827 PL_reginput = NULL;
10830 PL_regstartp = (I32*)NULL;
10831 PL_regendp = (I32*)NULL;
10832 PL_reglastparen = (U32*)NULL;
10833 PL_reglastcloseparen = (U32*)NULL;
10835 PL_reg_start_tmp = (char**)NULL;
10836 PL_reg_start_tmpl = 0;
10837 PL_regdata = (struct reg_data*)NULL;
10840 PL_reg_eval_set = 0;
10842 PL_regprogram = (regnode*)NULL;
10844 PL_regcc = (CURCUR*)NULL;
10845 PL_reg_call_cc = (struct re_cc_state*)NULL;
10846 PL_reg_re = (regexp*)NULL;
10847 PL_reg_ganch = NULL;
10849 PL_reg_match_utf8 = FALSE;
10850 PL_reg_magic = (MAGIC*)NULL;
10852 PL_reg_oldcurpm = (PMOP*)NULL;
10853 PL_reg_curpm = (PMOP*)NULL;
10854 PL_reg_oldsaved = NULL;
10855 PL_reg_oldsavedlen = 0;
10856 PL_reg_maxiter = 0;
10857 PL_reg_leftiter = 0;
10858 PL_reg_poscache = NULL;
10859 PL_reg_poscache_size= 0;
10861 /* RE engine - function pointers */
10862 PL_regcompp = proto_perl->Tregcompp;
10863 PL_regexecp = proto_perl->Tregexecp;
10864 PL_regint_start = proto_perl->Tregint_start;
10865 PL_regint_string = proto_perl->Tregint_string;
10866 PL_regfree = proto_perl->Tregfree;
10868 PL_reginterp_cnt = 0;
10869 PL_reg_starttry = 0;
10871 /* Pluggable optimizer */
10872 PL_peepp = proto_perl->Tpeepp;
10874 PL_stashcache = newHV();
10876 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
10877 ptr_table_free(PL_ptr_table);
10878 PL_ptr_table = NULL;
10881 /* Call the ->CLONE method, if it exists, for each of the stashes
10882 identified by sv_dup() above.
10884 while(av_len(param->stashes) != -1) {
10885 HV* const stash = (HV*) av_shift(param->stashes);
10886 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
10887 if (cloner && GvCV(cloner)) {
10892 XPUSHs(sv_2mortal(newSVpv(HvNAME_get(stash), 0)));
10894 call_sv((SV*)GvCV(cloner), G_DISCARD);
10900 SvREFCNT_dec(param->stashes);
10902 /* orphaned? eg threads->new inside BEGIN or use */
10903 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
10904 SvREFCNT_inc_simple_void(PL_compcv);
10905 SAVEFREESV(PL_compcv);
10911 #endif /* USE_ITHREADS */
10914 =head1 Unicode Support
10916 =for apidoc sv_recode_to_utf8
10918 The encoding is assumed to be an Encode object, on entry the PV
10919 of the sv is assumed to be octets in that encoding, and the sv
10920 will be converted into Unicode (and UTF-8).
10922 If the sv already is UTF-8 (or if it is not POK), or if the encoding
10923 is not a reference, nothing is done to the sv. If the encoding is not
10924 an C<Encode::XS> Encoding object, bad things will happen.
10925 (See F<lib/encoding.pm> and L<Encode>).
10927 The PV of the sv is returned.
10932 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
10934 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
10948 Passing sv_yes is wrong - it needs to be or'ed set of constants
10949 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
10950 remove converted chars from source.
10952 Both will default the value - let them.
10954 XPUSHs(&PL_sv_yes);
10957 call_method("decode", G_SCALAR);
10961 s = SvPV_const(uni, len);
10962 if (s != SvPVX_const(sv)) {
10963 SvGROW(sv, len + 1);
10964 Move(s, SvPVX(sv), len + 1, char);
10965 SvCUR_set(sv, len);
10972 return SvPOKp(sv) ? SvPVX(sv) : NULL;
10976 =for apidoc sv_cat_decode
10978 The encoding is assumed to be an Encode object, the PV of the ssv is
10979 assumed to be octets in that encoding and decoding the input starts
10980 from the position which (PV + *offset) pointed to. The dsv will be
10981 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
10982 when the string tstr appears in decoding output or the input ends on
10983 the PV of the ssv. The value which the offset points will be modified
10984 to the last input position on the ssv.
10986 Returns TRUE if the terminator was found, else returns FALSE.
10991 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
10992 SV *ssv, int *offset, char *tstr, int tlen)
10995 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
11006 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
11007 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
11009 call_method("cat_decode", G_SCALAR);
11011 ret = SvTRUE(TOPs);
11012 *offset = SvIV(offsv);
11018 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
11024 * c-indentation-style: bsd
11025 * c-basic-offset: 4
11026 * indent-tabs-mode: t
11029 * ex: set ts=8 sts=4 sw=4 noet: