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 /* The cache element 0 is the Unicode offset;
34 * the cache element 1 is the byte offset of the element 0;
35 * the cache element 2 is the Unicode length of the substring;
36 * the cache element 3 is the byte length of the substring;
37 * The checking of the substring side would be good
38 * but substr() has enough code paths to make my head spin;
39 * if adding more checks watch out for the following tests:
40 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
41 * lib/utf8.t lib/Unicode/Collate/t/index.t
44 #define ASSERT_UTF8_CACHE(cache) \
45 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
47 #define ASSERT_UTF8_CACHE(cache) NOOP
50 #ifdef PERL_OLD_COPY_ON_WRITE
51 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
52 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
53 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
57 /* ============================================================================
59 =head1 Allocation and deallocation of SVs.
61 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
62 av, hv...) contains type and reference count information, as well as a
63 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
64 specific to each type.
66 In all but the most memory-paranoid configuations (ex: PURIFY), this
67 allocation is done using arenas, which by default are approximately 4K
68 chunks of memory parcelled up into N heads or bodies (of same size).
69 Sv-bodies are allocated by their sv-type, guaranteeing size
70 consistency needed to allocate safely from arrays.
72 The first slot in each arena is reserved, and is used to hold a link
73 to the next arena. In the case of heads, the unused first slot also
74 contains some flags and a note of the number of slots. Snaked through
75 each arena chain is a linked list of free items; when this becomes
76 empty, an extra arena is allocated and divided up into N items which
77 are threaded into the free list.
79 The following global variables are associated with arenas:
81 PL_sv_arenaroot pointer to list of SV arenas
82 PL_sv_root pointer to list of free SV structures
84 PL_body_arenaroots[] array of pointers to list of arenas, 1 per svtype
85 PL_body_roots[] array of pointers to list of free bodies of svtype
86 arrays are indexed by the svtype needed
88 Note that some of the larger and more rarely used body types (eg
89 xpvio) are not allocated using arenas, but are instead just
90 malloc()/free()ed as required.
92 In addition, a few SV heads are not allocated from an arena, but are
93 instead directly created as static or auto variables, eg PL_sv_undef.
94 The size of arenas can be changed from the default by setting
95 PERL_ARENA_SIZE appropriately at compile time.
97 The SV arena serves the secondary purpose of allowing still-live SVs
98 to be located and destroyed during final cleanup.
100 At the lowest level, the macros new_SV() and del_SV() grab and free
101 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
102 to return the SV to the free list with error checking.) new_SV() calls
103 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
104 SVs in the free list have their SvTYPE field set to all ones.
106 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
107 that allocate and return individual body types. Normally these are mapped
108 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
109 instead mapped directly to malloc()/free() if PURIFY is defined. The
110 new/del functions remove from, or add to, the appropriate PL_foo_root
111 list, and call more_xiv() etc to add a new arena if the list is empty.
113 At the time of very final cleanup, sv_free_arenas() is called from
114 perl_destruct() to physically free all the arenas allocated since the
115 start of the interpreter.
117 Manipulation of any of the PL_*root pointers is protected by enclosing
118 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
119 if threads are enabled.
121 The function visit() scans the SV arenas list, and calls a specified
122 function for each SV it finds which is still live - ie which has an SvTYPE
123 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
124 following functions (specified as [function that calls visit()] / [function
125 called by visit() for each SV]):
127 sv_report_used() / do_report_used()
128 dump all remaining SVs (debugging aid)
130 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
131 Attempt to free all objects pointed to by RVs,
132 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
133 try to do the same for all objects indirectly
134 referenced by typeglobs too. Called once from
135 perl_destruct(), prior to calling sv_clean_all()
138 sv_clean_all() / do_clean_all()
139 SvREFCNT_dec(sv) each remaining SV, possibly
140 triggering an sv_free(). It also sets the
141 SVf_BREAK flag on the SV to indicate that the
142 refcnt has been artificially lowered, and thus
143 stopping sv_free() from giving spurious warnings
144 about SVs which unexpectedly have a refcnt
145 of zero. called repeatedly from perl_destruct()
146 until there are no SVs left.
148 =head2 Arena allocator API Summary
150 Private API to rest of sv.c
154 new_XIV(), del_XIV(),
155 new_XNV(), del_XNV(),
160 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
165 ============================================================================ */
170 * "A time to plant, and a time to uproot what was planted..."
174 * nice_chunk and nice_chunk size need to be set
175 * and queried under the protection of sv_mutex
178 Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
184 new_chunk = (void *)(chunk);
185 new_chunk_size = (chunk_size);
186 if (new_chunk_size > PL_nice_chunk_size) {
187 Safefree(PL_nice_chunk);
188 PL_nice_chunk = (char *) new_chunk;
189 PL_nice_chunk_size = new_chunk_size;
196 #ifdef DEBUG_LEAKING_SCALARS
197 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
199 # define FREE_SV_DEBUG_FILE(sv)
203 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
204 /* Whilst I'd love to do this, it seems that things like to check on
206 # define POSION_SV_HEAD(sv) Poison(sv, 1, struct STRUCT_SV)
208 # define POSION_SV_HEAD(sv) Poison(&SvANY(sv), 1, void *), \
209 Poison(&SvREFCNT(sv), 1, U32)
211 # define SvARENA_CHAIN(sv) SvANY(sv)
212 # define POSION_SV_HEAD(sv)
215 #define plant_SV(p) \
217 FREE_SV_DEBUG_FILE(p); \
219 SvARENA_CHAIN(p) = (void *)PL_sv_root; \
220 SvFLAGS(p) = SVTYPEMASK; \
225 /* sv_mutex must be held while calling uproot_SV() */
226 #define uproot_SV(p) \
229 PL_sv_root = (SV*)SvARENA_CHAIN(p); \
234 /* make some more SVs by adding another arena */
236 /* sv_mutex must be held while calling more_sv() */
244 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
245 PL_nice_chunk = NULL;
246 PL_nice_chunk_size = 0;
249 char *chunk; /* must use New here to match call to */
250 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
251 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
257 /* new_SV(): return a new, empty SV head */
259 #ifdef DEBUG_LEAKING_SCALARS
260 /* provide a real function for a debugger to play with */
270 sv = S_more_sv(aTHX);
275 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
276 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
277 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
278 sv->sv_debug_inpad = 0;
279 sv->sv_debug_cloned = 0;
280 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
284 # define new_SV(p) (p)=S_new_SV(aTHX)
293 (p) = S_more_sv(aTHX); \
302 /* del_SV(): return an empty SV head to the free list */
317 S_del_sv(pTHX_ SV *p)
323 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
324 const SV * const sv = sva + 1;
325 const SV * const svend = &sva[SvREFCNT(sva)];
326 if (p >= sv && p < svend) {
332 if (ckWARN_d(WARN_INTERNAL))
333 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
334 "Attempt to free non-arena SV: 0x%"UVxf
335 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
342 #else /* ! DEBUGGING */
344 #define del_SV(p) plant_SV(p)
346 #endif /* DEBUGGING */
350 =head1 SV Manipulation Functions
352 =for apidoc sv_add_arena
354 Given a chunk of memory, link it to the head of the list of arenas,
355 and split it into a list of free SVs.
361 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
364 SV* const sva = (SV*)ptr;
368 /* The first SV in an arena isn't an SV. */
369 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
370 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
371 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
373 PL_sv_arenaroot = sva;
374 PL_sv_root = sva + 1;
376 svend = &sva[SvREFCNT(sva) - 1];
379 SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1);
383 /* Must always set typemask because it's awlays checked in on cleanup
384 when the arenas are walked looking for objects. */
385 SvFLAGS(sv) = SVTYPEMASK;
388 SvARENA_CHAIN(sv) = 0;
392 SvFLAGS(sv) = SVTYPEMASK;
395 /* visit(): call the named function for each non-free SV in the arenas
396 * whose flags field matches the flags/mask args. */
399 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
405 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
406 register const SV * const svend = &sva[SvREFCNT(sva)];
408 for (sv = sva + 1; sv < svend; ++sv) {
409 if (SvTYPE(sv) != SVTYPEMASK
410 && (sv->sv_flags & mask) == flags
423 /* called by sv_report_used() for each live SV */
426 do_report_used(pTHX_ SV *sv)
428 if (SvTYPE(sv) != SVTYPEMASK) {
429 PerlIO_printf(Perl_debug_log, "****\n");
436 =for apidoc sv_report_used
438 Dump the contents of all SVs not yet freed. (Debugging aid).
444 Perl_sv_report_used(pTHX)
447 visit(do_report_used, 0, 0);
451 /* called by sv_clean_objs() for each live SV */
454 do_clean_objs(pTHX_ SV *ref)
458 SV * const target = SvRV(ref);
459 if (SvOBJECT(target)) {
460 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
461 if (SvWEAKREF(ref)) {
462 sv_del_backref(target, ref);
468 SvREFCNT_dec(target);
473 /* XXX Might want to check arrays, etc. */
476 /* called by sv_clean_objs() for each live SV */
478 #ifndef DISABLE_DESTRUCTOR_KLUDGE
480 do_clean_named_objs(pTHX_ SV *sv)
483 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
485 #ifdef PERL_DONT_CREATE_GVSV
488 SvOBJECT(GvSV(sv))) ||
489 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
490 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
491 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
492 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
494 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
495 SvFLAGS(sv) |= SVf_BREAK;
503 =for apidoc sv_clean_objs
505 Attempt to destroy all objects not yet freed
511 Perl_sv_clean_objs(pTHX)
514 PL_in_clean_objs = TRUE;
515 visit(do_clean_objs, SVf_ROK, SVf_ROK);
516 #ifndef DISABLE_DESTRUCTOR_KLUDGE
517 /* some barnacles may yet remain, clinging to typeglobs */
518 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
520 PL_in_clean_objs = FALSE;
523 /* called by sv_clean_all() for each live SV */
526 do_clean_all(pTHX_ SV *sv)
529 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
530 SvFLAGS(sv) |= SVf_BREAK;
531 if (PL_comppad == (AV*)sv) {
533 PL_curpad = Null(SV**);
539 =for apidoc sv_clean_all
541 Decrement the refcnt of each remaining SV, possibly triggering a
542 cleanup. This function may have to be called multiple times to free
543 SVs which are in complex self-referential hierarchies.
549 Perl_sv_clean_all(pTHX)
553 PL_in_clean_all = TRUE;
554 cleaned = visit(do_clean_all, 0,0);
555 PL_in_clean_all = FALSE;
560 S_free_arena(pTHX_ void **root) {
562 void ** const next = *(void **)root;
569 =for apidoc sv_free_arenas
571 Deallocate the memory used by all arenas. Note that all the individual SV
572 heads and bodies within the arenas must already have been freed.
577 Perl_sv_free_arenas(pTHX)
584 /* Free arenas here, but be careful about fake ones. (We assume
585 contiguity of the fake ones with the corresponding real ones.) */
587 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
588 svanext = (SV*) SvANY(sva);
589 while (svanext && SvFAKE(svanext))
590 svanext = (SV*) SvANY(svanext);
596 S_free_arena(aTHX_ (void**) PL_body_arenas);
598 for (i=0; i<SVt_LAST; i++)
599 PL_body_roots[i] = 0;
601 Safefree(PL_nice_chunk);
602 PL_nice_chunk = NULL;
603 PL_nice_chunk_size = 0;
609 Here are mid-level routines that manage the allocation of bodies out
610 of the various arenas. There are 5 kinds of arenas:
612 1. SV-head arenas, which are discussed and handled above
613 2. regular body arenas
614 3. arenas for reduced-size bodies
616 5. pte arenas (thread related)
618 Arena types 2 & 3 are chained by body-type off an array of
619 arena-root pointers, which is indexed by svtype. Some of the
620 larger/less used body types are malloced singly, since a large
621 unused block of them is wasteful. Also, several svtypes dont have
622 bodies; the data fits into the sv-head itself. The arena-root
623 pointer thus has a few unused root-pointers (which may be hijacked
624 later for arena types 4,5)
626 3 differs from 2 as an optimization; some body types have several
627 unused fields in the front of the structure (which are kept in-place
628 for consistency). These bodies can be allocated in smaller chunks,
629 because the leading fields arent accessed. Pointers to such bodies
630 are decremented to point at the unused 'ghost' memory, knowing that
631 the pointers are used with offsets to the real memory.
633 HE, HEK arenas are managed separately, with separate code, but may
634 be merge-able later..
636 PTE arenas are not sv-bodies, but they share these mid-level
637 mechanics, so are considered here. The new mid-level mechanics rely
638 on the sv_type of the body being allocated, so we just reserve one
639 of the unused body-slots for PTEs, then use it in those (2) PTE
640 contexts below (line ~10k)
644 S_more_bodies (pTHX_ size_t size, svtype sv_type)
647 void ** const root = &PL_body_roots[sv_type];
650 const size_t count = PERL_ARENA_SIZE / size;
652 Newx(start, count*size, char);
653 *((void **) start) = PL_body_arenas;
654 PL_body_arenas = (void *)start;
656 end = start + (count-1) * size;
658 /* The initial slot is used to link the arenas together, so it isn't to be
659 linked into the list of ready-to-use bodies. */
663 *root = (void *)start;
665 while (start < end) {
666 char * const next = start + size;
667 *(void**) start = (void *)next;
675 /* grab a new thing from the free list, allocating more if necessary */
677 /* 1st, the inline version */
679 #define new_body_inline(xpv, size, sv_type) \
681 void ** const r3wt = &PL_body_roots[sv_type]; \
683 xpv = *((void **)(r3wt)) \
684 ? *((void **)(r3wt)) : S_more_bodies(aTHX_ size, sv_type); \
685 *(r3wt) = *(void**)(xpv); \
689 /* now use the inline version in the proper function */
693 /* This isn't being used with -DPURIFY, so don't declare it. Otherwise
694 compilers issue warnings. */
697 S_new_body(pTHX_ size_t size, svtype sv_type)
701 new_body_inline(xpv, size, sv_type);
707 /* return a thing to the free list */
709 #define del_body(thing, root) \
711 void ** const thing_copy = (void **)thing;\
713 *thing_copy = *root; \
714 *root = (void*)thing_copy; \
719 Revisiting type 3 arenas, there are 4 body-types which have some
720 members that are never accessed. They are XPV, XPVIV, XPVAV,
721 XPVHV, which have corresponding types: xpv_allocated,
722 xpviv_allocated, xpvav_allocated, xpvhv_allocated,
724 For these types, the arenas are carved up into *_allocated size
725 chunks, we thus avoid wasted memory for those unaccessed members.
726 When bodies are allocated, we adjust the pointer back in memory by
727 the size of the bit not allocated, so it's as if we allocated the
728 full structure. (But things will all go boom if you write to the
729 part that is "not there", because you'll be overwriting the last
730 members of the preceding structure in memory.)
732 We calculate the correction using the STRUCT_OFFSET macro. For example, if
733 xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
734 and the pointer is unchanged. If the allocated structure is smaller (no
735 initial NV actually allocated) then the net effect is to subtract the size
736 of the NV from the pointer, to return a new pointer as if an initial NV were
739 This is the same trick as was used for NV and IV bodies. Ironically it
740 doesn't need to be used for NV bodies any more, because NV is now at the
741 start of the structure. IV bodies don't need it either, because they are
742 no longer allocated. */
744 /* The following 2 arrays hide the above details in a pair of
745 lookup-tables, allowing us to be body-type agnostic.
747 size maps svtype to its body's allocated size.
748 offset maps svtype to the body-pointer adjustment needed
750 NB: elements in latter are 0 or <0, and are added during
751 allocation, and subtracted during deallocation. It may be clearer
752 to invert the values, and call it shrinkage_by_svtype.
755 struct body_details {
756 size_t size; /* Size to allocate */
757 size_t copy; /* Size of structure to copy (may be shorter) */
759 bool cant_upgrade; /* Can upgrade this type */
760 bool zero_nv; /* zero the NV when upgrading from this */
761 bool arena; /* Allocated from an arena */
768 /* With -DPURFIY we allocate everything directly, and don't use arenas.
769 This seems a rather elegant way to simplify some of the code below. */
770 #define HASARENA FALSE
772 #define HASARENA TRUE
774 #define NOARENA FALSE
776 /* A macro to work out the offset needed to subtract from a pointer to (say)
783 to make its members accessible via a pointer to (say)
793 #define relative_STRUCT_OFFSET(longer, shorter, member) \
794 (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
796 /* Calculate the length to copy. Specifically work out the length less any
797 final padding the compiler needed to add. See the comment in sv_upgrade
798 for why copying the padding proved to be a bug. */
800 #define copy_length(type, last_member) \
801 STRUCT_OFFSET(type, last_member) \
802 + sizeof (((type*)SvANY((SV*)0))->last_member)
804 static const struct body_details bodies_by_type[] = {
805 {0, 0, 0, FALSE, NONV, NOARENA},
806 /* IVs are in the head, so the allocation size is 0 */
807 {0, sizeof(IV), STRUCT_OFFSET(XPVIV, xiv_iv), FALSE, NONV, NOARENA},
808 /* 8 bytes on most ILP32 with IEEE doubles */
809 {sizeof(NV), sizeof(NV), 0, FALSE, HADNV, HASARENA},
810 /* RVs are in the head now */
811 /* However, this slot is overloaded and used by the pte */
812 {0, 0, 0, FALSE, NONV, NOARENA},
813 /* 8 bytes on most ILP32 with IEEE doubles */
814 {sizeof(xpv_allocated),
815 copy_length(XPV, xpv_len)
816 - relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
817 + relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
818 FALSE, NONV, HASARENA},
820 {sizeof(xpviv_allocated),
821 copy_length(XPVIV, xiv_u)
822 - relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
823 + relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
824 FALSE, NONV, HASARENA},
826 {sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, FALSE, HADNV, HASARENA},
828 {sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, FALSE, HADNV, HASARENA},
830 {sizeof(XPVBM), sizeof(XPVBM), 0, TRUE, HADNV, HASARENA},
832 {sizeof(XPVGV), sizeof(XPVGV), 0, TRUE, HADNV, HASARENA},
834 {sizeof(XPVLV), sizeof(XPVLV), 0, TRUE, HADNV, HASARENA},
836 {sizeof(xpvav_allocated),
837 copy_length(XPVAV, xmg_stash)
838 - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
839 + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
840 TRUE, HADNV, HASARENA},
842 {sizeof(xpvhv_allocated),
843 copy_length(XPVHV, xmg_stash)
844 - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
845 + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
846 TRUE, HADNV, HASARENA},
848 {sizeof(XPVCV), sizeof(XPVCV), 0, TRUE, HADNV, HASARENA},
850 {sizeof(XPVFM), sizeof(XPVFM), 0, TRUE, HADNV, NOARENA},
852 {sizeof(XPVIO), sizeof(XPVIO), 0, TRUE, HADNV, NOARENA}
855 #define new_body_type(sv_type) \
856 (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
857 - bodies_by_type[sv_type].offset)
859 #define del_body_type(p, sv_type) \
860 del_body(p, &PL_body_roots[sv_type])
863 #define new_body_allocated(sv_type) \
864 (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
865 - bodies_by_type[sv_type].offset)
867 #define del_body_allocated(p, sv_type) \
868 del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
871 #define my_safemalloc(s) (void*)safemalloc(s)
872 #define my_safecalloc(s) (void*)safecalloc(s, 1)
873 #define my_safefree(p) safefree((char*)p)
877 #define new_XNV() my_safemalloc(sizeof(XPVNV))
878 #define del_XNV(p) my_safefree(p)
880 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
881 #define del_XPVNV(p) my_safefree(p)
883 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
884 #define del_XPVAV(p) my_safefree(p)
886 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
887 #define del_XPVHV(p) my_safefree(p)
889 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
890 #define del_XPVMG(p) my_safefree(p)
892 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
893 #define del_XPVGV(p) my_safefree(p)
897 #define new_XNV() new_body_type(SVt_NV)
898 #define del_XNV(p) del_body_type(p, SVt_NV)
900 #define new_XPVNV() new_body_type(SVt_PVNV)
901 #define del_XPVNV(p) del_body_type(p, SVt_PVNV)
903 #define new_XPVAV() new_body_allocated(SVt_PVAV)
904 #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
906 #define new_XPVHV() new_body_allocated(SVt_PVHV)
907 #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
909 #define new_XPVMG() new_body_type(SVt_PVMG)
910 #define del_XPVMG(p) del_body_type(p, SVt_PVMG)
912 #define new_XPVGV() new_body_type(SVt_PVGV)
913 #define del_XPVGV(p) del_body_type(p, SVt_PVGV)
917 /* no arena for you! */
919 #define new_NOARENA(details) \
920 my_safemalloc((details)->size + (details)->offset)
921 #define new_NOARENAZ(details) \
922 my_safecalloc((details)->size + (details)->offset)
925 =for apidoc sv_upgrade
927 Upgrade an SV to a more complex form. Generally adds a new body type to the
928 SV, then copies across as much information as possible from the old body.
929 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
935 Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
940 const U32 old_type = SvTYPE(sv);
941 const struct body_details *const old_type_details
942 = bodies_by_type + old_type;
943 const struct body_details *new_type_details = bodies_by_type + new_type;
945 if (new_type != SVt_PV && SvIsCOW(sv)) {
946 sv_force_normal_flags(sv, 0);
949 if (old_type == new_type)
952 if (old_type > new_type)
953 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
954 (int)old_type, (int)new_type);
957 old_body = SvANY(sv);
959 /* Copying structures onto other structures that have been neatly zeroed
960 has a subtle gotcha. Consider XPVMG
962 +------+------+------+------+------+-------+-------+
963 | NV | CUR | LEN | IV | MAGIC | STASH |
964 +------+------+------+------+------+-------+-------+
967 where NVs are aligned to 8 bytes, so that sizeof that structure is
968 actually 32 bytes long, with 4 bytes of padding at the end:
970 +------+------+------+------+------+-------+-------+------+
971 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
972 +------+------+------+------+------+-------+-------+------+
973 0 4 8 12 16 20 24 28 32
975 so what happens if you allocate memory for this structure:
977 +------+------+------+------+------+-------+-------+------+------+...
978 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
979 +------+------+------+------+------+-------+-------+------+------+...
980 0 4 8 12 16 20 24 28 32 36
982 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
983 expect, because you copy the area marked ??? onto GP. Now, ??? may have
984 started out as zero once, but it's quite possible that it isn't. So now,
985 rather than a nicely zeroed GP, you have it pointing somewhere random.
988 (In fact, GP ends up pointing at a previous GP structure, because the
989 principle cause of the padding in XPVMG getting garbage is a copy of
990 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
992 So we are careful and work out the size of used parts of all the
999 if (new_type < SVt_PVIV) {
1000 new_type = (new_type == SVt_NV)
1001 ? SVt_PVNV : SVt_PVIV;
1002 new_type_details = bodies_by_type + new_type;
1006 if (new_type < SVt_PVNV) {
1007 new_type = SVt_PVNV;
1008 new_type_details = bodies_by_type + new_type;
1014 assert(new_type > SVt_PV);
1015 assert(SVt_IV < SVt_PV);
1016 assert(SVt_NV < SVt_PV);
1023 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1024 there's no way that it can be safely upgraded, because perl.c
1025 expects to Safefree(SvANY(PL_mess_sv)) */
1026 assert(sv != PL_mess_sv);
1027 /* This flag bit is used to mean other things in other scalar types.
1028 Given that it only has meaning inside the pad, it shouldn't be set
1029 on anything that can get upgraded. */
1030 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1033 if (old_type_details->cant_upgrade)
1034 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1037 SvFLAGS(sv) &= ~SVTYPEMASK;
1038 SvFLAGS(sv) |= new_type;
1042 Perl_croak(aTHX_ "Can't upgrade to undef");
1044 assert(old_type == SVt_NULL);
1045 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1049 assert(old_type == SVt_NULL);
1050 SvANY(sv) = new_XNV();
1054 assert(old_type == SVt_NULL);
1055 SvANY(sv) = &sv->sv_u.svu_rv;
1059 SvANY(sv) = new_XPVHV();
1062 HvTOTALKEYS(sv) = 0;
1067 SvANY(sv) = new_XPVAV();
1074 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1075 The target created by newSVrv also is, and it can have magic.
1076 However, it never has SvPVX set.
1078 if (old_type >= SVt_RV) {
1079 assert(SvPVX_const(sv) == 0);
1082 /* Could put this in the else clause below, as PVMG must have SvPVX
1083 0 already (the assertion above) */
1086 if (old_type >= SVt_PVMG) {
1087 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
1088 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1090 SvMAGIC_set(sv, NULL);
1091 SvSTASH_set(sv, NULL);
1097 /* XXX Is this still needed? Was it ever needed? Surely as there is
1098 no route from NV to PVIV, NOK can never be true */
1099 assert(!SvNOKp(sv));
1111 assert(new_type_details->size);
1112 /* We always allocated the full length item with PURIFY. To do this
1113 we fake things so that arena is false for all 16 types.. */
1114 if(new_type_details->arena) {
1115 /* This points to the start of the allocated area. */
1116 new_body_inline(new_body, new_type_details->size, new_type);
1117 Zero(new_body, new_type_details->size, char);
1118 new_body = ((char *)new_body) - new_type_details->offset;
1120 new_body = new_NOARENAZ(new_type_details);
1122 SvANY(sv) = new_body;
1124 if (old_type_details->copy) {
1125 Copy((char *)old_body + old_type_details->offset,
1126 (char *)new_body + old_type_details->offset,
1127 old_type_details->copy, char);
1130 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1131 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1132 * correct 0.0 for us. Otherwise, if the old body didn't have an
1133 * NV slot, but the new one does, then we need to initialise the
1134 * freshly created NV slot with whatever the correct bit pattern is
1136 if (old_type_details->zero_nv && !new_type_details->zero_nv)
1140 if (new_type == SVt_PVIO)
1141 IoPAGE_LEN(sv) = 60;
1142 if (old_type < SVt_RV)
1146 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1147 (unsigned long)new_type);
1150 if (old_type_details->size) {
1151 /* If the old body had an allocated size, then we need to free it. */
1153 my_safefree(old_body);
1155 del_body((void*)((char*)old_body + old_type_details->offset),
1156 &PL_body_roots[old_type]);
1162 =for apidoc sv_backoff
1164 Remove any string offset. You should normally use the C<SvOOK_off> macro
1171 Perl_sv_backoff(pTHX_ register SV *sv)
1174 assert(SvTYPE(sv) != SVt_PVHV);
1175 assert(SvTYPE(sv) != SVt_PVAV);
1177 const char * const s = SvPVX_const(sv);
1178 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1179 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1181 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1183 SvFLAGS(sv) &= ~SVf_OOK;
1190 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1191 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1192 Use the C<SvGROW> wrapper instead.
1198 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1202 #ifdef HAS_64K_LIMIT
1203 if (newlen >= 0x10000) {
1204 PerlIO_printf(Perl_debug_log,
1205 "Allocation too large: %"UVxf"\n", (UV)newlen);
1208 #endif /* HAS_64K_LIMIT */
1211 if (SvTYPE(sv) < SVt_PV) {
1212 sv_upgrade(sv, SVt_PV);
1213 s = SvPVX_mutable(sv);
1215 else if (SvOOK(sv)) { /* pv is offset? */
1217 s = SvPVX_mutable(sv);
1218 if (newlen > SvLEN(sv))
1219 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1220 #ifdef HAS_64K_LIMIT
1221 if (newlen >= 0x10000)
1226 s = SvPVX_mutable(sv);
1228 if (newlen > SvLEN(sv)) { /* need more room? */
1229 newlen = PERL_STRLEN_ROUNDUP(newlen);
1230 if (SvLEN(sv) && s) {
1232 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1238 s = saferealloc(s, newlen);
1241 s = safemalloc(newlen);
1242 if (SvPVX_const(sv) && SvCUR(sv)) {
1243 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1247 SvLEN_set(sv, newlen);
1253 =for apidoc sv_setiv
1255 Copies an integer into the given SV, upgrading first if necessary.
1256 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1262 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1265 SV_CHECK_THINKFIRST_COW_DROP(sv);
1266 switch (SvTYPE(sv)) {
1268 sv_upgrade(sv, SVt_IV);
1271 sv_upgrade(sv, SVt_PVNV);
1275 sv_upgrade(sv, SVt_PVIV);
1284 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1287 (void)SvIOK_only(sv); /* validate number */
1293 =for apidoc sv_setiv_mg
1295 Like C<sv_setiv>, but also handles 'set' magic.
1301 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1308 =for apidoc sv_setuv
1310 Copies an unsigned integer into the given SV, upgrading first if necessary.
1311 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1317 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1319 /* With these two if statements:
1320 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1323 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1325 If you wish to remove them, please benchmark to see what the effect is
1327 if (u <= (UV)IV_MAX) {
1328 sv_setiv(sv, (IV)u);
1337 =for apidoc sv_setuv_mg
1339 Like C<sv_setuv>, but also handles 'set' magic.
1345 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1354 =for apidoc sv_setnv
1356 Copies a double into the given SV, upgrading first if necessary.
1357 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1363 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1366 SV_CHECK_THINKFIRST_COW_DROP(sv);
1367 switch (SvTYPE(sv)) {
1370 sv_upgrade(sv, SVt_NV);
1375 sv_upgrade(sv, SVt_PVNV);
1384 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1388 (void)SvNOK_only(sv); /* validate number */
1393 =for apidoc sv_setnv_mg
1395 Like C<sv_setnv>, but also handles 'set' magic.
1401 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1407 /* Print an "isn't numeric" warning, using a cleaned-up,
1408 * printable version of the offending string
1412 S_not_a_number(pTHX_ SV *sv)
1420 dsv = sv_2mortal(newSVpvs(""));
1421 pv = sv_uni_display(dsv, sv, 10, 0);
1424 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1425 /* each *s can expand to 4 chars + "...\0",
1426 i.e. need room for 8 chars */
1428 const char *s = SvPVX_const(sv);
1429 const char * const end = s + SvCUR(sv);
1430 for ( ; s < end && d < limit; s++ ) {
1432 if (ch & 128 && !isPRINT_LC(ch)) {
1441 else if (ch == '\r') {
1445 else if (ch == '\f') {
1449 else if (ch == '\\') {
1453 else if (ch == '\0') {
1457 else if (isPRINT_LC(ch))
1474 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1475 "Argument \"%s\" isn't numeric in %s", pv,
1478 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1479 "Argument \"%s\" isn't numeric", pv);
1483 =for apidoc looks_like_number
1485 Test if the content of an SV looks like a number (or is a number).
1486 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1487 non-numeric warning), even if your atof() doesn't grok them.
1493 Perl_looks_like_number(pTHX_ SV *sv)
1495 register const char *sbegin;
1499 sbegin = SvPVX_const(sv);
1502 else if (SvPOKp(sv))
1503 sbegin = SvPV_const(sv, len);
1505 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1506 return grok_number(sbegin, len, NULL);
1509 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1510 until proven guilty, assume that things are not that bad... */
1515 As 64 bit platforms often have an NV that doesn't preserve all bits of
1516 an IV (an assumption perl has been based on to date) it becomes necessary
1517 to remove the assumption that the NV always carries enough precision to
1518 recreate the IV whenever needed, and that the NV is the canonical form.
1519 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1520 precision as a side effect of conversion (which would lead to insanity
1521 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1522 1) to distinguish between IV/UV/NV slots that have cached a valid
1523 conversion where precision was lost and IV/UV/NV slots that have a
1524 valid conversion which has lost no precision
1525 2) to ensure that if a numeric conversion to one form is requested that
1526 would lose precision, the precise conversion (or differently
1527 imprecise conversion) is also performed and cached, to prevent
1528 requests for different numeric formats on the same SV causing
1529 lossy conversion chains. (lossless conversion chains are perfectly
1534 SvIOKp is true if the IV slot contains a valid value
1535 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1536 SvNOKp is true if the NV slot contains a valid value
1537 SvNOK is true only if the NV value is accurate
1540 while converting from PV to NV, check to see if converting that NV to an
1541 IV(or UV) would lose accuracy over a direct conversion from PV to
1542 IV(or UV). If it would, cache both conversions, return NV, but mark
1543 SV as IOK NOKp (ie not NOK).
1545 While converting from PV to IV, check to see if converting that IV to an
1546 NV would lose accuracy over a direct conversion from PV to NV. If it
1547 would, cache both conversions, flag similarly.
1549 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1550 correctly because if IV & NV were set NV *always* overruled.
1551 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1552 changes - now IV and NV together means that the two are interchangeable:
1553 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1555 The benefit of this is that operations such as pp_add know that if
1556 SvIOK is true for both left and right operands, then integer addition
1557 can be used instead of floating point (for cases where the result won't
1558 overflow). Before, floating point was always used, which could lead to
1559 loss of precision compared with integer addition.
1561 * making IV and NV equal status should make maths accurate on 64 bit
1563 * may speed up maths somewhat if pp_add and friends start to use
1564 integers when possible instead of fp. (Hopefully the overhead in
1565 looking for SvIOK and checking for overflow will not outweigh the
1566 fp to integer speedup)
1567 * will slow down integer operations (callers of SvIV) on "inaccurate"
1568 values, as the change from SvIOK to SvIOKp will cause a call into
1569 sv_2iv each time rather than a macro access direct to the IV slot
1570 * should speed up number->string conversion on integers as IV is
1571 favoured when IV and NV are equally accurate
1573 ####################################################################
1574 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1575 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1576 On the other hand, SvUOK is true iff UV.
1577 ####################################################################
1579 Your mileage will vary depending your CPU's relative fp to integer
1583 #ifndef NV_PRESERVES_UV
1584 # define IS_NUMBER_UNDERFLOW_IV 1
1585 # define IS_NUMBER_UNDERFLOW_UV 2
1586 # define IS_NUMBER_IV_AND_UV 2
1587 # define IS_NUMBER_OVERFLOW_IV 4
1588 # define IS_NUMBER_OVERFLOW_UV 5
1590 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1592 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1594 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1597 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));
1598 if (SvNVX(sv) < (NV)IV_MIN) {
1599 (void)SvIOKp_on(sv);
1601 SvIV_set(sv, IV_MIN);
1602 return IS_NUMBER_UNDERFLOW_IV;
1604 if (SvNVX(sv) > (NV)UV_MAX) {
1605 (void)SvIOKp_on(sv);
1608 SvUV_set(sv, UV_MAX);
1609 return IS_NUMBER_OVERFLOW_UV;
1611 (void)SvIOKp_on(sv);
1613 /* Can't use strtol etc to convert this string. (See truth table in
1615 if (SvNVX(sv) <= (UV)IV_MAX) {
1616 SvIV_set(sv, I_V(SvNVX(sv)));
1617 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1618 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1620 /* Integer is imprecise. NOK, IOKp */
1622 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1625 SvUV_set(sv, U_V(SvNVX(sv)));
1626 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1627 if (SvUVX(sv) == UV_MAX) {
1628 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1629 possibly be preserved by NV. Hence, it must be overflow.
1631 return IS_NUMBER_OVERFLOW_UV;
1633 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1635 /* Integer is imprecise. NOK, IOKp */
1637 return IS_NUMBER_OVERFLOW_IV;
1639 #endif /* !NV_PRESERVES_UV*/
1642 S_sv_2iuv_common(pTHX_ SV *sv) {
1645 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1646 * without also getting a cached IV/UV from it at the same time
1647 * (ie PV->NV conversion should detect loss of accuracy and cache
1648 * IV or UV at same time to avoid this. */
1649 /* IV-over-UV optimisation - choose to cache IV if possible */
1651 if (SvTYPE(sv) == SVt_NV)
1652 sv_upgrade(sv, SVt_PVNV);
1654 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1655 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1656 certainly cast into the IV range at IV_MAX, whereas the correct
1657 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1659 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1660 SvIV_set(sv, I_V(SvNVX(sv)));
1661 if (SvNVX(sv) == (NV) SvIVX(sv)
1662 #ifndef NV_PRESERVES_UV
1663 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1664 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1665 /* Don't flag it as "accurately an integer" if the number
1666 came from a (by definition imprecise) NV operation, and
1667 we're outside the range of NV integer precision */
1670 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1671 DEBUG_c(PerlIO_printf(Perl_debug_log,
1672 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
1678 /* IV not precise. No need to convert from PV, as NV
1679 conversion would already have cached IV if it detected
1680 that PV->IV would be better than PV->NV->IV
1681 flags already correct - don't set public IOK. */
1682 DEBUG_c(PerlIO_printf(Perl_debug_log,
1683 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
1688 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1689 but the cast (NV)IV_MIN rounds to a the value less (more
1690 negative) than IV_MIN which happens to be equal to SvNVX ??
1691 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1692 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1693 (NV)UVX == NVX are both true, but the values differ. :-(
1694 Hopefully for 2s complement IV_MIN is something like
1695 0x8000000000000000 which will be exact. NWC */
1698 SvUV_set(sv, U_V(SvNVX(sv)));
1700 (SvNVX(sv) == (NV) SvUVX(sv))
1701 #ifndef NV_PRESERVES_UV
1702 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1703 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1704 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1705 /* Don't flag it as "accurately an integer" if the number
1706 came from a (by definition imprecise) NV operation, and
1707 we're outside the range of NV integer precision */
1712 DEBUG_c(PerlIO_printf(Perl_debug_log,
1713 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1719 else if (SvPOKp(sv) && SvLEN(sv)) {
1721 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
1722 /* We want to avoid a possible problem when we cache an IV/ a UV which
1723 may be later translated to an NV, and the resulting NV is not
1724 the same as the direct translation of the initial string
1725 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
1726 be careful to ensure that the value with the .456 is around if the
1727 NV value is requested in the future).
1729 This means that if we cache such an IV/a UV, we need to cache the
1730 NV as well. Moreover, we trade speed for space, and do not
1731 cache the NV if we are sure it's not needed.
1734 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
1735 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1736 == IS_NUMBER_IN_UV) {
1737 /* It's definitely an integer, only upgrade to PVIV */
1738 if (SvTYPE(sv) < SVt_PVIV)
1739 sv_upgrade(sv, SVt_PVIV);
1741 } else if (SvTYPE(sv) < SVt_PVNV)
1742 sv_upgrade(sv, SVt_PVNV);
1744 /* If NVs preserve UVs then we only use the UV value if we know that
1745 we aren't going to call atof() below. If NVs don't preserve UVs
1746 then the value returned may have more precision than atof() will
1747 return, even though value isn't perfectly accurate. */
1748 if ((numtype & (IS_NUMBER_IN_UV
1749 #ifdef NV_PRESERVES_UV
1752 )) == IS_NUMBER_IN_UV) {
1753 /* This won't turn off the public IOK flag if it was set above */
1754 (void)SvIOKp_on(sv);
1756 if (!(numtype & IS_NUMBER_NEG)) {
1758 if (value <= (UV)IV_MAX) {
1759 SvIV_set(sv, (IV)value);
1761 /* it didn't overflow, and it was positive. */
1762 SvUV_set(sv, value);
1766 /* 2s complement assumption */
1767 if (value <= (UV)IV_MIN) {
1768 SvIV_set(sv, -(IV)value);
1770 /* Too negative for an IV. This is a double upgrade, but
1771 I'm assuming it will be rare. */
1772 if (SvTYPE(sv) < SVt_PVNV)
1773 sv_upgrade(sv, SVt_PVNV);
1777 SvNV_set(sv, -(NV)value);
1778 SvIV_set(sv, IV_MIN);
1782 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
1783 will be in the previous block to set the IV slot, and the next
1784 block to set the NV slot. So no else here. */
1786 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1787 != IS_NUMBER_IN_UV) {
1788 /* It wasn't an (integer that doesn't overflow the UV). */
1789 SvNV_set(sv, Atof(SvPVX_const(sv)));
1791 if (! numtype && ckWARN(WARN_NUMERIC))
1794 #if defined(USE_LONG_DOUBLE)
1795 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1796 PTR2UV(sv), SvNVX(sv)));
1798 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
1799 PTR2UV(sv), SvNVX(sv)));
1802 #ifdef NV_PRESERVES_UV
1803 (void)SvIOKp_on(sv);
1805 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1806 SvIV_set(sv, I_V(SvNVX(sv)));
1807 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1810 /* Integer is imprecise. NOK, IOKp */
1812 /* UV will not work better than IV */
1814 if (SvNVX(sv) > (NV)UV_MAX) {
1816 /* Integer is inaccurate. NOK, IOKp, is UV */
1817 SvUV_set(sv, UV_MAX);
1819 SvUV_set(sv, U_V(SvNVX(sv)));
1820 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
1821 NV preservse UV so can do correct comparison. */
1822 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1825 /* Integer is imprecise. NOK, IOKp, is UV */
1830 #else /* NV_PRESERVES_UV */
1831 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1832 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
1833 /* The IV/UV slot will have been set from value returned by
1834 grok_number above. The NV slot has just been set using
1837 assert (SvIOKp(sv));
1839 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1840 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1841 /* Small enough to preserve all bits. */
1842 (void)SvIOKp_on(sv);
1844 SvIV_set(sv, I_V(SvNVX(sv)));
1845 if ((NV)(SvIVX(sv)) == SvNVX(sv))
1847 /* Assumption: first non-preserved integer is < IV_MAX,
1848 this NV is in the preserved range, therefore: */
1849 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1851 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);
1855 0 0 already failed to read UV.
1856 0 1 already failed to read UV.
1857 1 0 you won't get here in this case. IV/UV
1858 slot set, public IOK, Atof() unneeded.
1859 1 1 already read UV.
1860 so there's no point in sv_2iuv_non_preserve() attempting
1861 to use atol, strtol, strtoul etc. */
1862 sv_2iuv_non_preserve (sv, numtype);
1865 #endif /* NV_PRESERVES_UV */
1869 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1870 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
1873 if (SvTYPE(sv) < SVt_IV)
1874 /* Typically the caller expects that sv_any is not NULL now. */
1875 sv_upgrade(sv, SVt_IV);
1876 /* Return 0 from the caller. */
1883 =for apidoc sv_2iv_flags
1885 Return the integer value of an SV, doing any necessary string
1886 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
1887 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
1893 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
1898 if (SvGMAGICAL(sv)) {
1899 if (flags & SV_GMAGIC)
1904 return I_V(SvNVX(sv));
1906 if (SvPOKp(sv) && SvLEN(sv)) {
1909 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
1911 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1912 == IS_NUMBER_IN_UV) {
1913 /* It's definitely an integer */
1914 if (numtype & IS_NUMBER_NEG) {
1915 if (value < (UV)IV_MIN)
1918 if (value < (UV)IV_MAX)
1923 if (ckWARN(WARN_NUMERIC))
1926 return I_V(Atof(SvPVX_const(sv)));
1931 assert(SvTYPE(sv) >= SVt_PVMG);
1932 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
1933 } else if (SvTHINKFIRST(sv)) {
1937 SV * const tmpstr=AMG_CALLun(sv,numer);
1938 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
1939 return SvIV(tmpstr);
1942 return PTR2IV(SvRV(sv));
1945 sv_force_normal_flags(sv, 0);
1947 if (SvREADONLY(sv) && !SvOK(sv)) {
1948 if (ckWARN(WARN_UNINITIALIZED))
1954 if (S_sv_2iuv_common(aTHX_ sv))
1957 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1958 PTR2UV(sv),SvIVX(sv)));
1959 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1963 =for apidoc sv_2uv_flags
1965 Return the unsigned integer value of an SV, doing any necessary string
1966 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
1967 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
1973 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
1978 if (SvGMAGICAL(sv)) {
1979 if (flags & SV_GMAGIC)
1984 return U_V(SvNVX(sv));
1985 if (SvPOKp(sv) && SvLEN(sv)) {
1988 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
1990 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1991 == IS_NUMBER_IN_UV) {
1992 /* It's definitely an integer */
1993 if (!(numtype & IS_NUMBER_NEG))
1997 if (ckWARN(WARN_NUMERIC))
2000 return U_V(Atof(SvPVX_const(sv)));
2005 assert(SvTYPE(sv) >= SVt_PVMG);
2006 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2007 } else if (SvTHINKFIRST(sv)) {
2011 SV *const tmpstr = AMG_CALLun(sv,numer);
2012 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2013 return SvUV(tmpstr);
2016 return PTR2UV(SvRV(sv));
2019 sv_force_normal_flags(sv, 0);
2021 if (SvREADONLY(sv) && !SvOK(sv)) {
2022 if (ckWARN(WARN_UNINITIALIZED))
2028 if (S_sv_2iuv_common(aTHX_ sv))
2032 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2033 PTR2UV(sv),SvUVX(sv)));
2034 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2040 Return the num value of an SV, doing any necessary string or integer
2041 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2048 Perl_sv_2nv(pTHX_ register SV *sv)
2053 if (SvGMAGICAL(sv)) {
2057 if (SvPOKp(sv) && SvLEN(sv)) {
2058 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2059 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2061 return Atof(SvPVX_const(sv));
2065 return (NV)SvUVX(sv);
2067 return (NV)SvIVX(sv);
2072 assert(SvTYPE(sv) >= SVt_PVMG);
2073 /* This falls through to the report_uninit near the end of the
2075 } else if (SvTHINKFIRST(sv)) {
2079 SV *const tmpstr = AMG_CALLun(sv,numer);
2080 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2081 return SvNV(tmpstr);
2084 return PTR2NV(SvRV(sv));
2087 sv_force_normal_flags(sv, 0);
2089 if (SvREADONLY(sv) && !SvOK(sv)) {
2090 if (ckWARN(WARN_UNINITIALIZED))
2095 if (SvTYPE(sv) < SVt_NV) {
2096 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2097 sv_upgrade(sv, SVt_NV);
2098 #ifdef USE_LONG_DOUBLE
2100 STORE_NUMERIC_LOCAL_SET_STANDARD();
2101 PerlIO_printf(Perl_debug_log,
2102 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2103 PTR2UV(sv), SvNVX(sv));
2104 RESTORE_NUMERIC_LOCAL();
2108 STORE_NUMERIC_LOCAL_SET_STANDARD();
2109 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2110 PTR2UV(sv), SvNVX(sv));
2111 RESTORE_NUMERIC_LOCAL();
2115 else if (SvTYPE(sv) < SVt_PVNV)
2116 sv_upgrade(sv, SVt_PVNV);
2121 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2122 #ifdef NV_PRESERVES_UV
2125 /* Only set the public NV OK flag if this NV preserves the IV */
2126 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2127 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2128 : (SvIVX(sv) == I_V(SvNVX(sv))))
2134 else if (SvPOKp(sv) && SvLEN(sv)) {
2136 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2137 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2139 #ifdef NV_PRESERVES_UV
2140 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2141 == IS_NUMBER_IN_UV) {
2142 /* It's definitely an integer */
2143 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2145 SvNV_set(sv, Atof(SvPVX_const(sv)));
2148 SvNV_set(sv, Atof(SvPVX_const(sv)));
2149 /* Only set the public NV OK flag if this NV preserves the value in
2150 the PV at least as well as an IV/UV would.
2151 Not sure how to do this 100% reliably. */
2152 /* if that shift count is out of range then Configure's test is
2153 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2155 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2156 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2157 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2158 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2159 /* Can't use strtol etc to convert this string, so don't try.
2160 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2163 /* value has been set. It may not be precise. */
2164 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2165 /* 2s complement assumption for (UV)IV_MIN */
2166 SvNOK_on(sv); /* Integer is too negative. */
2171 if (numtype & IS_NUMBER_NEG) {
2172 SvIV_set(sv, -(IV)value);
2173 } else if (value <= (UV)IV_MAX) {
2174 SvIV_set(sv, (IV)value);
2176 SvUV_set(sv, value);
2180 if (numtype & IS_NUMBER_NOT_INT) {
2181 /* I believe that even if the original PV had decimals,
2182 they are lost beyond the limit of the FP precision.
2183 However, neither is canonical, so both only get p
2184 flags. NWC, 2000/11/25 */
2185 /* Both already have p flags, so do nothing */
2187 const NV nv = SvNVX(sv);
2188 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2189 if (SvIVX(sv) == I_V(nv)) {
2192 /* It had no "." so it must be integer. */
2196 /* between IV_MAX and NV(UV_MAX).
2197 Could be slightly > UV_MAX */
2199 if (numtype & IS_NUMBER_NOT_INT) {
2200 /* UV and NV both imprecise. */
2202 const UV nv_as_uv = U_V(nv);
2204 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2213 #endif /* NV_PRESERVES_UV */
2216 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2218 assert (SvTYPE(sv) >= SVt_NV);
2219 /* Typically the caller expects that sv_any is not NULL now. */
2220 /* XXX Ilya implies that this is a bug in callers that assume this
2221 and ideally should be fixed. */
2224 #if defined(USE_LONG_DOUBLE)
2226 STORE_NUMERIC_LOCAL_SET_STANDARD();
2227 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2228 PTR2UV(sv), SvNVX(sv));
2229 RESTORE_NUMERIC_LOCAL();
2233 STORE_NUMERIC_LOCAL_SET_STANDARD();
2234 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2235 PTR2UV(sv), SvNVX(sv));
2236 RESTORE_NUMERIC_LOCAL();
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);
2274 /* stringify_regexp(): private routine for use by sv_2pv_flags(): converts
2275 * a regexp to its stringified form.
2279 S_stringify_regexp(pTHX_ SV *sv, MAGIC *mg, STRLEN *lp) {
2281 const regexp * const re = (regexp *)mg->mg_obj;
2284 const char *fptr = "msix";
2289 bool need_newline = 0;
2290 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
2292 while((ch = *fptr++)) {
2294 reflags[left++] = ch;
2297 reflags[right--] = ch;
2302 reflags[left] = '-';
2306 mg->mg_len = re->prelen + 4 + left;
2308 * If /x was used, we have to worry about a regex ending with a
2309 * comment later being embedded within another regex. If so, we don't
2310 * want this regex's "commentization" to leak out to the right part of
2311 * the enclosing regex, we must cap it with a newline.
2313 * So, if /x was used, we scan backwards from the end of the regex. If
2314 * we find a '#' before we find a newline, we need to add a newline
2315 * ourself. If we find a '\n' first (or if we don't find '#' or '\n'),
2316 * we don't need to add anything. -jfriedl
2318 if (PMf_EXTENDED & re->reganch) {
2319 const char *endptr = re->precomp + re->prelen;
2320 while (endptr >= re->precomp) {
2321 const char c = *(endptr--);
2323 break; /* don't need another */
2325 /* we end while in a comment, so we need a newline */
2326 mg->mg_len++; /* save space for it */
2327 need_newline = 1; /* note to add it */
2333 Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
2334 mg->mg_ptr[0] = '(';
2335 mg->mg_ptr[1] = '?';
2336 Copy(reflags, mg->mg_ptr+2, left, char);
2337 *(mg->mg_ptr+left+2) = ':';
2338 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2340 mg->mg_ptr[mg->mg_len - 2] = '\n';
2341 mg->mg_ptr[mg->mg_len - 1] = ')';
2342 mg->mg_ptr[mg->mg_len] = 0;
2344 PL_reginterp_cnt += re->program[0].next_off;
2346 if (re->reganch & ROPT_UTF8)
2356 =for apidoc sv_2pv_flags
2358 Returns a pointer to the string value of an SV, and sets *lp to its length.
2359 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2361 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2362 usually end up here too.
2368 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2378 if (SvGMAGICAL(sv)) {
2379 if (flags & SV_GMAGIC)
2384 if (flags & SV_MUTABLE_RETURN)
2385 return SvPVX_mutable(sv);
2386 if (flags & SV_CONST_RETURN)
2387 return (char *)SvPVX_const(sv);
2390 if (SvIOKp(sv) || SvNOKp(sv)) {
2391 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2395 len = SvIsUV(sv) ? my_sprintf(tbuf,"%"UVuf, (UV)SvUVX(sv))
2396 : my_sprintf(tbuf,"%"IVdf, (IV)SvIVX(sv));
2398 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2401 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2402 /* Sneaky stuff here */
2403 SV * const tsv = newSVpvn(tbuf, len);
2413 #ifdef FIXNEGATIVEZERO
2414 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2420 SvUPGRADE(sv, SVt_PV);
2423 s = SvGROW_mutable(sv, len + 1);
2426 return memcpy(s, tbuf, len + 1);
2432 assert(SvTYPE(sv) >= SVt_PVMG);
2433 /* This falls through to the report_uninit near the end of the
2435 } else if (SvTHINKFIRST(sv)) {
2439 SV *const tmpstr = AMG_CALLun(sv,string);
2440 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2442 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2446 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2447 if (flags & SV_CONST_RETURN) {
2448 pv = (char *) SvPVX_const(tmpstr);
2450 pv = (flags & SV_MUTABLE_RETURN)
2451 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2454 *lp = SvCUR(tmpstr);
2456 pv = sv_2pv_flags(tmpstr, lp, flags);
2468 const SV *const referent = (SV*)SvRV(sv);
2471 tsv = sv_2mortal(newSVpvs("NULLREF"));
2472 } else if (SvTYPE(referent) == SVt_PVMG
2473 && ((SvFLAGS(referent) &
2474 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2475 == (SVs_OBJECT|SVs_SMG))
2476 && (mg = mg_find(referent, PERL_MAGIC_qr))) {
2477 return stringify_regexp(sv, mg, lp);
2479 const char *const typestr = sv_reftype(referent, 0);
2481 tsv = sv_newmortal();
2482 if (SvOBJECT(referent)) {
2483 const char *const name = HvNAME_get(SvSTASH(referent));
2484 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
2485 name ? name : "__ANON__" , typestr,
2489 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr,
2497 if (SvREADONLY(sv) && !SvOK(sv)) {
2498 if (ckWARN(WARN_UNINITIALIZED))
2505 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2506 /* I'm assuming that if both IV and NV are equally valid then
2507 converting the IV is going to be more efficient */
2508 const U32 isIOK = SvIOK(sv);
2509 const U32 isUIOK = SvIsUV(sv);
2510 char buf[TYPE_CHARS(UV)];
2513 if (SvTYPE(sv) < SVt_PVIV)
2514 sv_upgrade(sv, SVt_PVIV);
2515 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2516 /* inlined from sv_setpvn */
2517 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
2518 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
2519 SvCUR_set(sv, ebuf - ptr);
2529 else if (SvNOKp(sv)) {
2530 const int olderrno = errno;
2531 if (SvTYPE(sv) < SVt_PVNV)
2532 sv_upgrade(sv, SVt_PVNV);
2533 /* The +20 is pure guesswork. Configure test needed. --jhi */
2534 s = SvGROW_mutable(sv, NV_DIG + 20);
2535 /* some Xenix systems wipe out errno here */
2537 if (SvNVX(sv) == 0.0)
2538 (void)strcpy(s,"0");
2542 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2545 #ifdef FIXNEGATIVEZERO
2546 if (*s == '-' && s[1] == '0' && !s[2])
2556 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2560 if (SvTYPE(sv) < SVt_PV)
2561 /* Typically the caller expects that sv_any is not NULL now. */
2562 sv_upgrade(sv, SVt_PV);
2566 const STRLEN len = s - SvPVX_const(sv);
2572 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2573 PTR2UV(sv),SvPVX_const(sv)));
2574 if (flags & SV_CONST_RETURN)
2575 return (char *)SvPVX_const(sv);
2576 if (flags & SV_MUTABLE_RETURN)
2577 return SvPVX_mutable(sv);
2582 =for apidoc sv_copypv
2584 Copies a stringified representation of the source SV into the
2585 destination SV. Automatically performs any necessary mg_get and
2586 coercion of numeric values into strings. Guaranteed to preserve
2587 UTF-8 flag even from overloaded objects. Similar in nature to
2588 sv_2pv[_flags] but operates directly on an SV instead of just the
2589 string. Mostly uses sv_2pv_flags to do its work, except when that
2590 would lose the UTF-8'ness of the PV.
2596 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
2599 const char * const s = SvPV_const(ssv,len);
2600 sv_setpvn(dsv,s,len);
2608 =for apidoc sv_2pvbyte
2610 Return a pointer to the byte-encoded representation of the SV, and set *lp
2611 to its length. May cause the SV to be downgraded from UTF-8 as a
2614 Usually accessed via the C<SvPVbyte> macro.
2620 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2622 sv_utf8_downgrade(sv,0);
2623 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2627 =for apidoc sv_2pvutf8
2629 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
2630 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
2632 Usually accessed via the C<SvPVutf8> macro.
2638 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2640 sv_utf8_upgrade(sv);
2641 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2646 =for apidoc sv_2bool
2648 This function is only called on magical items, and is only used by
2649 sv_true() or its macro equivalent.
2655 Perl_sv_2bool(pTHX_ register SV *sv)
2664 SV * const tmpsv = AMG_CALLun(sv,bool_);
2665 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2666 return (bool)SvTRUE(tmpsv);
2668 return SvRV(sv) != 0;
2671 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
2673 (*sv->sv_u.svu_pv > '0' ||
2674 Xpvtmp->xpv_cur > 1 ||
2675 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
2682 return SvIVX(sv) != 0;
2685 return SvNVX(sv) != 0.0;
2693 =for apidoc sv_utf8_upgrade
2695 Converts the PV of an SV to its UTF-8-encoded form.
2696 Forces the SV to string form if it is not already.
2697 Always sets the SvUTF8 flag to avoid future validity checks even
2698 if all the bytes have hibit clear.
2700 This is not as a general purpose byte encoding to Unicode interface:
2701 use the Encode extension for that.
2703 =for apidoc sv_utf8_upgrade_flags
2705 Converts the PV of an SV to its UTF-8-encoded form.
2706 Forces the SV to string form if it is not already.
2707 Always sets the SvUTF8 flag to avoid future validity checks even
2708 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
2709 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
2710 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
2712 This is not as a general purpose byte encoding to Unicode interface:
2713 use the Encode extension for that.
2719 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
2722 if (sv == &PL_sv_undef)
2726 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
2727 (void) sv_2pv_flags(sv,&len, flags);
2731 (void) SvPV_force(sv,len);
2740 sv_force_normal_flags(sv, 0);
2743 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
2744 sv_recode_to_utf8(sv, PL_encoding);
2745 else { /* Assume Latin-1/EBCDIC */
2746 /* This function could be much more efficient if we
2747 * had a FLAG in SVs to signal if there are any hibit
2748 * chars in the PV. Given that there isn't such a flag
2749 * make the loop as fast as possible. */
2750 const U8 * const s = (U8 *) SvPVX_const(sv);
2751 const U8 * const e = (U8 *) SvEND(sv);
2756 /* Check for hi bit */
2757 if (!NATIVE_IS_INVARIANT(ch)) {
2758 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
2759 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
2761 SvPV_free(sv); /* No longer using what was there before. */
2762 SvPV_set(sv, (char*)recoded);
2763 SvCUR_set(sv, len - 1);
2764 SvLEN_set(sv, len); /* No longer know the real size. */
2768 /* Mark as UTF-8 even if no hibit - saves scanning loop */
2775 =for apidoc sv_utf8_downgrade
2777 Attempts to convert the PV of an SV from characters to bytes.
2778 If the PV contains a character beyond byte, this conversion will fail;
2779 in this case, either returns false or, if C<fail_ok> is not
2782 This is not as a general purpose Unicode to byte encoding interface:
2783 use the Encode extension for that.
2789 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2792 if (SvPOKp(sv) && SvUTF8(sv)) {
2798 sv_force_normal_flags(sv, 0);
2800 s = (U8 *) SvPV(sv, len);
2801 if (!utf8_to_bytes(s, &len)) {
2806 Perl_croak(aTHX_ "Wide character in %s",
2809 Perl_croak(aTHX_ "Wide character");
2820 =for apidoc sv_utf8_encode
2822 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
2823 flag off so that it looks like octets again.
2829 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2831 (void) sv_utf8_upgrade(sv);
2833 sv_force_normal_flags(sv, 0);
2835 if (SvREADONLY(sv)) {
2836 Perl_croak(aTHX_ PL_no_modify);
2842 =for apidoc sv_utf8_decode
2844 If the PV of the SV is an octet sequence in UTF-8
2845 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
2846 so that it looks like a character. If the PV contains only single-byte
2847 characters, the C<SvUTF8> flag stays being off.
2848 Scans PV for validity and returns false if the PV is invalid UTF-8.
2854 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2860 /* The octets may have got themselves encoded - get them back as
2863 if (!sv_utf8_downgrade(sv, TRUE))
2866 /* it is actually just a matter of turning the utf8 flag on, but
2867 * we want to make sure everything inside is valid utf8 first.
2869 c = (const U8 *) SvPVX_const(sv);
2870 if (!is_utf8_string(c, SvCUR(sv)+1))
2872 e = (const U8 *) SvEND(sv);
2875 if (!UTF8_IS_INVARIANT(ch)) {
2885 =for apidoc sv_setsv
2887 Copies the contents of the source SV C<ssv> into the destination SV
2888 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
2889 function if the source SV needs to be reused. Does not handle 'set' magic.
2890 Loosely speaking, it performs a copy-by-value, obliterating any previous
2891 content of the destination.
2893 You probably want to use one of the assortment of wrappers, such as
2894 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
2895 C<SvSetMagicSV_nosteal>.
2897 =for apidoc sv_setsv_flags
2899 Copies the contents of the source SV C<ssv> into the destination SV
2900 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
2901 function if the source SV needs to be reused. Does not handle 'set' magic.
2902 Loosely speaking, it performs a copy-by-value, obliterating any previous
2903 content of the destination.
2904 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
2905 C<ssv> if appropriate, else not. If the C<flags> parameter has the
2906 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
2907 and C<sv_setsv_nomg> are implemented in terms of this function.
2909 You probably want to use one of the assortment of wrappers, such as
2910 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
2911 C<SvSetMagicSV_nosteal>.
2913 This is the primary function for copying scalars, and most other
2914 copy-ish functions and macros use this underneath.
2920 S_glob_assign(pTHX_ SV *dstr, SV *sstr, const int dtype)
2922 if (dtype != SVt_PVGV) {
2923 const char * const name = GvNAME(sstr);
2924 const STRLEN len = GvNAMELEN(sstr);
2925 /* don't upgrade SVt_PVLV: it can hold a glob */
2926 if (dtype != SVt_PVLV)
2927 sv_upgrade(dstr, SVt_PVGV);
2928 sv_magic(dstr, dstr, PERL_MAGIC_glob, NULL, 0);
2929 GvSTASH(dstr) = GvSTASH(sstr);
2931 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
2932 GvNAME(dstr) = savepvn(name, len);
2933 GvNAMELEN(dstr) = len;
2934 SvFAKE_on(dstr); /* can coerce to non-glob */
2937 #ifdef GV_UNIQUE_CHECK
2938 if (GvUNIQUE((GV*)dstr)) {
2939 Perl_croak(aTHX_ PL_no_modify);
2943 (void)SvOK_off(dstr);
2944 GvINTRO_off(dstr); /* one-shot flag */
2946 GvGP(dstr) = gp_ref(GvGP(sstr));
2947 if (SvTAINTED(sstr))
2949 if (GvIMPORTED(dstr) != GVf_IMPORTED
2950 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2952 GvIMPORTED_on(dstr);
2959 S_pvgv_assign(pTHX_ SV *dstr, SV *sstr) {
2960 SV * const sref = SvREFCNT_inc(SvRV(sstr));
2962 const int intro = GvINTRO(dstr);
2964 #ifdef GV_UNIQUE_CHECK
2965 if (GvUNIQUE((GV*)dstr)) {
2966 Perl_croak(aTHX_ PL_no_modify);
2971 GvINTRO_off(dstr); /* one-shot flag */
2972 GvLINE(dstr) = CopLINE(PL_curcop);
2973 GvEGV(dstr) = (GV*)dstr;
2976 switch (SvTYPE(sref)) {
2979 SAVEGENERICSV(GvAV(dstr));
2981 dref = (SV*)GvAV(dstr);
2982 GvAV(dstr) = (AV*)sref;
2983 if (!GvIMPORTED_AV(dstr)
2984 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2986 GvIMPORTED_AV_on(dstr);
2991 SAVEGENERICSV(GvHV(dstr));
2993 dref = (SV*)GvHV(dstr);
2994 GvHV(dstr) = (HV*)sref;
2995 if (!GvIMPORTED_HV(dstr)
2996 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2998 GvIMPORTED_HV_on(dstr);
3003 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3004 SvREFCNT_dec(GvCV(dstr));
3006 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3007 PL_sub_generation++;
3009 SAVEGENERICSV(GvCV(dstr));
3012 dref = (SV*)GvCV(dstr);
3013 if (GvCV(dstr) != (CV*)sref) {
3014 CV* const cv = GvCV(dstr);
3016 if (!GvCVGEN((GV*)dstr) &&
3017 (CvROOT(cv) || CvXSUB(cv)))
3019 /* Redefining a sub - warning is mandatory if
3020 it was a const and its value changed. */
3021 if (CvCONST(cv) && CvCONST((CV*)sref)
3022 && cv_const_sv(cv) == cv_const_sv((CV*)sref)) {
3023 /* They are 2 constant subroutines generated from
3024 the same constant. This probably means that
3025 they are really the "same" proxy subroutine
3026 instantiated in 2 places. Most likely this is
3027 when a constant is exported twice. Don't warn.
3030 else if (ckWARN(WARN_REDEFINE)
3032 && (!CvCONST((CV*)sref)
3033 || sv_cmp(cv_const_sv(cv),
3034 cv_const_sv((CV*)sref))))) {
3035 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3037 ? "Constant subroutine %s::%s redefined"
3038 : "Subroutine %s::%s redefined",
3039 HvNAME_get(GvSTASH((GV*)dstr)),
3040 GvENAME((GV*)dstr));
3044 cv_ckproto(cv, (GV*)dstr,
3045 SvPOK(sref) ? SvPVX_const(sref) : NULL);
3047 GvCV(dstr) = (CV*)sref;
3048 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3049 GvASSUMECV_on(dstr);
3050 PL_sub_generation++;
3052 if (!GvIMPORTED_CV(dstr) && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3053 GvIMPORTED_CV_on(dstr);
3058 SAVEGENERICSV(GvIOp(dstr));
3060 dref = (SV*)GvIOp(dstr);
3061 GvIOp(dstr) = (IO*)sref;
3065 SAVEGENERICSV(GvFORM(dstr));
3067 dref = (SV*)GvFORM(dstr);
3068 GvFORM(dstr) = (CV*)sref;
3072 SAVEGENERICSV(GvSV(dstr));
3074 dref = (SV*)GvSV(dstr);
3076 if (!GvIMPORTED_SV(dstr) && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3077 GvIMPORTED_SV_on(dstr);
3083 if (SvTAINTED(sstr))
3089 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3092 register U32 sflags;
3098 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3100 sstr = &PL_sv_undef;
3101 stype = SvTYPE(sstr);
3102 dtype = SvTYPE(dstr);
3107 /* need to nuke the magic */
3109 SvRMAGICAL_off(dstr);
3112 /* There's a lot of redundancy below but we're going for speed here */
3117 if (dtype != SVt_PVGV) {
3118 (void)SvOK_off(dstr);
3126 sv_upgrade(dstr, SVt_IV);
3129 sv_upgrade(dstr, SVt_PVNV);
3133 sv_upgrade(dstr, SVt_PVIV);
3136 (void)SvIOK_only(dstr);
3137 SvIV_set(dstr, SvIVX(sstr));
3140 /* SvTAINTED can only be true if the SV has taint magic, which in
3141 turn means that the SV type is PVMG (or greater). This is the
3142 case statement for SVt_IV, so this cannot be true (whatever gcov
3144 assert(!SvTAINTED(sstr));
3154 sv_upgrade(dstr, SVt_NV);
3159 sv_upgrade(dstr, SVt_PVNV);
3162 SvNV_set(dstr, SvNVX(sstr));
3163 (void)SvNOK_only(dstr);
3164 /* SvTAINTED can only be true if the SV has taint magic, which in
3165 turn means that the SV type is PVMG (or greater). This is the
3166 case statement for SVt_NV, so this cannot be true (whatever gcov
3168 assert(!SvTAINTED(sstr));
3175 sv_upgrade(dstr, SVt_RV);
3176 else if (dtype == SVt_PVGV &&
3177 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3180 if (GvIMPORTED(dstr) != GVf_IMPORTED
3181 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3183 GvIMPORTED_on(dstr);
3188 S_glob_assign(aTHX_ dstr, sstr, dtype);
3193 #ifdef PERL_OLD_COPY_ON_WRITE
3194 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3195 if (dtype < SVt_PVIV)
3196 sv_upgrade(dstr, SVt_PVIV);
3203 sv_upgrade(dstr, SVt_PV);
3206 if (dtype < SVt_PVIV)
3207 sv_upgrade(dstr, SVt_PVIV);
3210 if (dtype < SVt_PVNV)
3211 sv_upgrade(dstr, SVt_PVNV);
3218 const char * const type = sv_reftype(sstr,0);
3220 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3222 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3227 if (dtype <= SVt_PVGV) {
3228 S_glob_assign(aTHX_ dstr, sstr, dtype);
3234 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3236 if ((int)SvTYPE(sstr) != stype) {
3237 stype = SvTYPE(sstr);
3238 if (stype == SVt_PVGV && dtype <= SVt_PVGV) {
3239 S_glob_assign(aTHX_ dstr, sstr, dtype);
3244 if (stype == SVt_PVLV)
3245 SvUPGRADE(dstr, SVt_PVNV);
3247 SvUPGRADE(dstr, (U32)stype);
3250 sflags = SvFLAGS(sstr);
3252 if (sflags & SVf_ROK) {
3253 if (dtype >= SVt_PV) {
3254 if (dtype == SVt_PVGV) {
3255 S_pvgv_assign(aTHX_ dstr, sstr);
3258 if (SvPVX_const(dstr)) {
3264 (void)SvOK_off(dstr);
3265 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3266 SvFLAGS(dstr) |= sflags & (SVf_ROK|SVf_AMAGIC);
3267 assert(!(sflags & SVp_NOK));
3268 assert(!(sflags & SVp_IOK));
3269 assert(!(sflags & SVf_NOK));
3270 assert(!(sflags & SVf_IOK));
3272 else if (sflags & SVp_POK) {
3276 * Check to see if we can just swipe the string. If so, it's a
3277 * possible small lose on short strings, but a big win on long ones.
3278 * It might even be a win on short strings if SvPVX_const(dstr)
3279 * has to be allocated and SvPVX_const(sstr) has to be freed.
3282 /* Whichever path we take through the next code, we want this true,
3283 and doing it now facilitates the COW check. */
3284 (void)SvPOK_only(dstr);
3287 /* We're not already COW */
3288 ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
3289 #ifndef PERL_OLD_COPY_ON_WRITE
3290 /* or we are, but dstr isn't a suitable target. */
3291 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
3296 (sflags & SVs_TEMP) && /* slated for free anyway? */
3297 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3298 (!(flags & SV_NOSTEAL)) &&
3299 /* and we're allowed to steal temps */
3300 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3301 SvLEN(sstr) && /* and really is a string */
3302 /* and won't be needed again, potentially */
3303 !(PL_op && PL_op->op_type == OP_AASSIGN))
3304 #ifdef PERL_OLD_COPY_ON_WRITE
3305 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
3306 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
3307 && SvTYPE(sstr) >= SVt_PVIV)
3310 /* Failed the swipe test, and it's not a shared hash key either.
3311 Have to copy the string. */
3312 STRLEN len = SvCUR(sstr);
3313 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3314 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
3315 SvCUR_set(dstr, len);
3316 *SvEND(dstr) = '\0';
3318 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
3320 /* Either it's a shared hash key, or it's suitable for
3321 copy-on-write or we can swipe the string. */
3323 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
3327 #ifdef PERL_OLD_COPY_ON_WRITE
3329 /* I believe I should acquire a global SV mutex if
3330 it's a COW sv (not a shared hash key) to stop
3331 it going un copy-on-write.
3332 If the source SV has gone un copy on write between up there
3333 and down here, then (assert() that) it is of the correct
3334 form to make it copy on write again */
3335 if ((sflags & (SVf_FAKE | SVf_READONLY))
3336 != (SVf_FAKE | SVf_READONLY)) {
3337 SvREADONLY_on(sstr);
3339 /* Make the source SV into a loop of 1.
3340 (about to become 2) */
3341 SV_COW_NEXT_SV_SET(sstr, sstr);
3345 /* Initial code is common. */
3346 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
3351 /* making another shared SV. */
3352 STRLEN cur = SvCUR(sstr);
3353 STRLEN len = SvLEN(sstr);
3354 #ifdef PERL_OLD_COPY_ON_WRITE
3356 assert (SvTYPE(dstr) >= SVt_PVIV);
3357 /* SvIsCOW_normal */
3358 /* splice us in between source and next-after-source. */
3359 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3360 SV_COW_NEXT_SV_SET(sstr, dstr);
3361 SvPV_set(dstr, SvPVX_mutable(sstr));
3365 /* SvIsCOW_shared_hash */
3366 DEBUG_C(PerlIO_printf(Perl_debug_log,
3367 "Copy on write: Sharing hash\n"));
3369 assert (SvTYPE(dstr) >= SVt_PV);
3371 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
3373 SvLEN_set(dstr, len);
3374 SvCUR_set(dstr, cur);
3375 SvREADONLY_on(dstr);
3377 /* Relesase a global SV mutex. */
3380 { /* Passes the swipe test. */
3381 SvPV_set(dstr, SvPVX_mutable(sstr));
3382 SvLEN_set(dstr, SvLEN(sstr));
3383 SvCUR_set(dstr, SvCUR(sstr));
3386 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3387 SvPV_set(sstr, NULL);
3393 if (sflags & SVp_NOK) {
3394 SvNV_set(dstr, SvNVX(sstr));
3396 if (sflags & SVp_IOK) {
3397 SvRELEASE_IVX(dstr);
3398 SvIV_set(dstr, SvIVX(sstr));
3399 /* Must do this otherwise some other overloaded use of 0x80000000
3400 gets confused. I guess SVpbm_VALID */
3401 if (sflags & SVf_IVisUV)
3404 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
3406 const MAGIC * const smg = SvVOK(sstr);
3408 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
3409 smg->mg_ptr, smg->mg_len);
3410 SvRMAGICAL_on(dstr);
3414 else if (sflags & (SVp_IOK|SVp_NOK)) {
3415 (void)SvOK_off(dstr);
3416 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
3417 if (sflags & SVp_IOK) {
3418 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3419 SvIV_set(dstr, SvIVX(sstr));
3421 if (sflags & SVp_NOK) {
3422 SvFLAGS(dstr) |= sflags & (SVf_NOK|SVp_NOK);
3423 SvNV_set(dstr, SvNVX(sstr));
3427 if (dtype == SVt_PVGV) {
3428 if (ckWARN(WARN_MISC))
3429 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
3432 (void)SvOK_off(dstr);
3434 if (SvTAINTED(sstr))
3439 =for apidoc sv_setsv_mg
3441 Like C<sv_setsv>, but also handles 'set' magic.
3447 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3449 sv_setsv(dstr,sstr);
3453 #ifdef PERL_OLD_COPY_ON_WRITE
3455 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
3457 STRLEN cur = SvCUR(sstr);
3458 STRLEN len = SvLEN(sstr);
3459 register char *new_pv;
3462 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
3470 if (SvTHINKFIRST(dstr))
3471 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
3472 else if (SvPVX_const(dstr))
3473 Safefree(SvPVX_const(dstr));
3477 SvUPGRADE(dstr, SVt_PVIV);
3479 assert (SvPOK(sstr));
3480 assert (SvPOKp(sstr));
3481 assert (!SvIOK(sstr));
3482 assert (!SvIOKp(sstr));
3483 assert (!SvNOK(sstr));
3484 assert (!SvNOKp(sstr));
3486 if (SvIsCOW(sstr)) {
3488 if (SvLEN(sstr) == 0) {
3489 /* source is a COW shared hash key. */
3490 DEBUG_C(PerlIO_printf(Perl_debug_log,
3491 "Fast copy on write: Sharing hash\n"));
3492 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
3495 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3497 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
3498 SvUPGRADE(sstr, SVt_PVIV);
3499 SvREADONLY_on(sstr);
3501 DEBUG_C(PerlIO_printf(Perl_debug_log,
3502 "Fast copy on write: Converting sstr to COW\n"));
3503 SV_COW_NEXT_SV_SET(dstr, sstr);
3505 SV_COW_NEXT_SV_SET(sstr, dstr);
3506 new_pv = SvPVX_mutable(sstr);
3509 SvPV_set(dstr, new_pv);
3510 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
3513 SvLEN_set(dstr, len);
3514 SvCUR_set(dstr, cur);
3523 =for apidoc sv_setpvn
3525 Copies a string into an SV. The C<len> parameter indicates the number of
3526 bytes to be copied. If the C<ptr> argument is NULL the SV will become
3527 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3533 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3536 register char *dptr;
3538 SV_CHECK_THINKFIRST_COW_DROP(sv);
3544 /* len is STRLEN which is unsigned, need to copy to signed */
3547 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3549 SvUPGRADE(sv, SVt_PV);
3551 dptr = SvGROW(sv, len + 1);
3552 Move(ptr,dptr,len,char);
3555 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3560 =for apidoc sv_setpvn_mg
3562 Like C<sv_setpvn>, but also handles 'set' magic.
3568 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3570 sv_setpvn(sv,ptr,len);
3575 =for apidoc sv_setpv
3577 Copies a string into an SV. The string must be null-terminated. Does not
3578 handle 'set' magic. See C<sv_setpv_mg>.
3584 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3587 register STRLEN len;
3589 SV_CHECK_THINKFIRST_COW_DROP(sv);
3595 SvUPGRADE(sv, SVt_PV);
3597 SvGROW(sv, len + 1);
3598 Move(ptr,SvPVX(sv),len+1,char);
3600 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3605 =for apidoc sv_setpv_mg
3607 Like C<sv_setpv>, but also handles 'set' magic.
3613 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3620 =for apidoc sv_usepvn
3622 Tells an SV to use C<ptr> to find its string value. Normally the string is
3623 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3624 The C<ptr> should point to memory that was allocated by C<malloc>. The
3625 string length, C<len>, must be supplied. This function will realloc the
3626 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3627 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3628 See C<sv_usepvn_mg>.
3634 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3638 SV_CHECK_THINKFIRST_COW_DROP(sv);
3639 SvUPGRADE(sv, SVt_PV);
3644 if (SvPVX_const(sv))
3647 allocate = PERL_STRLEN_ROUNDUP(len + 1);
3648 ptr = saferealloc (ptr, allocate);
3651 SvLEN_set(sv, allocate);
3653 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3658 =for apidoc sv_usepvn_mg
3660 Like C<sv_usepvn>, but also handles 'set' magic.
3666 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3668 sv_usepvn(sv,ptr,len);
3672 #ifdef PERL_OLD_COPY_ON_WRITE
3673 /* Need to do this *after* making the SV normal, as we need the buffer
3674 pointer to remain valid until after we've copied it. If we let go too early,
3675 another thread could invalidate it by unsharing last of the same hash key
3676 (which it can do by means other than releasing copy-on-write Svs)
3677 or by changing the other copy-on-write SVs in the loop. */
3679 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
3681 if (len) { /* this SV was SvIsCOW_normal(sv) */
3682 /* we need to find the SV pointing to us. */
3683 SV *current = SV_COW_NEXT_SV(after);
3685 if (current == sv) {
3686 /* The SV we point to points back to us (there were only two of us
3688 Hence other SV is no longer copy on write either. */
3690 SvREADONLY_off(after);
3692 /* We need to follow the pointers around the loop. */
3694 while ((next = SV_COW_NEXT_SV(current)) != sv) {
3697 /* don't loop forever if the structure is bust, and we have
3698 a pointer into a closed loop. */
3699 assert (current != after);
3700 assert (SvPVX_const(current) == pvx);
3702 /* Make the SV before us point to the SV after us. */
3703 SV_COW_NEXT_SV_SET(current, after);
3706 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
3711 Perl_sv_release_IVX(pTHX_ register SV *sv)
3714 sv_force_normal_flags(sv, 0);
3720 =for apidoc sv_force_normal_flags
3722 Undo various types of fakery on an SV: if the PV is a shared string, make
3723 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
3724 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
3725 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
3726 then a copy-on-write scalar drops its PV buffer (if any) and becomes
3727 SvPOK_off rather than making a copy. (Used where this scalar is about to be
3728 set to some other value.) In addition, the C<flags> parameter gets passed to
3729 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
3730 with flags set to 0.
3736 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3739 #ifdef PERL_OLD_COPY_ON_WRITE
3740 if (SvREADONLY(sv)) {
3741 /* At this point I believe I should acquire a global SV mutex. */
3743 const char * const pvx = SvPVX_const(sv);
3744 const STRLEN len = SvLEN(sv);
3745 const STRLEN cur = SvCUR(sv);
3746 SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
3748 PerlIO_printf(Perl_debug_log,
3749 "Copy on write: Force normal %ld\n",
3755 /* This SV doesn't own the buffer, so need to Newx() a new one: */
3758 if (flags & SV_COW_DROP_PV) {
3759 /* OK, so we don't need to copy our buffer. */
3762 SvGROW(sv, cur + 1);
3763 Move(pvx,SvPVX(sv),cur,char);
3767 sv_release_COW(sv, pvx, len, next);
3772 else if (IN_PERL_RUNTIME)
3773 Perl_croak(aTHX_ PL_no_modify);
3774 /* At this point I believe that I can drop the global SV mutex. */
3777 if (SvREADONLY(sv)) {
3779 const char * const pvx = SvPVX_const(sv);
3780 const STRLEN len = SvCUR(sv);
3785 SvGROW(sv, len + 1);
3786 Move(pvx,SvPVX(sv),len,char);
3788 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
3790 else if (IN_PERL_RUNTIME)
3791 Perl_croak(aTHX_ PL_no_modify);
3795 sv_unref_flags(sv, flags);
3796 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3803 Efficient removal of characters from the beginning of the string buffer.
3804 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3805 the string buffer. The C<ptr> becomes the first character of the adjusted
3806 string. Uses the "OOK hack".
3807 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
3808 refer to the same chunk of data.
3814 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
3816 register STRLEN delta;
3817 if (!ptr || !SvPOKp(sv))
3819 delta = ptr - SvPVX_const(sv);
3820 SV_CHECK_THINKFIRST(sv);
3821 if (SvTYPE(sv) < SVt_PVIV)
3822 sv_upgrade(sv,SVt_PVIV);
3825 if (!SvLEN(sv)) { /* make copy of shared string */
3826 const char *pvx = SvPVX_const(sv);
3827 const STRLEN len = SvCUR(sv);
3828 SvGROW(sv, len + 1);
3829 Move(pvx,SvPVX(sv),len,char);
3833 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
3834 and we do that anyway inside the SvNIOK_off
3836 SvFLAGS(sv) |= SVf_OOK;
3839 SvLEN_set(sv, SvLEN(sv) - delta);
3840 SvCUR_set(sv, SvCUR(sv) - delta);
3841 SvPV_set(sv, SvPVX(sv) + delta);
3842 SvIV_set(sv, SvIVX(sv) + delta);
3846 =for apidoc sv_catpvn
3848 Concatenates the string onto the end of the string which is in the SV. The
3849 C<len> indicates number of bytes to copy. If the SV has the UTF-8
3850 status set, then the bytes appended should be valid UTF-8.
3851 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
3853 =for apidoc sv_catpvn_flags
3855 Concatenates the string onto the end of the string which is in the SV. The
3856 C<len> indicates number of bytes to copy. If the SV has the UTF-8
3857 status set, then the bytes appended should be valid UTF-8.
3858 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
3859 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
3860 in terms of this function.
3866 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
3870 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
3872 SvGROW(dsv, dlen + slen + 1);
3874 sstr = SvPVX_const(dsv);
3875 Move(sstr, SvPVX(dsv) + dlen, slen, char);
3876 SvCUR_set(dsv, SvCUR(dsv) + slen);
3878 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
3880 if (flags & SV_SMAGIC)
3885 =for apidoc sv_catsv
3887 Concatenates the string from SV C<ssv> onto the end of the string in
3888 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3889 not 'set' magic. See C<sv_catsv_mg>.
3891 =for apidoc sv_catsv_flags
3893 Concatenates the string from SV C<ssv> onto the end of the string in
3894 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
3895 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
3896 and C<sv_catsv_nomg> are implemented in terms of this function.
3901 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
3906 const char *spv = SvPV_const(ssv, slen);
3908 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
3909 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
3910 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
3911 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
3912 dsv->sv_flags doesn't have that bit set.
3913 Andy Dougherty 12 Oct 2001
3915 const I32 sutf8 = DO_UTF8(ssv);
3918 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
3920 dutf8 = DO_UTF8(dsv);
3922 if (dutf8 != sutf8) {
3924 /* Not modifying source SV, so taking a temporary copy. */
3925 SV* const csv = sv_2mortal(newSVpvn(spv, slen));
3927 sv_utf8_upgrade(csv);
3928 spv = SvPV_const(csv, slen);
3931 sv_utf8_upgrade_nomg(dsv);
3933 sv_catpvn_nomg(dsv, spv, slen);
3936 if (flags & SV_SMAGIC)
3941 =for apidoc sv_catpv
3943 Concatenates the string onto the end of the string which is in the SV.
3944 If the SV has the UTF-8 status set, then the bytes appended should be
3945 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3950 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3953 register STRLEN len;
3959 junk = SvPV_force(sv, tlen);
3961 SvGROW(sv, tlen + len + 1);
3963 ptr = SvPVX_const(sv);
3964 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3965 SvCUR_set(sv, SvCUR(sv) + len);
3966 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3971 =for apidoc sv_catpv_mg
3973 Like C<sv_catpv>, but also handles 'set' magic.
3979 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3988 Creates a new SV. A non-zero C<len> parameter indicates the number of
3989 bytes of preallocated string space the SV should have. An extra byte for a
3990 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
3991 space is allocated.) The reference count for the new SV is set to 1.
3993 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
3994 parameter, I<x>, a debug aid which allowed callers to identify themselves.
3995 This aid has been superseded by a new build option, PERL_MEM_LOG (see
3996 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
3997 modules supporting older perls.
4003 Perl_newSV(pTHX_ STRLEN len)
4010 sv_upgrade(sv, SVt_PV);
4011 SvGROW(sv, len + 1);
4016 =for apidoc sv_magicext
4018 Adds magic to an SV, upgrading it if necessary. Applies the
4019 supplied vtable and returns a pointer to the magic added.
4021 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4022 In particular, you can add magic to SvREADONLY SVs, and add more than
4023 one instance of the same 'how'.
4025 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4026 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4027 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4028 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4030 (This is now used as a subroutine by C<sv_magic>.)
4035 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
4036 const char* name, I32 namlen)
4041 if (SvTYPE(sv) < SVt_PVMG) {
4042 SvUPGRADE(sv, SVt_PVMG);
4044 Newxz(mg, 1, MAGIC);
4045 mg->mg_moremagic = SvMAGIC(sv);
4046 SvMAGIC_set(sv, mg);
4048 /* Sometimes a magic contains a reference loop, where the sv and
4049 object refer to each other. To prevent a reference loop that
4050 would prevent such objects being freed, we look for such loops
4051 and if we find one we avoid incrementing the object refcount.
4053 Note we cannot do this to avoid self-tie loops as intervening RV must
4054 have its REFCNT incremented to keep it in existence.
4057 if (!obj || obj == sv ||
4058 how == PERL_MAGIC_arylen ||
4059 how == PERL_MAGIC_qr ||
4060 how == PERL_MAGIC_symtab ||
4061 (SvTYPE(obj) == SVt_PVGV &&
4062 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4063 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4064 GvFORM(obj) == (CV*)sv)))
4069 mg->mg_obj = SvREFCNT_inc(obj);
4070 mg->mg_flags |= MGf_REFCOUNTED;
4073 /* Normal self-ties simply pass a null object, and instead of
4074 using mg_obj directly, use the SvTIED_obj macro to produce a
4075 new RV as needed. For glob "self-ties", we are tieing the PVIO
4076 with an RV obj pointing to the glob containing the PVIO. In
4077 this case, to avoid a reference loop, we need to weaken the
4081 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4082 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4088 mg->mg_len = namlen;
4091 mg->mg_ptr = savepvn(name, namlen);
4092 else if (namlen == HEf_SVKEY)
4093 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4095 mg->mg_ptr = (char *) name;
4097 mg->mg_virtual = vtable;
4101 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4106 =for apidoc sv_magic
4108 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4109 then adds a new magic item of type C<how> to the head of the magic list.
4111 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4112 handling of the C<name> and C<namlen> arguments.
4114 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4115 to add more than one instance of the same 'how'.
4121 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4127 #ifdef PERL_OLD_COPY_ON_WRITE
4129 sv_force_normal_flags(sv, 0);
4131 if (SvREADONLY(sv)) {
4133 /* its okay to attach magic to shared strings; the subsequent
4134 * upgrade to PVMG will unshare the string */
4135 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4138 && how != PERL_MAGIC_regex_global
4139 && how != PERL_MAGIC_bm
4140 && how != PERL_MAGIC_fm
4141 && how != PERL_MAGIC_sv
4142 && how != PERL_MAGIC_backref
4145 Perl_croak(aTHX_ PL_no_modify);
4148 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4149 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4150 /* sv_magic() refuses to add a magic of the same 'how' as an
4153 if (how == PERL_MAGIC_taint)
4161 vtable = &PL_vtbl_sv;
4163 case PERL_MAGIC_overload:
4164 vtable = &PL_vtbl_amagic;
4166 case PERL_MAGIC_overload_elem:
4167 vtable = &PL_vtbl_amagicelem;
4169 case PERL_MAGIC_overload_table:
4170 vtable = &PL_vtbl_ovrld;
4173 vtable = &PL_vtbl_bm;
4175 case PERL_MAGIC_regdata:
4176 vtable = &PL_vtbl_regdata;
4178 case PERL_MAGIC_regdatum:
4179 vtable = &PL_vtbl_regdatum;
4181 case PERL_MAGIC_env:
4182 vtable = &PL_vtbl_env;
4185 vtable = &PL_vtbl_fm;
4187 case PERL_MAGIC_envelem:
4188 vtable = &PL_vtbl_envelem;
4190 case PERL_MAGIC_regex_global:
4191 vtable = &PL_vtbl_mglob;
4193 case PERL_MAGIC_isa:
4194 vtable = &PL_vtbl_isa;
4196 case PERL_MAGIC_isaelem:
4197 vtable = &PL_vtbl_isaelem;
4199 case PERL_MAGIC_nkeys:
4200 vtable = &PL_vtbl_nkeys;
4202 case PERL_MAGIC_dbfile:
4205 case PERL_MAGIC_dbline:
4206 vtable = &PL_vtbl_dbline;
4208 #ifdef USE_LOCALE_COLLATE
4209 case PERL_MAGIC_collxfrm:
4210 vtable = &PL_vtbl_collxfrm;
4212 #endif /* USE_LOCALE_COLLATE */
4213 case PERL_MAGIC_tied:
4214 vtable = &PL_vtbl_pack;
4216 case PERL_MAGIC_tiedelem:
4217 case PERL_MAGIC_tiedscalar:
4218 vtable = &PL_vtbl_packelem;
4221 vtable = &PL_vtbl_regexp;
4223 case PERL_MAGIC_sig:
4224 vtable = &PL_vtbl_sig;
4226 case PERL_MAGIC_sigelem:
4227 vtable = &PL_vtbl_sigelem;
4229 case PERL_MAGIC_taint:
4230 vtable = &PL_vtbl_taint;
4232 case PERL_MAGIC_uvar:
4233 vtable = &PL_vtbl_uvar;
4235 case PERL_MAGIC_vec:
4236 vtable = &PL_vtbl_vec;
4238 case PERL_MAGIC_arylen_p:
4239 case PERL_MAGIC_rhash:
4240 case PERL_MAGIC_symtab:
4241 case PERL_MAGIC_vstring:
4244 case PERL_MAGIC_utf8:
4245 vtable = &PL_vtbl_utf8;
4247 case PERL_MAGIC_substr:
4248 vtable = &PL_vtbl_substr;
4250 case PERL_MAGIC_defelem:
4251 vtable = &PL_vtbl_defelem;
4253 case PERL_MAGIC_glob:
4254 vtable = &PL_vtbl_glob;
4256 case PERL_MAGIC_arylen:
4257 vtable = &PL_vtbl_arylen;
4259 case PERL_MAGIC_pos:
4260 vtable = &PL_vtbl_pos;
4262 case PERL_MAGIC_backref:
4263 vtable = &PL_vtbl_backref;
4265 case PERL_MAGIC_ext:
4266 /* Reserved for use by extensions not perl internals. */
4267 /* Useful for attaching extension internal data to perl vars. */
4268 /* Note that multiple extensions may clash if magical scalars */
4269 /* etc holding private data from one are passed to another. */
4273 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4276 /* Rest of work is done else where */
4277 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4280 case PERL_MAGIC_taint:
4283 case PERL_MAGIC_ext:
4284 case PERL_MAGIC_dbfile:
4291 =for apidoc sv_unmagic
4293 Removes all magic of type C<type> from an SV.
4299 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4303 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4306 for (mg = *mgp; mg; mg = *mgp) {
4307 if (mg->mg_type == type) {
4308 const MGVTBL* const vtbl = mg->mg_virtual;
4309 *mgp = mg->mg_moremagic;
4310 if (vtbl && vtbl->svt_free)
4311 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4312 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4314 Safefree(mg->mg_ptr);
4315 else if (mg->mg_len == HEf_SVKEY)
4316 SvREFCNT_dec((SV*)mg->mg_ptr);
4317 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
4318 Safefree(mg->mg_ptr);
4320 if (mg->mg_flags & MGf_REFCOUNTED)
4321 SvREFCNT_dec(mg->mg_obj);
4325 mgp = &mg->mg_moremagic;
4329 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4330 SvMAGIC_set(sv, NULL);
4337 =for apidoc sv_rvweaken
4339 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4340 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4341 push a back-reference to this RV onto the array of backreferences
4342 associated with that magic.
4348 Perl_sv_rvweaken(pTHX_ SV *sv)
4351 if (!SvOK(sv)) /* let undefs pass */
4354 Perl_croak(aTHX_ "Can't weaken a nonreference");
4355 else if (SvWEAKREF(sv)) {
4356 if (ckWARN(WARN_MISC))
4357 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
4361 Perl_sv_add_backref(aTHX_ tsv, sv);
4367 /* Give tsv backref magic if it hasn't already got it, then push a
4368 * back-reference to sv onto the array associated with the backref magic.
4372 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4377 if (SvTYPE(tsv) == SVt_PVHV) {
4378 AV **const avp = Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
4382 /* There is no AV in the offical place - try a fixup. */
4383 MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
4386 /* Aha. They've got it stowed in magic. Bring it back. */
4387 av = (AV*)mg->mg_obj;
4388 /* Stop mg_free decreasing the refernce count. */
4390 /* Stop mg_free even calling the destructor, given that
4391 there's no AV to free up. */
4393 sv_unmagic(tsv, PERL_MAGIC_backref);
4402 const MAGIC *const mg
4403 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
4405 av = (AV*)mg->mg_obj;
4409 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4410 /* av now has a refcnt of 2, which avoids it getting freed
4411 * before us during global cleanup. The extra ref is removed
4412 * by magic_killbackrefs() when tsv is being freed */
4415 if (AvFILLp(av) >= AvMAX(av)) {
4416 av_extend(av, AvFILLp(av)+1);
4418 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
4421 /* delete a back-reference to ourselves from the backref magic associated
4422 * with the SV we point to.
4426 S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
4433 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
4434 av = *Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
4435 /* We mustn't attempt to "fix up" the hash here by moving the
4436 backreference array back to the hv_aux structure, as that is stored
4437 in the main HvARRAY(), and hfreentries assumes that no-one
4438 reallocates HvARRAY() while it is running. */
4441 const MAGIC *const mg
4442 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
4444 av = (AV *)mg->mg_obj;
4447 if (PL_in_clean_all)
4449 Perl_croak(aTHX_ "panic: del_backref");
4456 /* We shouldn't be in here more than once, but for paranoia reasons lets
4458 for (i = AvFILLp(av); i >= 0; i--) {
4460 const SSize_t fill = AvFILLp(av);
4462 /* We weren't the last entry.
4463 An unordered list has this property that you can take the
4464 last element off the end to fill the hole, and it's still
4465 an unordered list :-)
4470 AvFILLp(av) = fill - 1;
4476 Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av)
4478 SV **svp = AvARRAY(av);
4480 PERL_UNUSED_ARG(sv);
4482 /* Not sure why the av can get freed ahead of its sv, but somehow it does
4483 in ext/B/t/bytecode.t test 15 (involving print <DATA>) */
4484 if (svp && !SvIS_FREED(av)) {
4485 SV *const *const last = svp + AvFILLp(av);
4487 while (svp <= last) {
4489 SV *const referrer = *svp;
4490 if (SvWEAKREF(referrer)) {
4491 /* XXX Should we check that it hasn't changed? */
4492 SvRV_set(referrer, 0);
4494 SvWEAKREF_off(referrer);
4495 } else if (SvTYPE(referrer) == SVt_PVGV ||
4496 SvTYPE(referrer) == SVt_PVLV) {
4497 /* You lookin' at me? */
4498 assert(GvSTASH(referrer));
4499 assert(GvSTASH(referrer) == (HV*)sv);
4500 GvSTASH(referrer) = 0;
4503 "panic: magic_killbackrefs (flags=%"UVxf")",
4504 (UV)SvFLAGS(referrer));
4512 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
4517 =for apidoc sv_insert
4519 Inserts a string at the specified offset/length within the SV. Similar to
4520 the Perl substr() function.
4526 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
4531 register char *midend;
4532 register char *bigend;
4538 Perl_croak(aTHX_ "Can't modify non-existent substring");
4539 SvPV_force(bigstr, curlen);
4540 (void)SvPOK_only_UTF8(bigstr);
4541 if (offset + len > curlen) {
4542 SvGROW(bigstr, offset+len+1);
4543 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4544 SvCUR_set(bigstr, offset+len);
4548 i = littlelen - len;
4549 if (i > 0) { /* string might grow */
4550 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4551 mid = big + offset + len;
4552 midend = bigend = big + SvCUR(bigstr);
4555 while (midend > mid) /* shove everything down */
4556 *--bigend = *--midend;
4557 Move(little,big+offset,littlelen,char);
4558 SvCUR_set(bigstr, SvCUR(bigstr) + i);
4563 Move(little,SvPVX(bigstr)+offset,len,char);
4568 big = SvPVX(bigstr);
4571 bigend = big + SvCUR(bigstr);
4573 if (midend > bigend)
4574 Perl_croak(aTHX_ "panic: sv_insert");
4576 if (mid - big > bigend - midend) { /* faster to shorten from end */
4578 Move(little, mid, littlelen,char);
4581 i = bigend - midend;
4583 Move(midend, mid, i,char);
4587 SvCUR_set(bigstr, mid - big);
4589 else if ((i = mid - big)) { /* faster from front */
4590 midend -= littlelen;
4592 sv_chop(bigstr,midend-i);
4597 Move(little, mid, littlelen,char);
4599 else if (littlelen) {
4600 midend -= littlelen;
4601 sv_chop(bigstr,midend);
4602 Move(little,midend,littlelen,char);
4605 sv_chop(bigstr,midend);
4611 =for apidoc sv_replace
4613 Make the first argument a copy of the second, then delete the original.
4614 The target SV physically takes over ownership of the body of the source SV
4615 and inherits its flags; however, the target keeps any magic it owns,
4616 and any magic in the source is discarded.
4617 Note that this is a rather specialist SV copying operation; most of the
4618 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
4624 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4627 const U32 refcnt = SvREFCNT(sv);
4628 SV_CHECK_THINKFIRST_COW_DROP(sv);
4629 if (SvREFCNT(nsv) != 1) {
4630 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
4631 UVuf " != 1)", (UV) SvREFCNT(nsv));
4633 if (SvMAGICAL(sv)) {
4637 sv_upgrade(nsv, SVt_PVMG);
4638 SvMAGIC_set(nsv, SvMAGIC(sv));
4639 SvFLAGS(nsv) |= SvMAGICAL(sv);
4641 SvMAGIC_set(sv, NULL);
4645 assert(!SvREFCNT(sv));
4646 #ifdef DEBUG_LEAKING_SCALARS
4647 sv->sv_flags = nsv->sv_flags;
4648 sv->sv_any = nsv->sv_any;
4649 sv->sv_refcnt = nsv->sv_refcnt;
4650 sv->sv_u = nsv->sv_u;
4652 StructCopy(nsv,sv,SV);
4654 /* Currently could join these into one piece of pointer arithmetic, but
4655 it would be unclear. */
4656 if(SvTYPE(sv) == SVt_IV)
4658 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
4659 else if (SvTYPE(sv) == SVt_RV) {
4660 SvANY(sv) = &sv->sv_u.svu_rv;
4664 #ifdef PERL_OLD_COPY_ON_WRITE
4665 if (SvIsCOW_normal(nsv)) {
4666 /* We need to follow the pointers around the loop to make the
4667 previous SV point to sv, rather than nsv. */
4670 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
4673 assert(SvPVX_const(current) == SvPVX_const(nsv));
4675 /* Make the SV before us point to the SV after us. */
4677 PerlIO_printf(Perl_debug_log, "previous is\n");
4679 PerlIO_printf(Perl_debug_log,
4680 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
4681 (UV) SV_COW_NEXT_SV(current), (UV) sv);
4683 SV_COW_NEXT_SV_SET(current, sv);
4686 SvREFCNT(sv) = refcnt;
4687 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4693 =for apidoc sv_clear
4695 Clear an SV: call any destructors, free up any memory used by the body,
4696 and free the body itself. The SV's head is I<not> freed, although
4697 its type is set to all 1's so that it won't inadvertently be assumed
4698 to be live during global destruction etc.
4699 This function should only be called when REFCNT is zero. Most of the time
4700 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
4707 Perl_sv_clear(pTHX_ register SV *sv)
4710 const U32 type = SvTYPE(sv);
4711 const struct body_details *const sv_type_details
4712 = bodies_by_type + type;
4715 assert(SvREFCNT(sv) == 0);
4721 if (PL_defstash) { /* Still have a symbol table? */
4726 stash = SvSTASH(sv);
4727 destructor = StashHANDLER(stash,DESTROY);
4729 SV* const tmpref = newRV(sv);
4730 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
4732 PUSHSTACKi(PERLSI_DESTROY);
4737 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
4743 if(SvREFCNT(tmpref) < 2) {
4744 /* tmpref is not kept alive! */
4746 SvRV_set(tmpref, NULL);
4749 SvREFCNT_dec(tmpref);
4751 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4755 if (PL_in_clean_objs)
4756 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4758 /* DESTROY gave object new lease on life */
4764 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4765 SvOBJECT_off(sv); /* Curse the object. */
4766 if (type != SVt_PVIO)
4767 --PL_sv_objcount; /* XXX Might want something more general */
4770 if (type >= SVt_PVMG) {
4773 if (type == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
4774 SvREFCNT_dec(SvSTASH(sv));
4779 IoIFP(sv) != PerlIO_stdin() &&
4780 IoIFP(sv) != PerlIO_stdout() &&
4781 IoIFP(sv) != PerlIO_stderr())
4783 io_close((IO*)sv, FALSE);
4785 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4786 PerlDir_close(IoDIRP(sv));
4787 IoDIRP(sv) = (DIR*)NULL;
4788 Safefree(IoTOP_NAME(sv));
4789 Safefree(IoFMT_NAME(sv));
4790 Safefree(IoBOTTOM_NAME(sv));
4799 Perl_hv_kill_backrefs(aTHX_ (HV*)sv);
4806 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
4807 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
4808 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
4809 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
4811 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
4812 SvREFCNT_dec(LvTARG(sv));
4816 Safefree(GvNAME(sv));
4817 /* If we're in a stash, we don't own a reference to it. However it does
4818 have a back reference to us, which needs to be cleared. */
4820 sv_del_backref((SV*)GvSTASH(sv), sv);
4825 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
4827 SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
4828 /* Don't even bother with turning off the OOK flag. */
4833 SV *target = SvRV(sv);
4835 sv_del_backref(target, sv);
4837 SvREFCNT_dec(target);
4839 #ifdef PERL_OLD_COPY_ON_WRITE
4840 else if (SvPVX_const(sv)) {
4842 /* I believe I need to grab the global SV mutex here and
4843 then recheck the COW status. */
4845 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
4848 sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv),
4849 SV_COW_NEXT_SV(sv));
4850 /* And drop it here. */
4852 } else if (SvLEN(sv)) {
4853 Safefree(SvPVX_const(sv));
4857 else if (SvPVX_const(sv) && SvLEN(sv))
4858 Safefree(SvPVX_mutable(sv));
4859 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4860 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
4869 SvFLAGS(sv) &= SVf_BREAK;
4870 SvFLAGS(sv) |= SVTYPEMASK;
4872 if (sv_type_details->arena) {
4873 del_body(((char *)SvANY(sv) + sv_type_details->offset),
4874 &PL_body_roots[type]);
4876 else if (sv_type_details->size) {
4877 my_safefree(SvANY(sv));
4882 =for apidoc sv_newref
4884 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
4891 Perl_sv_newref(pTHX_ SV *sv)
4901 Decrement an SV's reference count, and if it drops to zero, call
4902 C<sv_clear> to invoke destructors and free up any memory used by
4903 the body; finally, deallocate the SV's head itself.
4904 Normally called via a wrapper macro C<SvREFCNT_dec>.
4910 Perl_sv_free(pTHX_ SV *sv)
4915 if (SvREFCNT(sv) == 0) {
4916 if (SvFLAGS(sv) & SVf_BREAK)
4917 /* this SV's refcnt has been artificially decremented to
4918 * trigger cleanup */
4920 if (PL_in_clean_all) /* All is fair */
4922 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4923 /* make sure SvREFCNT(sv)==0 happens very seldom */
4924 SvREFCNT(sv) = (~(U32)0)/2;
4927 if (ckWARN_d(WARN_INTERNAL)) {
4928 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
4929 "Attempt to free unreferenced scalar: SV 0x%"UVxf
4930 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
4931 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
4932 Perl_dump_sv_child(aTHX_ sv);
4937 if (--(SvREFCNT(sv)) > 0)
4939 Perl_sv_free2(aTHX_ sv);
4943 Perl_sv_free2(pTHX_ SV *sv)
4948 if (ckWARN_d(WARN_DEBUGGING))
4949 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
4950 "Attempt to free temp prematurely: SV 0x%"UVxf
4951 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
4955 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4956 /* make sure SvREFCNT(sv)==0 happens very seldom */
4957 SvREFCNT(sv) = (~(U32)0)/2;
4968 Returns the length of the string in the SV. Handles magic and type
4969 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
4975 Perl_sv_len(pTHX_ register SV *sv)
4983 len = mg_length(sv);
4985 (void)SvPV_const(sv, len);
4990 =for apidoc sv_len_utf8
4992 Returns the number of characters in the string in an SV, counting wide
4993 UTF-8 bytes as a single character. Handles magic and type coercion.
4999 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
5000 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
5001 * (Note that the mg_len is not the length of the mg_ptr field.)
5006 Perl_sv_len_utf8(pTHX_ register SV *sv)
5012 return mg_length(sv);
5016 const U8 *s = (U8*)SvPV_const(sv, len);
5017 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
5019 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
5021 #ifdef PERL_UTF8_CACHE_ASSERT
5022 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
5026 ulen = Perl_utf8_length(aTHX_ s, s + len);
5027 if (!mg && !SvREADONLY(sv)) {
5028 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5029 mg = mg_find(sv, PERL_MAGIC_utf8);
5039 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
5040 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5041 * between UTF-8 and byte offsets. There are two (substr offset and substr
5042 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
5043 * and byte offset) cache positions.
5045 * The mg_len field is used by sv_len_utf8(), see its comments.
5046 * Note that the mg_len is not the length of the mg_ptr field.
5050 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i,
5051 I32 offsetp, const U8 *s, const U8 *start)
5055 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5057 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
5061 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5063 Newxz(*cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5064 (*mgp)->mg_ptr = (char *) *cachep;
5068 (*cachep)[i] = offsetp;
5069 (*cachep)[i+1] = s - start;
5077 * S_utf8_mg_pos() is used to query and update mg_ptr field of
5078 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5079 * between UTF-8 and byte offsets. See also the comments of
5080 * S_utf8_mg_pos_init().
5084 S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, const U8 **sp, const U8 *start, const U8 *send)
5088 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5090 *mgp = mg_find(sv, PERL_MAGIC_utf8);
5091 if (*mgp && (*mgp)->mg_ptr) {
5092 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5093 ASSERT_UTF8_CACHE(*cachep);
5094 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
5096 else { /* We will skip to the right spot. */
5101 /* The assumption is that going backward is half
5102 * the speed of going forward (that's where the
5103 * 2 * backw in the below comes from). (The real
5104 * figure of course depends on the UTF-8 data.) */
5106 if ((*cachep)[i] > (STRLEN)uoff) {
5108 backw = (*cachep)[i] - (STRLEN)uoff;
5110 if (forw < 2 * backw)
5113 p = start + (*cachep)[i+1];
5115 /* Try this only for the substr offset (i == 0),
5116 * not for the substr length (i == 2). */
5117 else if (i == 0) { /* (*cachep)[i] < uoff */
5118 const STRLEN ulen = sv_len_utf8(sv);
5120 if ((STRLEN)uoff < ulen) {
5121 forw = (STRLEN)uoff - (*cachep)[i];
5122 backw = ulen - (STRLEN)uoff;
5124 if (forw < 2 * backw)
5125 p = start + (*cachep)[i+1];
5130 /* If the string is not long enough for uoff,
5131 * we could extend it, but not at this low a level. */
5135 if (forw < 2 * backw) {
5142 while (UTF8_IS_CONTINUATION(*p))
5147 /* Update the cache. */
5148 (*cachep)[i] = (STRLEN)uoff;
5149 (*cachep)[i+1] = p - start;
5151 /* Drop the stale "length" cache */
5160 if (found) { /* Setup the return values. */
5161 *offsetp = (*cachep)[i+1];
5162 *sp = start + *offsetp;
5165 *offsetp = send - start;
5167 else if (*sp < start) {
5173 #ifdef PERL_UTF8_CACHE_ASSERT
5178 while (n-- && s < send)
5182 assert(*offsetp == s - start);
5183 assert((*cachep)[0] == (STRLEN)uoff);
5184 assert((*cachep)[1] == *offsetp);
5186 ASSERT_UTF8_CACHE(*cachep);
5195 =for apidoc sv_pos_u2b
5197 Converts the value pointed to by offsetp from a count of UTF-8 chars from
5198 the start of the string, to a count of the equivalent number of bytes; if
5199 lenp is non-zero, it does the same to lenp, but this time starting from
5200 the offset, rather than from the start of the string. Handles magic and
5207 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
5208 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5209 * byte offsets. See also the comments of S_utf8_mg_pos().
5214 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5222 start = (U8*)SvPV_const(sv, len);
5225 STRLEN *cache = NULL;
5226 const U8 *s = start;
5227 I32 uoffset = *offsetp;
5228 const U8 * const send = s + len;
5230 bool found = utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send);
5232 if (!found && uoffset > 0) {
5233 while (s < send && uoffset--)
5237 if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
5239 *offsetp = s - start;
5244 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
5248 if (!found && *lenp > 0) {
5251 while (s < send && ulen--)
5255 utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
5259 ASSERT_UTF8_CACHE(cache);
5271 =for apidoc sv_pos_b2u
5273 Converts the value pointed to by offsetp from a count of bytes from the
5274 start of the string, to a count of the equivalent number of UTF-8 chars.
5275 Handles magic and type coercion.
5281 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
5282 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5283 * byte offsets. See also the comments of S_utf8_mg_pos().
5288 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
5296 s = (const U8*)SvPV_const(sv, len);
5297 if ((I32)len < *offsetp)
5298 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5300 const U8* send = s + *offsetp;
5302 STRLEN *cache = NULL;
5306 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5307 mg = mg_find(sv, PERL_MAGIC_utf8);
5308 if (mg && mg->mg_ptr) {
5309 cache = (STRLEN *) mg->mg_ptr;
5310 if (cache[1] == (STRLEN)*offsetp) {
5311 /* An exact match. */
5312 *offsetp = cache[0];
5316 else if (cache[1] < (STRLEN)*offsetp) {
5317 /* We already know part of the way. */
5320 /* Let the below loop do the rest. */
5322 else { /* cache[1] > *offsetp */
5323 /* We already know all of the way, now we may
5324 * be able to walk back. The same assumption
5325 * is made as in S_utf8_mg_pos(), namely that
5326 * walking backward is twice slower than
5327 * walking forward. */
5328 const STRLEN forw = *offsetp;
5329 STRLEN backw = cache[1] - *offsetp;
5331 if (!(forw < 2 * backw)) {
5332 const U8 *p = s + cache[1];
5339 while (UTF8_IS_CONTINUATION(*p)) {
5347 *offsetp = cache[0];
5349 /* Drop the stale "length" cache */
5357 ASSERT_UTF8_CACHE(cache);
5363 /* Call utf8n_to_uvchr() to validate the sequence
5364 * (unless a simple non-UTF character) */
5365 if (!UTF8_IS_INVARIANT(*s))
5366 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5375 if (!SvREADONLY(sv)) {
5377 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5378 mg = mg_find(sv, PERL_MAGIC_utf8);
5383 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5384 mg->mg_ptr = (char *) cache;
5389 cache[1] = *offsetp;
5390 /* Drop the stale "length" cache */
5403 Returns a boolean indicating whether the strings in the two SVs are
5404 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5405 coerce its args to strings if necessary.
5411 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5420 SV* svrecode = NULL;
5427 pv1 = SvPV_const(sv1, cur1);
5434 pv2 = SvPV_const(sv2, cur2);
5436 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5437 /* Differing utf8ness.
5438 * Do not UTF8size the comparands as a side-effect. */
5441 svrecode = newSVpvn(pv2, cur2);
5442 sv_recode_to_utf8(svrecode, PL_encoding);
5443 pv2 = SvPV_const(svrecode, cur2);
5446 svrecode = newSVpvn(pv1, cur1);
5447 sv_recode_to_utf8(svrecode, PL_encoding);
5448 pv1 = SvPV_const(svrecode, cur1);
5450 /* Now both are in UTF-8. */
5452 SvREFCNT_dec(svrecode);
5457 bool is_utf8 = TRUE;
5460 /* sv1 is the UTF-8 one,
5461 * if is equal it must be downgrade-able */
5462 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
5468 /* sv2 is the UTF-8 one,
5469 * if is equal it must be downgrade-able */
5470 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
5476 /* Downgrade not possible - cannot be eq */
5484 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
5487 SvREFCNT_dec(svrecode);
5498 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
5499 string in C<sv1> is less than, equal to, or greater than the string in
5500 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5501 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
5507 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5511 const char *pv1, *pv2;
5514 SV *svrecode = NULL;
5521 pv1 = SvPV_const(sv1, cur1);
5528 pv2 = SvPV_const(sv2, cur2);
5530 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5531 /* Differing utf8ness.
5532 * Do not UTF8size the comparands as a side-effect. */
5535 svrecode = newSVpvn(pv2, cur2);
5536 sv_recode_to_utf8(svrecode, PL_encoding);
5537 pv2 = SvPV_const(svrecode, cur2);
5540 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
5545 svrecode = newSVpvn(pv1, cur1);
5546 sv_recode_to_utf8(svrecode, PL_encoding);
5547 pv1 = SvPV_const(svrecode, cur1);
5550 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
5556 cmp = cur2 ? -1 : 0;
5560 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
5563 cmp = retval < 0 ? -1 : 1;
5564 } else if (cur1 == cur2) {
5567 cmp = cur1 < cur2 ? -1 : 1;
5572 SvREFCNT_dec(svrecode);
5581 =for apidoc sv_cmp_locale
5583 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5584 'use bytes' aware, handles get magic, and will coerce its args to strings
5585 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
5591 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5594 #ifdef USE_LOCALE_COLLATE
5600 if (PL_collation_standard)
5604 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5606 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5608 if (!pv1 || !len1) {
5619 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5622 return retval < 0 ? -1 : 1;
5625 * When the result of collation is equality, that doesn't mean
5626 * that there are no differences -- some locales exclude some
5627 * characters from consideration. So to avoid false equalities,
5628 * we use the raw string as a tiebreaker.
5634 #endif /* USE_LOCALE_COLLATE */
5636 return sv_cmp(sv1, sv2);
5640 #ifdef USE_LOCALE_COLLATE
5643 =for apidoc sv_collxfrm
5645 Add Collate Transform magic to an SV if it doesn't already have it.
5647 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5648 scalar data of the variable, but transformed to such a format that a normal
5649 memory comparison can be used to compare the data according to the locale
5656 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5661 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5662 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5668 Safefree(mg->mg_ptr);
5669 s = SvPV_const(sv, len);
5670 if ((xf = mem_collxfrm(s, len, &xlen))) {
5671 if (SvREADONLY(sv)) {
5674 return xf + sizeof(PL_collation_ix);
5677 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5678 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5691 if (mg && mg->mg_ptr) {
5693 return mg->mg_ptr + sizeof(PL_collation_ix);
5701 #endif /* USE_LOCALE_COLLATE */
5706 Get a line from the filehandle and store it into the SV, optionally
5707 appending to the currently-stored string.
5713 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5718 register STDCHAR rslast;
5719 register STDCHAR *bp;
5725 if (SvTHINKFIRST(sv))
5726 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
5727 /* XXX. If you make this PVIV, then copy on write can copy scalars read
5729 However, perlbench says it's slower, because the existing swipe code
5730 is faster than copy on write.
5731 Swings and roundabouts. */
5732 SvUPGRADE(sv, SVt_PV);
5737 if (PerlIO_isutf8(fp)) {
5739 sv_utf8_upgrade_nomg(sv);
5740 sv_pos_u2b(sv,&append,0);
5742 } else if (SvUTF8(sv)) {
5743 SV * const tsv = newSV(0);
5744 sv_gets(tsv, fp, 0);
5745 sv_utf8_upgrade_nomg(tsv);
5746 SvCUR_set(sv,append);
5749 goto return_string_or_null;
5754 if (PerlIO_isutf8(fp))
5757 if (IN_PERL_COMPILETIME) {
5758 /* we always read code in line mode */
5762 else if (RsSNARF(PL_rs)) {
5763 /* If it is a regular disk file use size from stat() as estimate
5764 of amount we are going to read - may result in malloc-ing
5765 more memory than we realy need if layers bellow reduce
5766 size we read (e.g. CRLF or a gzip layer)
5769 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
5770 const Off_t offset = PerlIO_tell(fp);
5771 if (offset != (Off_t) -1 && st.st_size + append > offset) {
5772 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
5778 else if (RsRECORD(PL_rs)) {
5782 /* Grab the size of the record we're getting */
5783 recsize = SvIV(SvRV(PL_rs));
5784 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
5787 /* VMS wants read instead of fread, because fread doesn't respect */
5788 /* RMS record boundaries. This is not necessarily a good thing to be */
5789 /* doing, but we've got no other real choice - except avoid stdio
5790 as implementation - perhaps write a :vms layer ?
5792 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5794 bytesread = PerlIO_read(fp, buffer, recsize);
5798 SvCUR_set(sv, bytesread += append);
5799 buffer[bytesread] = '\0';
5800 goto return_string_or_null;
5802 else if (RsPARA(PL_rs)) {
5808 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5809 if (PerlIO_isutf8(fp)) {
5810 rsptr = SvPVutf8(PL_rs, rslen);
5813 if (SvUTF8(PL_rs)) {
5814 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5815 Perl_croak(aTHX_ "Wide character in $/");
5818 rsptr = SvPV_const(PL_rs, rslen);
5822 rslast = rslen ? rsptr[rslen - 1] : '\0';
5824 if (rspara) { /* have to do this both before and after */
5825 do { /* to make sure file boundaries work right */
5828 i = PerlIO_getc(fp);
5832 PerlIO_ungetc(fp,i);
5838 /* See if we know enough about I/O mechanism to cheat it ! */
5840 /* This used to be #ifdef test - it is made run-time test for ease
5841 of abstracting out stdio interface. One call should be cheap
5842 enough here - and may even be a macro allowing compile
5846 if (PerlIO_fast_gets(fp)) {
5849 * We're going to steal some values from the stdio struct
5850 * and put EVERYTHING in the innermost loop into registers.
5852 register STDCHAR *ptr;
5856 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5857 /* An ungetc()d char is handled separately from the regular
5858 * buffer, so we getc() it back out and stuff it in the buffer.
5860 i = PerlIO_getc(fp);
5861 if (i == EOF) return 0;
5862 *(--((*fp)->_ptr)) = (unsigned char) i;
5866 /* Here is some breathtakingly efficient cheating */
5868 cnt = PerlIO_get_cnt(fp); /* get count into register */
5869 /* make sure we have the room */
5870 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
5871 /* Not room for all of it
5872 if we are looking for a separator and room for some
5874 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
5875 /* just process what we have room for */
5876 shortbuffered = cnt - SvLEN(sv) + append + 1;
5877 cnt -= shortbuffered;
5881 /* remember that cnt can be negative */
5882 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
5887 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
5888 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5889 DEBUG_P(PerlIO_printf(Perl_debug_log,
5890 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5891 DEBUG_P(PerlIO_printf(Perl_debug_log,
5892 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5893 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5894 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5899 while (cnt > 0) { /* this | eat */
5901 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5902 goto thats_all_folks; /* screams | sed :-) */
5906 Copy(ptr, bp, cnt, char); /* this | eat */
5907 bp += cnt; /* screams | dust */
5908 ptr += cnt; /* louder | sed :-) */
5913 if (shortbuffered) { /* oh well, must extend */
5914 cnt = shortbuffered;
5916 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
5918 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5919 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
5923 DEBUG_P(PerlIO_printf(Perl_debug_log,
5924 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5925 PTR2UV(ptr),(long)cnt));
5926 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
5928 DEBUG_P(PerlIO_printf(Perl_debug_log,
5929 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5930 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5931 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5933 /* This used to call 'filbuf' in stdio form, but as that behaves like
5934 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5935 another abstraction. */
5936 i = PerlIO_getc(fp); /* get more characters */
5938 DEBUG_P(PerlIO_printf(Perl_debug_log,
5939 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5940 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5941 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5943 cnt = PerlIO_get_cnt(fp);
5944 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5945 DEBUG_P(PerlIO_printf(Perl_debug_log,
5946 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5948 if (i == EOF) /* all done for ever? */
5949 goto thats_really_all_folks;
5951 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
5953 SvGROW(sv, bpx + cnt + 2);
5954 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
5956 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
5958 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5959 goto thats_all_folks;
5963 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
5964 memNE((char*)bp - rslen, rsptr, rslen))
5965 goto screamer; /* go back to the fray */
5966 thats_really_all_folks:
5968 cnt += shortbuffered;
5969 DEBUG_P(PerlIO_printf(Perl_debug_log,
5970 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5971 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
5972 DEBUG_P(PerlIO_printf(Perl_debug_log,
5973 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5974 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5975 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5977 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
5978 DEBUG_P(PerlIO_printf(Perl_debug_log,
5979 "Screamer: done, len=%ld, string=|%.*s|\n",
5980 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
5984 /*The big, slow, and stupid way. */
5985 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
5986 STDCHAR *buf = NULL;
5987 Newx(buf, 8192, STDCHAR);
5995 register const STDCHAR * const bpe = buf + sizeof(buf);
5997 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
5998 ; /* keep reading */
6002 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6003 /* Accomodate broken VAXC compiler, which applies U8 cast to
6004 * both args of ?: operator, causing EOF to change into 255
6007 i = (U8)buf[cnt - 1];
6013 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
6015 sv_catpvn(sv, (char *) buf, cnt);
6017 sv_setpvn(sv, (char *) buf, cnt);
6019 if (i != EOF && /* joy */
6021 SvCUR(sv) < rslen ||
6022 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6026 * If we're reading from a TTY and we get a short read,
6027 * indicating that the user hit his EOF character, we need
6028 * to notice it now, because if we try to read from the TTY
6029 * again, the EOF condition will disappear.
6031 * The comparison of cnt to sizeof(buf) is an optimization
6032 * that prevents unnecessary calls to feof().
6036 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6040 #ifdef USE_HEAP_INSTEAD_OF_STACK
6045 if (rspara) { /* have to do this both before and after */
6046 while (i != EOF) { /* to make sure file boundaries work right */
6047 i = PerlIO_getc(fp);
6049 PerlIO_ungetc(fp,i);
6055 return_string_or_null:
6056 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
6062 Auto-increment of the value in the SV, doing string to numeric conversion
6063 if necessary. Handles 'get' magic.
6069 Perl_sv_inc(pTHX_ register SV *sv)
6078 if (SvTHINKFIRST(sv)) {
6080 sv_force_normal_flags(sv, 0);
6081 if (SvREADONLY(sv)) {
6082 if (IN_PERL_RUNTIME)
6083 Perl_croak(aTHX_ PL_no_modify);
6087 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6089 i = PTR2IV(SvRV(sv));
6094 flags = SvFLAGS(sv);
6095 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6096 /* It's (privately or publicly) a float, but not tested as an
6097 integer, so test it to see. */
6099 flags = SvFLAGS(sv);
6101 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6102 /* It's publicly an integer, or privately an integer-not-float */
6103 #ifdef PERL_PRESERVE_IVUV
6107 if (SvUVX(sv) == UV_MAX)
6108 sv_setnv(sv, UV_MAX_P1);
6110 (void)SvIOK_only_UV(sv);
6111 SvUV_set(sv, SvUVX(sv) + 1);
6113 if (SvIVX(sv) == IV_MAX)
6114 sv_setuv(sv, (UV)IV_MAX + 1);
6116 (void)SvIOK_only(sv);
6117 SvIV_set(sv, SvIVX(sv) + 1);
6122 if (flags & SVp_NOK) {
6123 (void)SvNOK_only(sv);
6124 SvNV_set(sv, SvNVX(sv) + 1.0);
6128 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
6129 if ((flags & SVTYPEMASK) < SVt_PVIV)
6130 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
6131 (void)SvIOK_only(sv);
6136 while (isALPHA(*d)) d++;
6137 while (isDIGIT(*d)) d++;
6139 #ifdef PERL_PRESERVE_IVUV
6140 /* Got to punt this as an integer if needs be, but we don't issue
6141 warnings. Probably ought to make the sv_iv_please() that does
6142 the conversion if possible, and silently. */
6143 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6144 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6145 /* Need to try really hard to see if it's an integer.
6146 9.22337203685478e+18 is an integer.
6147 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6148 so $a="9.22337203685478e+18"; $a+0; $a++
6149 needs to be the same as $a="9.22337203685478e+18"; $a++
6156 /* sv_2iv *should* have made this an NV */
6157 if (flags & SVp_NOK) {
6158 (void)SvNOK_only(sv);
6159 SvNV_set(sv, SvNVX(sv) + 1.0);
6162 /* I don't think we can get here. Maybe I should assert this
6163 And if we do get here I suspect that sv_setnv will croak. NWC
6165 #if defined(USE_LONG_DOUBLE)
6166 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",
6167 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6169 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6170 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6173 #endif /* PERL_PRESERVE_IVUV */
6174 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
6178 while (d >= SvPVX_const(sv)) {
6186 /* MKS: The original code here died if letters weren't consecutive.
6187 * at least it didn't have to worry about non-C locales. The
6188 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6189 * arranged in order (although not consecutively) and that only
6190 * [A-Za-z] are accepted by isALPHA in the C locale.
6192 if (*d != 'z' && *d != 'Z') {
6193 do { ++*d; } while (!isALPHA(*d));
6196 *(d--) -= 'z' - 'a';
6201 *(d--) -= 'z' - 'a' + 1;
6205 /* oh,oh, the number grew */
6206 SvGROW(sv, SvCUR(sv) + 2);
6207 SvCUR_set(sv, SvCUR(sv) + 1);
6208 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
6219 Auto-decrement of the value in the SV, doing string to numeric conversion
6220 if necessary. Handles 'get' magic.
6226 Perl_sv_dec(pTHX_ register SV *sv)
6234 if (SvTHINKFIRST(sv)) {
6236 sv_force_normal_flags(sv, 0);
6237 if (SvREADONLY(sv)) {
6238 if (IN_PERL_RUNTIME)
6239 Perl_croak(aTHX_ PL_no_modify);
6243 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6245 i = PTR2IV(SvRV(sv));
6250 /* Unlike sv_inc we don't have to worry about string-never-numbers
6251 and keeping them magic. But we mustn't warn on punting */
6252 flags = SvFLAGS(sv);
6253 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6254 /* It's publicly an integer, or privately an integer-not-float */
6255 #ifdef PERL_PRESERVE_IVUV
6259 if (SvUVX(sv) == 0) {
6260 (void)SvIOK_only(sv);
6264 (void)SvIOK_only_UV(sv);
6265 SvUV_set(sv, SvUVX(sv) - 1);
6268 if (SvIVX(sv) == IV_MIN)
6269 sv_setnv(sv, (NV)IV_MIN - 1.0);
6271 (void)SvIOK_only(sv);
6272 SvIV_set(sv, SvIVX(sv) - 1);
6277 if (flags & SVp_NOK) {
6278 SvNV_set(sv, SvNVX(sv) - 1.0);
6279 (void)SvNOK_only(sv);
6282 if (!(flags & SVp_POK)) {
6283 if ((flags & SVTYPEMASK) < SVt_PVIV)
6284 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
6286 (void)SvIOK_only(sv);
6289 #ifdef PERL_PRESERVE_IVUV
6291 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6292 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6293 /* Need to try really hard to see if it's an integer.
6294 9.22337203685478e+18 is an integer.
6295 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6296 so $a="9.22337203685478e+18"; $a+0; $a--
6297 needs to be the same as $a="9.22337203685478e+18"; $a--
6304 /* sv_2iv *should* have made this an NV */
6305 if (flags & SVp_NOK) {
6306 (void)SvNOK_only(sv);
6307 SvNV_set(sv, SvNVX(sv) - 1.0);
6310 /* I don't think we can get here. Maybe I should assert this
6311 And if we do get here I suspect that sv_setnv will croak. NWC
6313 #if defined(USE_LONG_DOUBLE)
6314 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",
6315 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6317 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6318 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6322 #endif /* PERL_PRESERVE_IVUV */
6323 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
6327 =for apidoc sv_mortalcopy
6329 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6330 The new SV is marked as mortal. It will be destroyed "soon", either by an
6331 explicit call to FREETMPS, or by an implicit call at places such as
6332 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
6337 /* Make a string that will exist for the duration of the expression
6338 * evaluation. Actually, it may have to last longer than that, but
6339 * hopefully we won't free it until it has been assigned to a
6340 * permanent location. */
6343 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6349 sv_setsv(sv,oldstr);
6351 PL_tmps_stack[++PL_tmps_ix] = sv;
6357 =for apidoc sv_newmortal
6359 Creates a new null SV which is mortal. The reference count of the SV is
6360 set to 1. It will be destroyed "soon", either by an explicit call to
6361 FREETMPS, or by an implicit call at places such as statement boundaries.
6362 See also C<sv_mortalcopy> and C<sv_2mortal>.
6368 Perl_sv_newmortal(pTHX)
6374 SvFLAGS(sv) = SVs_TEMP;
6376 PL_tmps_stack[++PL_tmps_ix] = sv;
6381 =for apidoc sv_2mortal
6383 Marks an existing SV as mortal. The SV will be destroyed "soon", either
6384 by an explicit call to FREETMPS, or by an implicit call at places such as
6385 statement boundaries. SvTEMP() is turned on which means that the SV's
6386 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
6387 and C<sv_mortalcopy>.
6393 Perl_sv_2mortal(pTHX_ register SV *sv)
6398 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6401 PL_tmps_stack[++PL_tmps_ix] = sv;
6409 Creates a new SV and copies a string into it. The reference count for the
6410 SV is set to 1. If C<len> is zero, Perl will compute the length using
6411 strlen(). For efficiency, consider using C<newSVpvn> instead.
6417 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6423 sv_setpvn(sv,s,len ? len : strlen(s));
6428 =for apidoc newSVpvn
6430 Creates a new SV and copies a string into it. The reference count for the
6431 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
6432 string. You are responsible for ensuring that the source string is at least
6433 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
6439 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6445 sv_setpvn(sv,s,len);
6451 =for apidoc newSVhek
6453 Creates a new SV from the hash key structure. It will generate scalars that
6454 point to the shared string table where possible. Returns a new (undefined)
6455 SV if the hek is NULL.
6461 Perl_newSVhek(pTHX_ const HEK *hek)
6471 if (HEK_LEN(hek) == HEf_SVKEY) {
6472 return newSVsv(*(SV**)HEK_KEY(hek));
6474 const int flags = HEK_FLAGS(hek);
6475 if (flags & HVhek_WASUTF8) {
6477 Andreas would like keys he put in as utf8 to come back as utf8
6479 STRLEN utf8_len = HEK_LEN(hek);
6480 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
6481 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
6484 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
6486 } else if (flags & HVhek_REHASH) {
6487 /* We don't have a pointer to the hv, so we have to replicate the
6488 flag into every HEK. This hv is using custom a hasing
6489 algorithm. Hence we can't return a shared string scalar, as
6490 that would contain the (wrong) hash value, and might get passed
6491 into an hv routine with a regular hash */
6493 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
6498 /* This will be overwhelminly the most common case. */
6499 return newSVpvn_share(HEK_KEY(hek),
6500 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
6506 =for apidoc newSVpvn_share
6508 Creates a new SV with its SvPVX_const pointing to a shared string in the string
6509 table. If the string does not already exist in the table, it is created
6510 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
6511 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6512 otherwise the hash is computed. The idea here is that as the string table
6513 is used for shared hash keys these strings will have SvPVX_const == HeKEY and
6514 hash lookup will avoid string compare.
6520 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6524 bool is_utf8 = FALSE;
6526 STRLEN tmplen = -len;
6528 /* See the note in hv.c:hv_fetch() --jhi */
6529 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
6533 PERL_HASH(hash, src, len);
6535 sv_upgrade(sv, SVt_PV);
6536 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
6548 #if defined(PERL_IMPLICIT_CONTEXT)
6550 /* pTHX_ magic can't cope with varargs, so this is a no-context
6551 * version of the main function, (which may itself be aliased to us).
6552 * Don't access this version directly.
6556 Perl_newSVpvf_nocontext(const char* pat, ...)
6561 va_start(args, pat);
6562 sv = vnewSVpvf(pat, &args);
6569 =for apidoc newSVpvf
6571 Creates a new SV and initializes it with the string formatted like
6578 Perl_newSVpvf(pTHX_ const char* pat, ...)
6582 va_start(args, pat);
6583 sv = vnewSVpvf(pat, &args);
6588 /* backend for newSVpvf() and newSVpvf_nocontext() */
6591 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6596 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6603 Creates a new SV and copies a floating point value into it.
6604 The reference count for the SV is set to 1.
6610 Perl_newSVnv(pTHX_ NV n)
6623 Creates a new SV and copies an integer into it. The reference count for the
6630 Perl_newSViv(pTHX_ IV i)
6643 Creates a new SV and copies an unsigned integer into it.
6644 The reference count for the SV is set to 1.
6650 Perl_newSVuv(pTHX_ UV u)
6661 =for apidoc newRV_noinc
6663 Creates an RV wrapper for an SV. The reference count for the original
6664 SV is B<not> incremented.
6670 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6676 sv_upgrade(sv, SVt_RV);
6678 SvRV_set(sv, tmpRef);
6683 /* newRV_inc is the official function name to use now.
6684 * newRV_inc is in fact #defined to newRV in sv.h
6688 Perl_newRV(pTHX_ SV *tmpRef)
6691 return newRV_noinc(SvREFCNT_inc(tmpRef));
6697 Creates a new SV which is an exact duplicate of the original SV.
6704 Perl_newSVsv(pTHX_ register SV *old)
6711 if (SvTYPE(old) == SVTYPEMASK) {
6712 if (ckWARN_d(WARN_INTERNAL))
6713 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
6717 /* SV_GMAGIC is the default for sv_setv()
6718 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
6719 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
6720 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
6725 =for apidoc sv_reset
6727 Underlying implementation for the C<reset> Perl function.
6728 Note that the perl-level function is vaguely deprecated.
6734 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
6737 char todo[PERL_UCHAR_MAX+1];
6742 if (!*s) { /* reset ?? searches */
6743 MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
6745 PMOP *pm = (PMOP *) mg->mg_obj;
6747 pm->op_pmdynflags &= ~PMdf_USED;
6754 /* reset variables */
6756 if (!HvARRAY(stash))
6759 Zero(todo, 256, char);
6762 I32 i = (unsigned char)*s;
6766 max = (unsigned char)*s++;
6767 for ( ; i <= max; i++) {
6770 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6772 for (entry = HvARRAY(stash)[i];
6774 entry = HeNEXT(entry))
6779 if (!todo[(U8)*HeKEY(entry)])
6781 gv = (GV*)HeVAL(entry);
6784 if (SvTHINKFIRST(sv)) {
6785 if (!SvREADONLY(sv) && SvROK(sv))
6787 /* XXX Is this continue a bug? Why should THINKFIRST
6788 exempt us from resetting arrays and hashes? */
6792 if (SvTYPE(sv) >= SVt_PV) {
6794 if (SvPVX_const(sv) != NULL)
6802 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
6804 Perl_die(aTHX_ "Can't reset %%ENV on this system");
6807 # if defined(USE_ENVIRON_ARRAY)
6810 # endif /* USE_ENVIRON_ARRAY */
6821 Using various gambits, try to get an IO from an SV: the IO slot if its a
6822 GV; or the recursive result if we're an RV; or the IO slot of the symbol
6823 named after the PV if we're a string.
6829 Perl_sv_2io(pTHX_ SV *sv)
6834 switch (SvTYPE(sv)) {
6842 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6846 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6848 return sv_2io(SvRV(sv));
6849 gv = gv_fetchsv(sv, 0, SVt_PVIO);
6855 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
6864 Using various gambits, try to get a CV from an SV; in addition, try if
6865 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
6866 The flags in C<lref> are passed to sv_fetchsv.
6872 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6879 return *st = NULL, *gvp = NULL, NULL;
6880 switch (SvTYPE(sv)) {
6899 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6900 tryAMAGICunDEREF(to_cv);
6903 if (SvTYPE(sv) == SVt_PVCV) {
6912 Perl_croak(aTHX_ "Not a subroutine reference");
6917 gv = gv_fetchsv(sv, lref, SVt_PVCV);
6923 /* Some flags to gv_fetchsv mean don't really create the GV */
6924 if (SvTYPE(gv) != SVt_PVGV) {
6930 if (lref && !GvCVu(gv)) {
6934 gv_efullname3(tmpsv, gv, NULL);
6935 /* XXX this is probably not what they think they're getting.
6936 * It has the same effect as "sub name;", i.e. just a forward
6938 newSUB(start_subparse(FALSE, 0),
6939 newSVOP(OP_CONST, 0, tmpsv),
6944 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
6954 Returns true if the SV has a true value by Perl's rules.
6955 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
6956 instead use an in-line version.
6962 Perl_sv_true(pTHX_ register SV *sv)
6967 register const XPV* const tXpv = (XPV*)SvANY(sv);
6969 (tXpv->xpv_cur > 1 ||
6970 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
6977 return SvIVX(sv) != 0;
6980 return SvNVX(sv) != 0.0;
6982 return sv_2bool(sv);
6988 =for apidoc sv_pvn_force
6990 Get a sensible string out of the SV somehow.
6991 A private implementation of the C<SvPV_force> macro for compilers which
6992 can't cope with complex macro expressions. Always use the macro instead.
6994 =for apidoc sv_pvn_force_flags
6996 Get a sensible string out of the SV somehow.
6997 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6998 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6999 implemented in terms of this function.
7000 You normally want to use the various wrapper macros instead: see
7001 C<SvPV_force> and C<SvPV_force_nomg>
7007 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7010 if (SvTHINKFIRST(sv) && !SvROK(sv))
7011 sv_force_normal_flags(sv, 0);
7021 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
7022 const char * const ref = sv_reftype(sv,0);
7024 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
7025 ref, OP_NAME(PL_op));
7027 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
7029 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
7030 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7032 s = sv_2pv_flags(sv, &len, flags);
7036 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
7039 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
7040 SvGROW(sv, len + 1);
7041 Move(s,SvPVX(sv),len,char);
7046 SvPOK_on(sv); /* validate pointer */
7048 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7049 PTR2UV(sv),SvPVX_const(sv)));
7052 return SvPVX_mutable(sv);
7056 =for apidoc sv_pvbyten_force
7058 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
7064 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7066 sv_pvn_force(sv,lp);
7067 sv_utf8_downgrade(sv,0);
7073 =for apidoc sv_pvutf8n_force
7075 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
7081 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
7083 sv_pvn_force(sv,lp);
7084 sv_utf8_upgrade(sv);
7090 =for apidoc sv_reftype
7092 Returns a string describing what the SV is a reference to.
7098 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
7100 /* The fact that I don't need to downcast to char * everywhere, only in ?:
7101 inside return suggests a const propagation bug in g++. */
7102 if (ob && SvOBJECT(sv)) {
7103 char * const name = HvNAME_get(SvSTASH(sv));
7104 return name ? name : (char *) "__ANON__";
7107 switch (SvTYPE(sv)) {
7124 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
7125 /* tied lvalues should appear to be
7126 * scalars for backwards compatitbility */
7127 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
7128 ? "SCALAR" : "LVALUE");
7129 case SVt_PVAV: return "ARRAY";
7130 case SVt_PVHV: return "HASH";
7131 case SVt_PVCV: return "CODE";
7132 case SVt_PVGV: return "GLOB";
7133 case SVt_PVFM: return "FORMAT";
7134 case SVt_PVIO: return "IO";
7135 default: return "UNKNOWN";
7141 =for apidoc sv_isobject
7143 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7144 object. If the SV is not an RV, or if the object is not blessed, then this
7151 Perl_sv_isobject(pTHX_ SV *sv)
7167 Returns a boolean indicating whether the SV is blessed into the specified
7168 class. This does not check for subtypes; use C<sv_derived_from> to verify
7169 an inheritance relationship.
7175 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7186 hvname = HvNAME_get(SvSTASH(sv));
7190 return strEQ(hvname, name);
7196 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
7197 it will be upgraded to one. If C<classname> is non-null then the new SV will
7198 be blessed in the specified package. The new SV is returned and its
7199 reference count is 1.
7205 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7212 SV_CHECK_THINKFIRST_COW_DROP(rv);
7215 if (SvTYPE(rv) >= SVt_PVMG) {
7216 const U32 refcnt = SvREFCNT(rv);
7220 SvREFCNT(rv) = refcnt;
7223 if (SvTYPE(rv) < SVt_RV)
7224 sv_upgrade(rv, SVt_RV);
7225 else if (SvTYPE(rv) > SVt_RV) {
7236 HV* const stash = gv_stashpv(classname, TRUE);
7237 (void)sv_bless(rv, stash);
7243 =for apidoc sv_setref_pv
7245 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7246 argument will be upgraded to an RV. That RV will be modified to point to
7247 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7248 into the SV. The C<classname> argument indicates the package for the
7249 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7250 will have a reference count of 1, and the RV will be returned.
7252 Do not use with other Perl types such as HV, AV, SV, CV, because those
7253 objects will become corrupted by the pointer copy process.
7255 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7261 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7265 sv_setsv(rv, &PL_sv_undef);
7269 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7274 =for apidoc sv_setref_iv
7276 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7277 argument will be upgraded to an RV. That RV will be modified to point to
7278 the new SV. The C<classname> argument indicates the package for the
7279 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7280 will have a reference count of 1, and the RV will be returned.
7286 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7288 sv_setiv(newSVrv(rv,classname), iv);
7293 =for apidoc sv_setref_uv
7295 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7296 argument will be upgraded to an RV. That RV will be modified to point to
7297 the new SV. The C<classname> argument indicates the package for the
7298 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7299 will have a reference count of 1, and the RV will be returned.
7305 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7307 sv_setuv(newSVrv(rv,classname), uv);
7312 =for apidoc sv_setref_nv
7314 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7315 argument will be upgraded to an RV. That RV will be modified to point to
7316 the new SV. The C<classname> argument indicates the package for the
7317 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7318 will have a reference count of 1, and the RV will be returned.
7324 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7326 sv_setnv(newSVrv(rv,classname), nv);
7331 =for apidoc sv_setref_pvn
7333 Copies a string into a new SV, optionally blessing the SV. The length of the
7334 string must be specified with C<n>. The C<rv> argument will be upgraded to
7335 an RV. That RV will be modified to point to the new SV. The C<classname>
7336 argument indicates the package for the blessing. Set C<classname> to
7337 C<NULL> to avoid the blessing. The new SV will have a reference count
7338 of 1, and the RV will be returned.
7340 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7346 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n)
7348 sv_setpvn(newSVrv(rv,classname), pv, n);
7353 =for apidoc sv_bless
7355 Blesses an SV into a specified package. The SV must be an RV. The package
7356 must be designated by its stash (see C<gv_stashpv()>). The reference count
7357 of the SV is unaffected.
7363 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7368 Perl_croak(aTHX_ "Can't bless non-reference value");
7370 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7371 if (SvREADONLY(tmpRef))
7372 Perl_croak(aTHX_ PL_no_modify);
7373 if (SvOBJECT(tmpRef)) {
7374 if (SvTYPE(tmpRef) != SVt_PVIO)
7376 SvREFCNT_dec(SvSTASH(tmpRef));
7379 SvOBJECT_on(tmpRef);
7380 if (SvTYPE(tmpRef) != SVt_PVIO)
7382 SvUPGRADE(tmpRef, SVt_PVMG);
7383 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
7390 if(SvSMAGICAL(tmpRef))
7391 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
7399 /* Downgrades a PVGV to a PVMG.
7403 S_sv_unglob(pTHX_ SV *sv)
7408 assert(SvTYPE(sv) == SVt_PVGV);
7413 sv_del_backref((SV*)GvSTASH(sv), sv);
7416 sv_unmagic(sv, PERL_MAGIC_glob);
7417 Safefree(GvNAME(sv));
7420 /* need to keep SvANY(sv) in the right arena */
7421 xpvmg = new_XPVMG();
7422 StructCopy(SvANY(sv), xpvmg, XPVMG);
7423 del_XPVGV(SvANY(sv));
7426 SvFLAGS(sv) &= ~SVTYPEMASK;
7427 SvFLAGS(sv) |= SVt_PVMG;
7431 =for apidoc sv_unref_flags
7433 Unsets the RV status of the SV, and decrements the reference count of
7434 whatever was being referenced by the RV. This can almost be thought of
7435 as a reversal of C<newSVrv>. The C<cflags> argument can contain
7436 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7437 (otherwise the decrementing is conditional on the reference count being
7438 different from one or the reference being a readonly SV).
7445 Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
7447 SV* const target = SvRV(ref);
7449 if (SvWEAKREF(ref)) {
7450 sv_del_backref(target, ref);
7452 SvRV_set(ref, NULL);
7455 SvRV_set(ref, NULL);
7457 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
7458 assigned to as BEGIN {$a = \"Foo"} will fail. */
7459 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
7460 SvREFCNT_dec(target);
7461 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7462 sv_2mortal(target); /* Schedule for freeing later */
7466 =for apidoc sv_untaint
7468 Untaint an SV. Use C<SvTAINTED_off> instead.
7473 Perl_sv_untaint(pTHX_ SV *sv)
7475 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7476 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
7483 =for apidoc sv_tainted
7485 Test an SV for taintedness. Use C<SvTAINTED> instead.
7490 Perl_sv_tainted(pTHX_ SV *sv)
7492 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7493 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
7494 if (mg && (mg->mg_len & 1) )
7501 =for apidoc sv_setpviv
7503 Copies an integer into the given SV, also updating its string value.
7504 Does not handle 'set' magic. See C<sv_setpviv_mg>.
7510 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
7512 char buf[TYPE_CHARS(UV)];
7514 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7516 sv_setpvn(sv, ptr, ebuf - ptr);
7520 =for apidoc sv_setpviv_mg
7522 Like C<sv_setpviv>, but also handles 'set' magic.
7528 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
7534 #if defined(PERL_IMPLICIT_CONTEXT)
7536 /* pTHX_ magic can't cope with varargs, so this is a no-context
7537 * version of the main function, (which may itself be aliased to us).
7538 * Don't access this version directly.
7542 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
7546 va_start(args, pat);
7547 sv_vsetpvf(sv, pat, &args);
7551 /* pTHX_ magic can't cope with varargs, so this is a no-context
7552 * version of the main function, (which may itself be aliased to us).
7553 * Don't access this version directly.
7557 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7561 va_start(args, pat);
7562 sv_vsetpvf_mg(sv, pat, &args);
7568 =for apidoc sv_setpvf
7570 Works like C<sv_catpvf> but copies the text into the SV instead of
7571 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
7577 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7580 va_start(args, pat);
7581 sv_vsetpvf(sv, pat, &args);
7586 =for apidoc sv_vsetpvf
7588 Works like C<sv_vcatpvf> but copies the text into the SV instead of
7589 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
7591 Usually used via its frontend C<sv_setpvf>.
7597 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7599 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7603 =for apidoc sv_setpvf_mg
7605 Like C<sv_setpvf>, but also handles 'set' magic.
7611 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7614 va_start(args, pat);
7615 sv_vsetpvf_mg(sv, pat, &args);
7620 =for apidoc sv_vsetpvf_mg
7622 Like C<sv_vsetpvf>, but also handles 'set' magic.
7624 Usually used via its frontend C<sv_setpvf_mg>.
7630 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7632 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7636 #if defined(PERL_IMPLICIT_CONTEXT)
7638 /* pTHX_ magic can't cope with varargs, so this is a no-context
7639 * version of the main function, (which may itself be aliased to us).
7640 * Don't access this version directly.
7644 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
7648 va_start(args, pat);
7649 sv_vcatpvf(sv, pat, &args);
7653 /* pTHX_ magic can't cope with varargs, so this is a no-context
7654 * version of the main function, (which may itself be aliased to us).
7655 * Don't access this version directly.
7659 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
7663 va_start(args, pat);
7664 sv_vcatpvf_mg(sv, pat, &args);
7670 =for apidoc sv_catpvf
7672 Processes its arguments like C<sprintf> and appends the formatted
7673 output to an SV. If the appended data contains "wide" characters
7674 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
7675 and characters >255 formatted with %c), the original SV might get
7676 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
7677 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
7678 valid UTF-8; if the original SV was bytes, the pattern should be too.
7683 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
7686 va_start(args, pat);
7687 sv_vcatpvf(sv, pat, &args);
7692 =for apidoc sv_vcatpvf
7694 Processes its arguments like C<vsprintf> and appends the formatted output
7695 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
7697 Usually used via its frontend C<sv_catpvf>.
7703 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7705 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7709 =for apidoc sv_catpvf_mg
7711 Like C<sv_catpvf>, but also handles 'set' magic.
7717 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7720 va_start(args, pat);
7721 sv_vcatpvf_mg(sv, pat, &args);
7726 =for apidoc sv_vcatpvf_mg
7728 Like C<sv_vcatpvf>, but also handles 'set' magic.
7730 Usually used via its frontend C<sv_catpvf_mg>.
7736 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7738 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7743 =for apidoc sv_vsetpvfn
7745 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
7748 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
7754 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7756 sv_setpvn(sv, "", 0);
7757 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
7761 S_expect_number(pTHX_ char** pattern)
7765 switch (**pattern) {
7766 case '1': case '2': case '3':
7767 case '4': case '5': case '6':
7768 case '7': case '8': case '9':
7769 var = *(*pattern)++ - '0';
7770 while (isDIGIT(**pattern)) {
7771 I32 tmp = var * 10 + (*(*pattern)++ - '0');
7773 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn"));
7781 S_F0convert(NV nv, char *endbuf, STRLEN *len)
7783 const int neg = nv < 0;
7792 if (uv & 1 && uv == nv)
7793 uv--; /* Round to even */
7795 const unsigned dig = uv % 10;
7808 =for apidoc sv_vcatpvfn
7810 Processes its arguments like C<vsprintf> and appends the formatted output
7811 to an SV. Uses an array of SVs if the C style variable argument list is
7812 missing (NULL). When running with taint checks enabled, indicates via
7813 C<maybe_tainted> if results are untrustworthy (often due to the use of
7816 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
7822 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
7823 vecstr = (U8*)SvPV_const(vecsv,veclen);\
7824 vec_utf8 = DO_UTF8(vecsv);
7826 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
7829 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7837 static const char nullstr[] = "(null)";
7839 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
7840 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
7842 /* Times 4: a decimal digit takes more than 3 binary digits.
7843 * NV_DIG: mantissa takes than many decimal digits.
7844 * Plus 32: Playing safe. */
7845 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7846 /* large enough for "%#.#f" --chip */
7847 /* what about long double NVs? --jhi */
7849 PERL_UNUSED_ARG(maybe_tainted);
7851 /* no matter what, this is a string now */
7852 (void)SvPV_force(sv, origlen);
7854 /* special-case "", "%s", and "%-p" (SVf - see below) */
7857 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
7859 const char * const s = va_arg(*args, char*);
7860 sv_catpv(sv, s ? s : nullstr);
7862 else if (svix < svmax) {
7863 sv_catsv(sv, *svargs);
7867 if (args && patlen == 3 && pat[0] == '%' &&
7868 pat[1] == '-' && pat[2] == 'p') {
7869 argsv = va_arg(*args, SV*);
7870 sv_catsv(sv, argsv);
7874 #ifndef USE_LONG_DOUBLE
7875 /* special-case "%.<number>[gf]" */
7876 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
7877 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
7878 unsigned digits = 0;
7882 while (*pp >= '0' && *pp <= '9')
7883 digits = 10 * digits + (*pp++ - '0');
7884 if (pp - pat == (int)patlen - 1) {
7892 /* Add check for digits != 0 because it seems that some
7893 gconverts are buggy in this case, and we don't yet have
7894 a Configure test for this. */
7895 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
7896 /* 0, point, slack */
7897 Gconvert(nv, (int)digits, 0, ebuf);
7899 if (*ebuf) /* May return an empty string for digits==0 */
7902 } else if (!digits) {
7905 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
7906 sv_catpvn(sv, p, l);
7912 #endif /* !USE_LONG_DOUBLE */
7914 if (!args && svix < svmax && DO_UTF8(*svargs))
7917 patend = (char*)pat + patlen;
7918 for (p = (char*)pat; p < patend; p = q) {
7921 bool vectorize = FALSE;
7922 bool vectorarg = FALSE;
7923 bool vec_utf8 = FALSE;
7929 bool has_precis = FALSE;
7931 const I32 osvix = svix;
7932 bool is_utf8 = FALSE; /* is this item utf8? */
7933 #ifdef HAS_LDBL_SPRINTF_BUG
7934 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
7935 with sfio - Allen <allens@cpan.org> */
7936 bool fix_ldbl_sprintf_bug = FALSE;
7940 U8 utf8buf[UTF8_MAXBYTES+1];
7941 STRLEN esignlen = 0;
7943 const char *eptr = NULL;
7946 const U8 *vecstr = Null(U8*);
7953 /* we need a long double target in case HAS_LONG_DOUBLE but
7956 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
7964 const char *dotstr = ".";
7965 STRLEN dotstrlen = 1;
7966 I32 efix = 0; /* explicit format parameter index */
7967 I32 ewix = 0; /* explicit width index */
7968 I32 epix = 0; /* explicit precision index */
7969 I32 evix = 0; /* explicit vector index */
7970 bool asterisk = FALSE;
7972 /* echo everything up to the next format specification */
7973 for (q = p; q < patend && *q != '%'; ++q) ;
7975 if (has_utf8 && !pat_utf8)
7976 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
7978 sv_catpvn(sv, p, q - p);
7985 We allow format specification elements in this order:
7986 \d+\$ explicit format parameter index
7988 v|\*(\d+\$)?v vector with optional (optionally specified) arg
7989 0 flag (as above): repeated to allow "v02"
7990 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7991 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7993 [%bcdefginopsuxDFOUX] format (mandatory)
7998 As of perl5.9.3, printf format checking is on by default.
7999 Internally, perl uses %p formats to provide an escape to
8000 some extended formatting. This block deals with those
8001 extensions: if it does not match, (char*)q is reset and
8002 the normal format processing code is used.
8004 Currently defined extensions are:
8005 %p include pointer address (standard)
8006 %-p (SVf) include an SV (previously %_)
8007 %-<num>p include an SV with precision <num>
8008 %1p (VDf) include a v-string (as %vd)
8009 %<num>p reserved for future extensions
8011 Robin Barker 2005-07-14
8018 n = expect_number(&q);
8025 argsv = va_arg(*args, SV*);
8026 eptr = SvPVx_const(argsv, elen);
8032 else if (n == vdNUMBER) { /* VDf */
8039 if (ckWARN_d(WARN_INTERNAL))
8040 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
8041 "internal %%<num>p might conflict with future printf extensions");
8047 if ( (width = expect_number(&q)) ) {
8088 if ( (ewix = expect_number(&q)) )
8097 if ((vectorarg = asterisk)) {
8110 width = expect_number(&q);
8116 vecsv = va_arg(*args, SV*);
8118 vecsv = (evix > 0 && evix <= svmax)
8119 ? svargs[evix-1] : &PL_sv_undef;
8121 vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
8123 dotstr = SvPV_const(vecsv, dotstrlen);
8124 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
8125 bad with tied or overloaded values that return UTF8. */
8128 else if (has_utf8) {
8129 vecsv = sv_mortalcopy(vecsv);
8130 sv_utf8_upgrade(vecsv);
8131 dotstr = SvPV_const(vecsv, dotstrlen);
8138 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
8139 vecsv = svargs[efix ? efix-1 : svix++];
8140 vecstr = (U8*)SvPV_const(vecsv,veclen);
8141 vec_utf8 = DO_UTF8(vecsv);
8143 /* if this is a version object, we need to convert
8144 * back into v-string notation and then let the
8145 * vectorize happen normally
8147 if (sv_derived_from(vecsv, "version")) {
8148 char *version = savesvpv(vecsv);
8149 if ( hv_exists((HV*)SvRV(vecsv), "alpha", 5 ) ) {
8150 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
8151 "vector argument not supported with alpha versions");
8154 vecsv = sv_newmortal();
8155 /* scan_vstring is expected to be called during
8156 * tokenization, so we need to fake up the end
8157 * of the buffer for it
8159 PL_bufend = version + veclen;
8160 scan_vstring(version, vecsv);
8161 vecstr = (U8*)SvPV_const(vecsv, veclen);
8162 vec_utf8 = DO_UTF8(vecsv);
8174 i = va_arg(*args, int);
8176 i = (ewix ? ewix <= svmax : svix < svmax) ?
8177 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8179 width = (i < 0) ? -i : i;
8189 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
8191 /* XXX: todo, support specified precision parameter */
8195 i = va_arg(*args, int);
8197 i = (ewix ? ewix <= svmax : svix < svmax)
8198 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8199 precis = (i < 0) ? 0 : i;
8204 precis = precis * 10 + (*q++ - '0');
8213 case 'I': /* Ix, I32x, and I64x */
8215 if (q[1] == '6' && q[2] == '4') {
8221 if (q[1] == '3' && q[2] == '2') {
8231 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8242 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8243 if (*(q + 1) == 'l') { /* lld, llf */
8269 if (!vectorize && !args) {
8271 const I32 i = efix-1;
8272 argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
8274 argsv = (svix >= 0 && svix < svmax)
8275 ? svargs[svix++] : &PL_sv_undef;
8286 uv = (args) ? va_arg(*args, int) : SvIVx(argsv);
8288 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8290 eptr = (char*)utf8buf;
8291 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
8305 eptr = va_arg(*args, char*);
8307 #ifdef MACOS_TRADITIONAL
8308 /* On MacOS, %#s format is used for Pascal strings */
8313 elen = strlen(eptr);
8315 eptr = (char *)nullstr;
8316 elen = sizeof nullstr - 1;
8320 eptr = SvPVx_const(argsv, elen);
8321 if (DO_UTF8(argsv)) {
8322 if (has_precis && precis < elen) {
8324 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
8327 if (width) { /* fudge width (can't fudge elen) */
8328 width += elen - sv_len_utf8(argsv);
8335 if (has_precis && elen > precis)
8342 if (alt || vectorize)
8344 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
8365 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8374 esignbuf[esignlen++] = plus;
8378 case 'h': iv = (short)va_arg(*args, int); break;
8379 case 'l': iv = va_arg(*args, long); break;
8380 case 'V': iv = va_arg(*args, IV); break;
8381 default: iv = va_arg(*args, int); break;
8383 case 'q': iv = va_arg(*args, Quad_t); break;
8388 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
8390 case 'h': iv = (short)tiv; break;
8391 case 'l': iv = (long)tiv; break;
8393 default: iv = tiv; break;
8395 case 'q': iv = (Quad_t)tiv; break;
8399 if ( !vectorize ) /* we already set uv above */
8404 esignbuf[esignlen++] = plus;
8408 esignbuf[esignlen++] = '-';
8451 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8462 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
8463 case 'l': uv = va_arg(*args, unsigned long); break;
8464 case 'V': uv = va_arg(*args, UV); break;
8465 default: uv = va_arg(*args, unsigned); break;
8467 case 'q': uv = va_arg(*args, Uquad_t); break;
8472 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
8474 case 'h': uv = (unsigned short)tuv; break;
8475 case 'l': uv = (unsigned long)tuv; break;
8477 default: uv = tuv; break;
8479 case 'q': uv = (Uquad_t)tuv; break;
8486 char *ptr = ebuf + sizeof ebuf;
8492 p = (char*)((c == 'X')
8493 ? "0123456789ABCDEF" : "0123456789abcdef");
8499 esignbuf[esignlen++] = '0';
8500 esignbuf[esignlen++] = c; /* 'x' or 'X' */
8508 if (alt && *ptr != '0')
8519 esignbuf[esignlen++] = '0';
8520 esignbuf[esignlen++] = 'b';
8523 default: /* it had better be ten or less */
8527 } while (uv /= base);
8530 elen = (ebuf + sizeof ebuf) - ptr;
8534 zeros = precis - elen;
8535 else if (precis == 0 && elen == 1 && *eptr == '0')
8541 /* FLOATING POINT */
8544 c = 'f'; /* maybe %F isn't supported here */
8552 /* This is evil, but floating point is even more evil */
8554 /* for SV-style calling, we can only get NV
8555 for C-style calling, we assume %f is double;
8556 for simplicity we allow any of %Lf, %llf, %qf for long double
8560 #if defined(USE_LONG_DOUBLE)
8564 /* [perl #20339] - we should accept and ignore %lf rather than die */
8568 #if defined(USE_LONG_DOUBLE)
8569 intsize = args ? 0 : 'q';
8573 #if defined(HAS_LONG_DOUBLE)
8582 /* now we need (long double) if intsize == 'q', else (double) */
8584 #if LONG_DOUBLESIZE > DOUBLESIZE
8586 va_arg(*args, long double) :
8587 va_arg(*args, double)
8589 va_arg(*args, double)
8594 if (c != 'e' && c != 'E') {
8596 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
8597 will cast our (long double) to (double) */
8598 (void)Perl_frexp(nv, &i);
8599 if (i == PERL_INT_MIN)
8600 Perl_die(aTHX_ "panic: frexp");
8602 need = BIT_DIGITS(i);
8604 need += has_precis ? precis : 6; /* known default */
8609 #ifdef HAS_LDBL_SPRINTF_BUG
8610 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8611 with sfio - Allen <allens@cpan.org> */
8614 # define MY_DBL_MAX DBL_MAX
8615 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
8616 # if DOUBLESIZE >= 8
8617 # define MY_DBL_MAX 1.7976931348623157E+308L
8619 # define MY_DBL_MAX 3.40282347E+38L
8623 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
8624 # define MY_DBL_MAX_BUG 1L
8626 # define MY_DBL_MAX_BUG MY_DBL_MAX
8630 # define MY_DBL_MIN DBL_MIN
8631 # else /* XXX guessing! -Allen */
8632 # if DOUBLESIZE >= 8
8633 # define MY_DBL_MIN 2.2250738585072014E-308L
8635 # define MY_DBL_MIN 1.17549435E-38L
8639 if ((intsize == 'q') && (c == 'f') &&
8640 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
8642 /* it's going to be short enough that
8643 * long double precision is not needed */
8645 if ((nv <= 0L) && (nv >= -0L))
8646 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
8648 /* would use Perl_fp_class as a double-check but not
8649 * functional on IRIX - see perl.h comments */
8651 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
8652 /* It's within the range that a double can represent */
8653 #if defined(DBL_MAX) && !defined(DBL_MIN)
8654 if ((nv >= ((long double)1/DBL_MAX)) ||
8655 (nv <= (-(long double)1/DBL_MAX)))
8657 fix_ldbl_sprintf_bug = TRUE;
8660 if (fix_ldbl_sprintf_bug == TRUE) {
8670 # undef MY_DBL_MAX_BUG
8673 #endif /* HAS_LDBL_SPRINTF_BUG */
8675 need += 20; /* fudge factor */
8676 if (PL_efloatsize < need) {
8677 Safefree(PL_efloatbuf);
8678 PL_efloatsize = need + 20; /* more fudge */
8679 Newx(PL_efloatbuf, PL_efloatsize, char);
8680 PL_efloatbuf[0] = '\0';
8683 if ( !(width || left || plus || alt) && fill != '0'
8684 && has_precis && intsize != 'q' ) { /* Shortcuts */
8685 /* See earlier comment about buggy Gconvert when digits,
8687 if ( c == 'g' && precis) {
8688 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
8689 /* May return an empty string for digits==0 */
8690 if (*PL_efloatbuf) {
8691 elen = strlen(PL_efloatbuf);
8692 goto float_converted;
8694 } else if ( c == 'f' && !precis) {
8695 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
8700 char *ptr = ebuf + sizeof ebuf;
8703 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
8704 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
8705 if (intsize == 'q') {
8706 /* Copy the one or more characters in a long double
8707 * format before the 'base' ([efgEFG]) character to
8708 * the format string. */
8709 static char const prifldbl[] = PERL_PRIfldbl;
8710 char const *p = prifldbl + sizeof(prifldbl) - 3;
8711 while (p >= prifldbl) { *--ptr = *p--; }
8716 do { *--ptr = '0' + (base % 10); } while (base /= 10);
8721 do { *--ptr = '0' + (base % 10); } while (base /= 10);
8733 /* No taint. Otherwise we are in the strange situation
8734 * where printf() taints but print($float) doesn't.
8736 #if defined(HAS_LONG_DOUBLE)
8737 elen = ((intsize == 'q')
8738 ? my_sprintf(PL_efloatbuf, ptr, nv)
8739 : my_sprintf(PL_efloatbuf, ptr, (double)nv));
8741 elen = my_sprintf(PL_efloatbuf, ptr, nv);
8745 eptr = PL_efloatbuf;
8753 i = SvCUR(sv) - origlen;
8756 case 'h': *(va_arg(*args, short*)) = i; break;
8757 default: *(va_arg(*args, int*)) = i; break;
8758 case 'l': *(va_arg(*args, long*)) = i; break;
8759 case 'V': *(va_arg(*args, IV*)) = i; break;
8761 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
8766 sv_setuv_mg(argsv, (UV)i);
8767 continue; /* not "break" */
8774 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
8775 && ckWARN(WARN_PRINTF))
8777 SV * const msg = sv_newmortal();
8778 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
8779 (PL_op->op_type == OP_PRTF) ? "" : "s");
8782 Perl_sv_catpvf(aTHX_ msg,
8783 "\"%%%c\"", c & 0xFF);
8785 Perl_sv_catpvf(aTHX_ msg,
8786 "\"%%\\%03"UVof"\"",
8789 sv_catpvs(msg, "end of string");
8790 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
8793 /* output mangled stuff ... */
8799 /* ... right here, because formatting flags should not apply */
8800 SvGROW(sv, SvCUR(sv) + elen + 1);
8802 Copy(eptr, p, elen, char);
8805 SvCUR_set(sv, p - SvPVX_const(sv));
8807 continue; /* not "break" */
8810 /* calculate width before utf8_upgrade changes it */
8811 have = esignlen + zeros + elen;
8813 Perl_croak_nocontext(PL_memory_wrap);
8815 if (is_utf8 != has_utf8) {
8818 sv_utf8_upgrade(sv);
8821 SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
8822 sv_utf8_upgrade(nsv);
8823 eptr = SvPVX_const(nsv);
8826 SvGROW(sv, SvCUR(sv) + elen + 1);
8831 need = (have > width ? have : width);
8834 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
8835 Perl_croak_nocontext(PL_memory_wrap);
8836 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
8838 if (esignlen && fill == '0') {
8840 for (i = 0; i < (int)esignlen; i++)
8844 memset(p, fill, gap);
8847 if (esignlen && fill != '0') {
8849 for (i = 0; i < (int)esignlen; i++)
8854 for (i = zeros; i; i--)
8858 Copy(eptr, p, elen, char);
8862 memset(p, ' ', gap);
8867 Copy(dotstr, p, dotstrlen, char);
8871 vectorize = FALSE; /* done iterating over vecstr */
8878 SvCUR_set(sv, p - SvPVX_const(sv));
8886 /* =========================================================================
8888 =head1 Cloning an interpreter
8890 All the macros and functions in this section are for the private use of
8891 the main function, perl_clone().
8893 The foo_dup() functions make an exact copy of an existing foo thinngy.
8894 During the course of a cloning, a hash table is used to map old addresses
8895 to new addresses. The table is created and manipulated with the
8896 ptr_table_* functions.
8900 ============================================================================*/
8903 #if defined(USE_ITHREADS)
8905 #ifndef GpREFCNT_inc
8906 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
8910 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8911 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
8912 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8913 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
8914 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8915 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
8916 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8917 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
8918 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
8919 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
8920 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8921 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
8922 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
8925 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
8926 regcomp.c. AMS 20010712 */
8929 Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
8934 struct reg_substr_datum *s;
8937 return (REGEXP *)NULL;
8939 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8942 len = r->offsets[0];
8943 npar = r->nparens+1;
8945 Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
8946 Copy(r->program, ret->program, len+1, regnode);
8948 Newx(ret->startp, npar, I32);
8949 Copy(r->startp, ret->startp, npar, I32);
8950 Newx(ret->endp, npar, I32);
8951 Copy(r->startp, ret->startp, npar, I32);
8953 Newx(ret->substrs, 1, struct reg_substr_data);
8954 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8955 s->min_offset = r->substrs->data[i].min_offset;
8956 s->max_offset = r->substrs->data[i].max_offset;
8957 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
8958 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
8961 ret->regstclass = NULL;
8964 const int count = r->data->count;
8967 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
8968 char, struct reg_data);
8969 Newx(d->what, count, U8);
8972 for (i = 0; i < count; i++) {
8973 d->what[i] = r->data->what[i];
8974 switch (d->what[i]) {
8975 /* legal options are one of: sfpont
8976 see also regcomp.h and pregfree() */
8978 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
8981 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
8984 /* This is cheating. */
8985 Newx(d->data[i], 1, struct regnode_charclass_class);
8986 StructCopy(r->data->data[i], d->data[i],
8987 struct regnode_charclass_class);
8988 ret->regstclass = (regnode*)d->data[i];
8991 /* Compiled op trees are readonly, and can thus be
8992 shared without duplication. */
8994 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
8998 d->data[i] = r->data->data[i];
9001 d->data[i] = r->data->data[i];
9003 ((reg_trie_data*)d->data[i])->refcount++;
9007 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
9016 Newx(ret->offsets, 2*len+1, U32);
9017 Copy(r->offsets, ret->offsets, 2*len+1, U32);
9019 ret->precomp = SAVEPVN(r->precomp, r->prelen);
9020 ret->refcnt = r->refcnt;
9021 ret->minlen = r->minlen;
9022 ret->prelen = r->prelen;
9023 ret->nparens = r->nparens;
9024 ret->lastparen = r->lastparen;
9025 ret->lastcloseparen = r->lastcloseparen;
9026 ret->reganch = r->reganch;
9028 ret->sublen = r->sublen;
9030 if (RX_MATCH_COPIED(ret))
9031 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
9034 #ifdef PERL_OLD_COPY_ON_WRITE
9035 ret->saved_copy = NULL;
9038 ptr_table_store(PL_ptr_table, r, ret);
9042 /* duplicate a file handle */
9045 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9049 PERL_UNUSED_ARG(type);
9052 return (PerlIO*)NULL;
9054 /* look for it in the table first */
9055 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
9059 /* create anew and remember what it is */
9060 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
9061 ptr_table_store(PL_ptr_table, fp, ret);
9065 /* duplicate a directory handle */
9068 Perl_dirp_dup(pTHX_ DIR *dp)
9076 /* duplicate a typeglob */
9079 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
9084 /* look for it in the table first */
9085 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
9089 /* create anew and remember what it is */
9091 ptr_table_store(PL_ptr_table, gp, ret);
9094 ret->gp_refcnt = 0; /* must be before any other dups! */
9095 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
9096 ret->gp_io = io_dup_inc(gp->gp_io, param);
9097 ret->gp_form = cv_dup_inc(gp->gp_form, param);
9098 ret->gp_av = av_dup_inc(gp->gp_av, param);
9099 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
9100 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
9101 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
9102 ret->gp_cvgen = gp->gp_cvgen;
9103 ret->gp_line = gp->gp_line;
9104 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
9108 /* duplicate a chain of magic */
9111 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9113 MAGIC *mgprev = (MAGIC*)NULL;
9116 return (MAGIC*)NULL;
9117 /* look for it in the table first */
9118 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9122 for (; mg; mg = mg->mg_moremagic) {
9124 Newxz(nmg, 1, MAGIC);
9126 mgprev->mg_moremagic = nmg;
9129 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
9130 nmg->mg_private = mg->mg_private;
9131 nmg->mg_type = mg->mg_type;
9132 nmg->mg_flags = mg->mg_flags;
9133 if (mg->mg_type == PERL_MAGIC_qr) {
9134 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
9136 else if(mg->mg_type == PERL_MAGIC_backref) {
9137 /* The backref AV has its reference count deliberately bumped by
9139 nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param));
9141 else if (mg->mg_type == PERL_MAGIC_symtab) {
9142 nmg->mg_obj = mg->mg_obj;
9145 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
9146 ? sv_dup_inc(mg->mg_obj, param)
9147 : sv_dup(mg->mg_obj, param);
9149 nmg->mg_len = mg->mg_len;
9150 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
9151 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
9152 if (mg->mg_len > 0) {
9153 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
9154 if (mg->mg_type == PERL_MAGIC_overload_table &&
9155 AMT_AMAGIC((AMT*)mg->mg_ptr))
9157 const AMT * const amtp = (AMT*)mg->mg_ptr;
9158 AMT * const namtp = (AMT*)nmg->mg_ptr;
9160 for (i = 1; i < NofAMmeth; i++) {
9161 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9165 else if (mg->mg_len == HEf_SVKEY)
9166 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9168 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9169 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
9176 /* create a new pointer-mapping table */
9179 Perl_ptr_table_new(pTHX)
9182 Newxz(tbl, 1, PTR_TBL_t);
9185 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
9189 #define PTR_TABLE_HASH(ptr) \
9190 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
9193 we use the PTE_SVSLOT 'reservation' made above, both here (in the
9194 following define) and at call to new_body_inline made below in
9195 Perl_ptr_table_store()
9198 #define del_pte(p) del_body_type(p, PTE_SVSLOT)
9200 /* map an existing pointer using a table */
9202 STATIC PTR_TBL_ENT_t *
9203 S_ptr_table_find(pTHX_ PTR_TBL_t *tbl, const void *sv) {
9204 PTR_TBL_ENT_t *tblent;
9205 const UV hash = PTR_TABLE_HASH(sv);
9207 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9208 for (; tblent; tblent = tblent->next) {
9209 if (tblent->oldval == sv)
9216 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
9218 PTR_TBL_ENT_t const *const tblent = S_ptr_table_find(aTHX_ tbl, sv);
9219 return tblent ? tblent->newval : (void *) 0;
9222 /* add a new entry to a pointer-mapping table */
9225 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
9227 PTR_TBL_ENT_t *tblent = S_ptr_table_find(aTHX_ tbl, oldsv);
9230 tblent->newval = newsv;
9232 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
9234 new_body_inline(tblent, sizeof(struct ptr_tbl_ent), PTE_SVSLOT);
9235 tblent->oldval = oldsv;
9236 tblent->newval = newsv;
9237 tblent->next = tbl->tbl_ary[entry];
9238 tbl->tbl_ary[entry] = tblent;
9240 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
9241 ptr_table_split(tbl);
9245 /* double the hash bucket size of an existing ptr table */
9248 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9250 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9251 const UV oldsize = tbl->tbl_max + 1;
9252 UV newsize = oldsize * 2;
9255 Renew(ary, newsize, PTR_TBL_ENT_t*);
9256 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9257 tbl->tbl_max = --newsize;
9259 for (i=0; i < oldsize; i++, ary++) {
9260 PTR_TBL_ENT_t **curentp, **entp, *ent;
9263 curentp = ary + oldsize;
9264 for (entp = ary, ent = *ary; ent; ent = *entp) {
9265 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
9267 ent->next = *curentp;
9277 /* remove all the entries from a ptr table */
9280 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9282 if (tbl && tbl->tbl_items) {
9283 register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary;
9284 UV riter = tbl->tbl_max;
9287 PTR_TBL_ENT_t *entry = array[riter];
9290 PTR_TBL_ENT_t * const oentry = entry;
9291 entry = entry->next;
9300 /* clear and free a ptr table */
9303 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
9308 ptr_table_clear(tbl);
9309 Safefree(tbl->tbl_ary);
9315 Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param)
9318 SvRV_set(dstr, SvWEAKREF(sstr)
9319 ? sv_dup(SvRV(sstr), param)
9320 : sv_dup_inc(SvRV(sstr), param));
9323 else if (SvPVX_const(sstr)) {
9324 /* Has something there */
9326 /* Normal PV - clone whole allocated space */
9327 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
9328 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9329 /* Not that normal - actually sstr is copy on write.
9330 But we are a true, independant SV, so: */
9331 SvREADONLY_off(dstr);
9336 /* Special case - not normally malloced for some reason */
9337 if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
9338 /* A "shared" PV - clone it as "shared" PV */
9340 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
9344 /* Some other special case - random pointer */
9345 SvPV_set(dstr, SvPVX(sstr));
9351 if (SvTYPE(dstr) == SVt_RV)
9352 SvRV_set(dstr, NULL);
9354 SvPV_set(dstr, NULL);
9358 /* duplicate an SV of any type (including AV, HV etc) */
9361 Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
9366 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
9368 /* look for it in the table first */
9369 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
9373 if(param->flags & CLONEf_JOIN_IN) {
9374 /** We are joining here so we don't want do clone
9375 something that is bad **/
9376 if (SvTYPE(sstr) == SVt_PVHV) {
9377 const char * const hvname = HvNAME_get(sstr);
9379 /** don't clone stashes if they already exist **/
9380 return (SV*)gv_stashpv(hvname,0);
9384 /* create anew and remember what it is */
9387 #ifdef DEBUG_LEAKING_SCALARS
9388 dstr->sv_debug_optype = sstr->sv_debug_optype;
9389 dstr->sv_debug_line = sstr->sv_debug_line;
9390 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
9391 dstr->sv_debug_cloned = 1;
9392 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
9395 ptr_table_store(PL_ptr_table, sstr, dstr);
9398 SvFLAGS(dstr) = SvFLAGS(sstr);
9399 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
9400 SvREFCNT(dstr) = 0; /* must be before any other dups! */
9403 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
9404 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
9405 PL_watch_pvx, SvPVX_const(sstr));
9408 /* don't clone objects whose class has asked us not to */
9409 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
9410 SvFLAGS(dstr) &= ~SVTYPEMASK;
9415 switch (SvTYPE(sstr)) {
9420 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
9421 SvIV_set(dstr, SvIVX(sstr));
9424 SvANY(dstr) = new_XNV();
9425 SvNV_set(dstr, SvNVX(sstr));
9428 SvANY(dstr) = &(dstr->sv_u.svu_rv);
9429 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9433 /* These are all the types that need complex bodies allocating. */
9435 const svtype sv_type = SvTYPE(sstr);
9436 const struct body_details *const sv_type_details
9437 = bodies_by_type + sv_type;
9441 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]",
9446 if (GvUNIQUE((GV*)sstr)) {
9447 /* Do sharing here, and fall through */
9460 assert(sv_type_details->size);
9461 if (sv_type_details->arena) {
9462 new_body_inline(new_body, sv_type_details->size, sv_type);
9464 = (void*)((char*)new_body - sv_type_details->offset);
9466 new_body = new_NOARENA(sv_type_details);
9470 SvANY(dstr) = new_body;
9473 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
9474 ((char*)SvANY(dstr)) + sv_type_details->offset,
9475 sv_type_details->copy, char);
9477 Copy(((char*)SvANY(sstr)),
9478 ((char*)SvANY(dstr)),
9479 sv_type_details->size + sv_type_details->offset, char);
9482 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV)
9483 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9485 /* The Copy above means that all the source (unduplicated) pointers
9486 are now in the destination. We can check the flags and the
9487 pointers in either, but it's possible that there's less cache
9488 missing by always going for the destination.
9489 FIXME - instrument and check that assumption */
9490 if (sv_type >= SVt_PVMG) {
9492 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
9494 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
9497 /* The cast silences a GCC warning about unhandled types. */
9498 switch ((int)sv_type) {
9510 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
9511 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
9512 LvTARG(dstr) = dstr;
9513 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
9514 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
9516 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
9519 GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
9520 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
9521 /* Don't call sv_add_backref here as it's going to be created
9522 as part of the magic cloning of the symbol table. */
9523 GvGP(dstr) = gp_dup(GvGP(dstr), param);
9524 (void)GpREFCNT_inc(GvGP(dstr));
9527 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
9528 if (IoOFP(dstr) == IoIFP(sstr))
9529 IoOFP(dstr) = IoIFP(dstr);
9531 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
9532 /* PL_rsfp_filters entries have fake IoDIRP() */
9533 if (IoDIRP(dstr) && !(IoFLAGS(dstr) & IOf_FAKE_DIRP))
9534 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
9535 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
9536 /* I have no idea why fake dirp (rsfps)
9537 should be treated differently but otherwise
9538 we end up with leaks -- sky*/
9539 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
9540 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
9541 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
9543 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
9544 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
9545 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
9547 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
9548 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
9549 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
9552 if (AvARRAY((AV*)sstr)) {
9553 SV **dst_ary, **src_ary;
9554 SSize_t items = AvFILLp((AV*)sstr) + 1;
9556 src_ary = AvARRAY((AV*)sstr);
9557 Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
9558 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
9559 SvPV_set(dstr, (char*)dst_ary);
9560 AvALLOC((AV*)dstr) = dst_ary;
9561 if (AvREAL((AV*)sstr)) {
9563 *dst_ary++ = sv_dup_inc(*src_ary++, param);
9567 *dst_ary++ = sv_dup(*src_ary++, param);
9569 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
9570 while (items-- > 0) {
9571 *dst_ary++ = &PL_sv_undef;
9575 SvPV_set(dstr, NULL);
9576 AvALLOC((AV*)dstr) = (SV**)NULL;
9583 if (HvARRAY((HV*)sstr)) {
9585 const bool sharekeys = !!HvSHAREKEYS(sstr);
9586 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
9587 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
9589 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
9590 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
9592 HvARRAY(dstr) = (HE**)darray;
9593 while (i <= sxhv->xhv_max) {
9594 const HE *source = HvARRAY(sstr)[i];
9595 HvARRAY(dstr)[i] = source
9596 ? he_dup(source, sharekeys, param) : 0;
9600 struct xpvhv_aux * const saux = HvAUX(sstr);
9601 struct xpvhv_aux * const daux = HvAUX(dstr);
9602 /* This flag isn't copied. */
9603 /* SvOOK_on(hv) attacks the IV flags. */
9604 SvFLAGS(dstr) |= SVf_OOK;
9606 hvname = saux->xhv_name;
9608 = hvname ? hek_dup(hvname, param) : hvname;
9610 daux->xhv_riter = saux->xhv_riter;
9611 daux->xhv_eiter = saux->xhv_eiter
9612 ? he_dup(saux->xhv_eiter,
9613 (bool)!!HvSHAREKEYS(sstr), param) : 0;
9614 daux->xhv_backreferences = saux->xhv_backreferences
9615 ? (AV*) SvREFCNT_inc(
9623 SvPV_set(dstr, NULL);
9625 /* Record stashes for possible cloning in Perl_clone(). */
9627 av_push(param->stashes, dstr);
9632 /* NOTE: not refcounted */
9633 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
9635 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
9637 if (CvCONST(dstr)) {
9638 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
9639 SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
9640 sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
9642 /* don't dup if copying back - CvGV isn't refcounted, so the
9643 * duped GV may never be freed. A bit of a hack! DAPM */
9644 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
9645 NULL : gv_dup(CvGV(dstr), param) ;
9646 if (!(param->flags & CLONEf_COPY_STACKS)) {
9649 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
9652 ? cv_dup( CvOUTSIDE(dstr), param)
9653 : cv_dup_inc(CvOUTSIDE(dstr), param);
9655 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
9661 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9667 /* duplicate a context */
9670 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
9675 return (PERL_CONTEXT*)NULL;
9677 /* look for it in the table first */
9678 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
9682 /* create anew and remember what it is */
9683 Newxz(ncxs, max + 1, PERL_CONTEXT);
9684 ptr_table_store(PL_ptr_table, cxs, ncxs);
9687 PERL_CONTEXT * const cx = &cxs[ix];
9688 PERL_CONTEXT * const ncx = &ncxs[ix];
9689 ncx->cx_type = cx->cx_type;
9690 if (CxTYPE(cx) == CXt_SUBST) {
9691 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
9694 ncx->blk_oldsp = cx->blk_oldsp;
9695 ncx->blk_oldcop = cx->blk_oldcop;
9696 ncx->blk_oldmarksp = cx->blk_oldmarksp;
9697 ncx->blk_oldscopesp = cx->blk_oldscopesp;
9698 ncx->blk_oldpm = cx->blk_oldpm;
9699 ncx->blk_gimme = cx->blk_gimme;
9700 switch (CxTYPE(cx)) {
9702 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
9703 ? cv_dup_inc(cx->blk_sub.cv, param)
9704 : cv_dup(cx->blk_sub.cv,param));
9705 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
9706 ? av_dup_inc(cx->blk_sub.argarray, param)
9708 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
9709 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
9710 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9711 ncx->blk_sub.lval = cx->blk_sub.lval;
9712 ncx->blk_sub.retop = cx->blk_sub.retop;
9715 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
9716 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
9717 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
9718 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
9719 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
9720 ncx->blk_eval.retop = cx->blk_eval.retop;
9723 ncx->blk_loop.label = cx->blk_loop.label;
9724 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
9725 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
9726 ncx->blk_loop.next_op = cx->blk_loop.next_op;
9727 ncx->blk_loop.last_op = cx->blk_loop.last_op;
9728 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
9729 ? cx->blk_loop.iterdata
9730 : gv_dup((GV*)cx->blk_loop.iterdata, param));
9731 ncx->blk_loop.oldcomppad
9732 = (PAD*)ptr_table_fetch(PL_ptr_table,
9733 cx->blk_loop.oldcomppad);
9734 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
9735 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
9736 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
9737 ncx->blk_loop.iterix = cx->blk_loop.iterix;
9738 ncx->blk_loop.itermax = cx->blk_loop.itermax;
9741 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
9742 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
9743 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
9744 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9745 ncx->blk_sub.retop = cx->blk_sub.retop;
9757 /* duplicate a stack info structure */
9760 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
9765 return (PERL_SI*)NULL;
9767 /* look for it in the table first */
9768 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
9772 /* create anew and remember what it is */
9773 Newxz(nsi, 1, PERL_SI);
9774 ptr_table_store(PL_ptr_table, si, nsi);
9776 nsi->si_stack = av_dup_inc(si->si_stack, param);
9777 nsi->si_cxix = si->si_cxix;
9778 nsi->si_cxmax = si->si_cxmax;
9779 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
9780 nsi->si_type = si->si_type;
9781 nsi->si_prev = si_dup(si->si_prev, param);
9782 nsi->si_next = si_dup(si->si_next, param);
9783 nsi->si_markoff = si->si_markoff;
9788 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
9789 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
9790 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
9791 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
9792 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
9793 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
9794 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
9795 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
9796 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
9797 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
9798 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
9799 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
9800 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
9801 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
9804 #define pv_dup_inc(p) SAVEPV(p)
9805 #define pv_dup(p) SAVEPV(p)
9806 #define svp_dup_inc(p,pp) any_dup(p,pp)
9808 /* map any object to the new equivent - either something in the
9809 * ptr table, or something in the interpreter structure
9813 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
9820 /* look for it in the table first */
9821 ret = ptr_table_fetch(PL_ptr_table, v);
9825 /* see if it is part of the interpreter structure */
9826 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
9827 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
9835 /* duplicate the save stack */
9838 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
9840 ANY * const ss = proto_perl->Tsavestack;
9841 const I32 max = proto_perl->Tsavestack_max;
9842 I32 ix = proto_perl->Tsavestack_ix;
9854 void (*dptr) (void*);
9855 void (*dxptr) (pTHX_ void*);
9857 Newxz(nss, max, ANY);
9860 I32 i = POPINT(ss,ix);
9863 case SAVEt_ITEM: /* normal string */
9864 sv = (SV*)POPPTR(ss,ix);
9865 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9866 sv = (SV*)POPPTR(ss,ix);
9867 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9869 case SAVEt_SV: /* scalar reference */
9870 sv = (SV*)POPPTR(ss,ix);
9871 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9872 gv = (GV*)POPPTR(ss,ix);
9873 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9875 case SAVEt_GENERIC_PVREF: /* generic char* */
9876 c = (char*)POPPTR(ss,ix);
9877 TOPPTR(nss,ix) = pv_dup(c);
9878 ptr = POPPTR(ss,ix);
9879 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9881 case SAVEt_SHARED_PVREF: /* char* in shared space */
9882 c = (char*)POPPTR(ss,ix);
9883 TOPPTR(nss,ix) = savesharedpv(c);
9884 ptr = POPPTR(ss,ix);
9885 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9887 case SAVEt_GENERIC_SVREF: /* generic sv */
9888 case SAVEt_SVREF: /* scalar reference */
9889 sv = (SV*)POPPTR(ss,ix);
9890 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9891 ptr = POPPTR(ss,ix);
9892 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
9894 case SAVEt_AV: /* array reference */
9895 av = (AV*)POPPTR(ss,ix);
9896 TOPPTR(nss,ix) = av_dup_inc(av, param);
9897 gv = (GV*)POPPTR(ss,ix);
9898 TOPPTR(nss,ix) = gv_dup(gv, param);
9900 case SAVEt_HV: /* hash reference */
9901 hv = (HV*)POPPTR(ss,ix);
9902 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9903 gv = (GV*)POPPTR(ss,ix);
9904 TOPPTR(nss,ix) = gv_dup(gv, param);
9906 case SAVEt_INT: /* int reference */
9907 ptr = POPPTR(ss,ix);
9908 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9909 intval = (int)POPINT(ss,ix);
9910 TOPINT(nss,ix) = intval;
9912 case SAVEt_LONG: /* long reference */
9913 ptr = POPPTR(ss,ix);
9914 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9915 longval = (long)POPLONG(ss,ix);
9916 TOPLONG(nss,ix) = longval;
9918 case SAVEt_I32: /* I32 reference */
9919 case SAVEt_I16: /* I16 reference */
9920 case SAVEt_I8: /* I8 reference */
9921 ptr = POPPTR(ss,ix);
9922 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9926 case SAVEt_IV: /* IV reference */
9927 ptr = POPPTR(ss,ix);
9928 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9932 case SAVEt_SPTR: /* SV* reference */
9933 ptr = POPPTR(ss,ix);
9934 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9935 sv = (SV*)POPPTR(ss,ix);
9936 TOPPTR(nss,ix) = sv_dup(sv, param);
9938 case SAVEt_VPTR: /* random* reference */
9939 ptr = POPPTR(ss,ix);
9940 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9941 ptr = POPPTR(ss,ix);
9942 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9944 case SAVEt_PPTR: /* char* reference */
9945 ptr = POPPTR(ss,ix);
9946 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9947 c = (char*)POPPTR(ss,ix);
9948 TOPPTR(nss,ix) = pv_dup(c);
9950 case SAVEt_HPTR: /* HV* reference */
9951 ptr = POPPTR(ss,ix);
9952 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9953 hv = (HV*)POPPTR(ss,ix);
9954 TOPPTR(nss,ix) = hv_dup(hv, param);
9956 case SAVEt_APTR: /* AV* reference */
9957 ptr = POPPTR(ss,ix);
9958 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9959 av = (AV*)POPPTR(ss,ix);
9960 TOPPTR(nss,ix) = av_dup(av, param);
9963 gv = (GV*)POPPTR(ss,ix);
9964 TOPPTR(nss,ix) = gv_dup(gv, param);
9966 case SAVEt_GP: /* scalar reference */
9967 gp = (GP*)POPPTR(ss,ix);
9968 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
9969 (void)GpREFCNT_inc(gp);
9970 gv = (GV*)POPPTR(ss,ix);
9971 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9972 c = (char*)POPPTR(ss,ix);
9973 TOPPTR(nss,ix) = pv_dup(c);
9980 case SAVEt_MORTALIZESV:
9981 sv = (SV*)POPPTR(ss,ix);
9982 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9985 ptr = POPPTR(ss,ix);
9986 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
9987 /* these are assumed to be refcounted properly */
9989 switch (((OP*)ptr)->op_type) {
9996 TOPPTR(nss,ix) = ptr;
10001 TOPPTR(nss,ix) = Nullop;
10006 TOPPTR(nss,ix) = Nullop;
10009 c = (char*)POPPTR(ss,ix);
10010 TOPPTR(nss,ix) = pv_dup_inc(c);
10012 case SAVEt_CLEARSV:
10013 longval = POPLONG(ss,ix);
10014 TOPLONG(nss,ix) = longval;
10017 hv = (HV*)POPPTR(ss,ix);
10018 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10019 c = (char*)POPPTR(ss,ix);
10020 TOPPTR(nss,ix) = pv_dup_inc(c);
10022 TOPINT(nss,ix) = i;
10024 case SAVEt_DESTRUCTOR:
10025 ptr = POPPTR(ss,ix);
10026 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10027 dptr = POPDPTR(ss,ix);
10028 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
10029 any_dup(FPTR2DPTR(void *, dptr),
10032 case SAVEt_DESTRUCTOR_X:
10033 ptr = POPPTR(ss,ix);
10034 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10035 dxptr = POPDXPTR(ss,ix);
10036 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
10037 any_dup(FPTR2DPTR(void *, dxptr),
10040 case SAVEt_REGCONTEXT:
10043 TOPINT(nss,ix) = i;
10046 case SAVEt_STACK_POS: /* Position on Perl stack */
10048 TOPINT(nss,ix) = i;
10050 case SAVEt_AELEM: /* array element */
10051 sv = (SV*)POPPTR(ss,ix);
10052 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10054 TOPINT(nss,ix) = i;
10055 av = (AV*)POPPTR(ss,ix);
10056 TOPPTR(nss,ix) = av_dup_inc(av, param);
10058 case SAVEt_HELEM: /* hash element */
10059 sv = (SV*)POPPTR(ss,ix);
10060 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10061 sv = (SV*)POPPTR(ss,ix);
10062 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10063 hv = (HV*)POPPTR(ss,ix);
10064 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10067 ptr = POPPTR(ss,ix);
10068 TOPPTR(nss,ix) = ptr;
10072 TOPINT(nss,ix) = i;
10074 case SAVEt_COMPPAD:
10075 av = (AV*)POPPTR(ss,ix);
10076 TOPPTR(nss,ix) = av_dup(av, param);
10079 longval = (long)POPLONG(ss,ix);
10080 TOPLONG(nss,ix) = longval;
10081 ptr = POPPTR(ss,ix);
10082 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10083 sv = (SV*)POPPTR(ss,ix);
10084 TOPPTR(nss,ix) = sv_dup(sv, param);
10087 ptr = POPPTR(ss,ix);
10088 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10089 longval = (long)POPBOOL(ss,ix);
10090 TOPBOOL(nss,ix) = (bool)longval;
10092 case SAVEt_SET_SVFLAGS:
10094 TOPINT(nss,ix) = i;
10096 TOPINT(nss,ix) = i;
10097 sv = (SV*)POPPTR(ss,ix);
10098 TOPPTR(nss,ix) = sv_dup(sv, param);
10101 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
10109 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
10110 * flag to the result. This is done for each stash before cloning starts,
10111 * so we know which stashes want their objects cloned */
10114 do_mark_cloneable_stash(pTHX_ SV *sv)
10116 const HEK * const hvname = HvNAME_HEK((HV*)sv);
10118 GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
10119 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
10120 if (cloner && GvCV(cloner)) {
10127 XPUSHs(sv_2mortal(newSVhek(hvname)));
10129 call_sv((SV*)GvCV(cloner), G_SCALAR);
10136 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
10144 =for apidoc perl_clone
10146 Create and return a new interpreter by cloning the current one.
10148 perl_clone takes these flags as parameters:
10150 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
10151 without it we only clone the data and zero the stacks,
10152 with it we copy the stacks and the new perl interpreter is
10153 ready to run at the exact same point as the previous one.
10154 The pseudo-fork code uses COPY_STACKS while the
10155 threads->new doesn't.
10157 CLONEf_KEEP_PTR_TABLE
10158 perl_clone keeps a ptr_table with the pointer of the old
10159 variable as a key and the new variable as a value,
10160 this allows it to check if something has been cloned and not
10161 clone it again but rather just use the value and increase the
10162 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
10163 the ptr_table using the function
10164 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
10165 reason to keep it around is if you want to dup some of your own
10166 variable who are outside the graph perl scans, example of this
10167 code is in threads.xs create
10170 This is a win32 thing, it is ignored on unix, it tells perls
10171 win32host code (which is c++) to clone itself, this is needed on
10172 win32 if you want to run two threads at the same time,
10173 if you just want to do some stuff in a separate perl interpreter
10174 and then throw it away and return to the original one,
10175 you don't need to do anything.
10180 /* XXX the above needs expanding by someone who actually understands it ! */
10181 EXTERN_C PerlInterpreter *
10182 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10185 perl_clone(PerlInterpreter *proto_perl, UV flags)
10188 #ifdef PERL_IMPLICIT_SYS
10190 /* perlhost.h so we need to call into it
10191 to clone the host, CPerlHost should have a c interface, sky */
10193 if (flags & CLONEf_CLONE_HOST) {
10194 return perl_clone_host(proto_perl,flags);
10196 return perl_clone_using(proto_perl, flags,
10198 proto_perl->IMemShared,
10199 proto_perl->IMemParse,
10201 proto_perl->IStdIO,
10205 proto_perl->IProc);
10209 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10210 struct IPerlMem* ipM, struct IPerlMem* ipMS,
10211 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10212 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10213 struct IPerlDir* ipD, struct IPerlSock* ipS,
10214 struct IPerlProc* ipP)
10216 /* XXX many of the string copies here can be optimized if they're
10217 * constants; they need to be allocated as common memory and just
10218 * their pointers copied. */
10221 CLONE_PARAMS clone_params;
10222 CLONE_PARAMS* param = &clone_params;
10224 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10225 /* for each stash, determine whether its objects should be cloned */
10226 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10227 PERL_SET_THX(my_perl);
10230 Poison(my_perl, 1, PerlInterpreter);
10232 PL_curcop = (COP *)Nullop;
10236 PL_savestack_ix = 0;
10237 PL_savestack_max = -1;
10238 PL_sig_pending = 0;
10239 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10240 # else /* !DEBUGGING */
10241 Zero(my_perl, 1, PerlInterpreter);
10242 # endif /* DEBUGGING */
10244 /* host pointers */
10246 PL_MemShared = ipMS;
10247 PL_MemParse = ipMP;
10254 #else /* !PERL_IMPLICIT_SYS */
10256 CLONE_PARAMS clone_params;
10257 CLONE_PARAMS* param = &clone_params;
10258 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10259 /* for each stash, determine whether its objects should be cloned */
10260 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10261 PERL_SET_THX(my_perl);
10264 Poison(my_perl, 1, PerlInterpreter);
10266 PL_curcop = (COP *)Nullop;
10270 PL_savestack_ix = 0;
10271 PL_savestack_max = -1;
10272 PL_sig_pending = 0;
10273 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10274 # else /* !DEBUGGING */
10275 Zero(my_perl, 1, PerlInterpreter);
10276 # endif /* DEBUGGING */
10277 #endif /* PERL_IMPLICIT_SYS */
10278 param->flags = flags;
10279 param->proto_perl = proto_perl;
10281 PL_body_arenas = NULL;
10282 Zero(&PL_body_roots, 1, PL_body_roots);
10284 PL_nice_chunk = NULL;
10285 PL_nice_chunk_size = 0;
10287 PL_sv_objcount = 0;
10289 PL_sv_arenaroot = NULL;
10291 PL_debug = proto_perl->Idebug;
10293 PL_hash_seed = proto_perl->Ihash_seed;
10294 PL_rehash_seed = proto_perl->Irehash_seed;
10296 #ifdef USE_REENTRANT_API
10297 /* XXX: things like -Dm will segfault here in perlio, but doing
10298 * PERL_SET_CONTEXT(proto_perl);
10299 * breaks too many other things
10301 Perl_reentrant_init(aTHX);
10304 /* create SV map for pointer relocation */
10305 PL_ptr_table = ptr_table_new();
10307 /* initialize these special pointers as early as possible */
10308 SvANY(&PL_sv_undef) = NULL;
10309 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
10310 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
10311 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
10313 SvANY(&PL_sv_no) = new_XPVNV();
10314 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
10315 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
10316 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10317 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
10318 SvCUR_set(&PL_sv_no, 0);
10319 SvLEN_set(&PL_sv_no, 1);
10320 SvIV_set(&PL_sv_no, 0);
10321 SvNV_set(&PL_sv_no, 0);
10322 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
10324 SvANY(&PL_sv_yes) = new_XPVNV();
10325 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
10326 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
10327 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10328 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
10329 SvCUR_set(&PL_sv_yes, 1);
10330 SvLEN_set(&PL_sv_yes, 2);
10331 SvIV_set(&PL_sv_yes, 1);
10332 SvNV_set(&PL_sv_yes, 1);
10333 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
10335 /* create (a non-shared!) shared string table */
10336 PL_strtab = newHV();
10337 HvSHAREKEYS_off(PL_strtab);
10338 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
10339 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
10341 PL_compiling = proto_perl->Icompiling;
10343 /* These two PVs will be free'd special way so must set them same way op.c does */
10344 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
10345 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
10347 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
10348 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
10350 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
10351 if (!specialWARN(PL_compiling.cop_warnings))
10352 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
10353 if (!specialCopIO(PL_compiling.cop_io))
10354 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
10355 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
10357 /* pseudo environmental stuff */
10358 PL_origargc = proto_perl->Iorigargc;
10359 PL_origargv = proto_perl->Iorigargv;
10361 param->stashes = newAV(); /* Setup array of objects to call clone on */
10363 /* Set tainting stuff before PerlIO_debug can possibly get called */
10364 PL_tainting = proto_perl->Itainting;
10365 PL_taint_warn = proto_perl->Itaint_warn;
10367 #ifdef PERLIO_LAYERS
10368 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
10369 PerlIO_clone(aTHX_ proto_perl, param);
10372 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
10373 PL_incgv = gv_dup(proto_perl->Iincgv, param);
10374 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
10375 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
10376 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
10377 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
10380 PL_minus_c = proto_perl->Iminus_c;
10381 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
10382 PL_localpatches = proto_perl->Ilocalpatches;
10383 PL_splitstr = proto_perl->Isplitstr;
10384 PL_preprocess = proto_perl->Ipreprocess;
10385 PL_minus_n = proto_perl->Iminus_n;
10386 PL_minus_p = proto_perl->Iminus_p;
10387 PL_minus_l = proto_perl->Iminus_l;
10388 PL_minus_a = proto_perl->Iminus_a;
10389 PL_minus_E = proto_perl->Iminus_E;
10390 PL_minus_F = proto_perl->Iminus_F;
10391 PL_doswitches = proto_perl->Idoswitches;
10392 PL_dowarn = proto_perl->Idowarn;
10393 PL_doextract = proto_perl->Idoextract;
10394 PL_sawampersand = proto_perl->Isawampersand;
10395 PL_unsafe = proto_perl->Iunsafe;
10396 PL_inplace = SAVEPV(proto_perl->Iinplace);
10397 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
10398 PL_perldb = proto_perl->Iperldb;
10399 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
10400 PL_exit_flags = proto_perl->Iexit_flags;
10402 /* magical thingies */
10403 /* XXX time(&PL_basetime) when asked for? */
10404 PL_basetime = proto_perl->Ibasetime;
10405 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
10407 PL_maxsysfd = proto_perl->Imaxsysfd;
10408 PL_multiline = proto_perl->Imultiline;
10409 PL_statusvalue = proto_perl->Istatusvalue;
10411 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
10413 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
10415 PL_encoding = sv_dup(proto_perl->Iencoding, param);
10417 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
10418 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
10419 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
10421 /* Clone the regex array */
10422 PL_regex_padav = newAV();
10424 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
10425 SV* const * const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
10427 av_push(PL_regex_padav,
10428 sv_dup_inc(regexen[0],param));
10429 for(i = 1; i <= len; i++) {
10430 const SV * const regex = regexen[i];
10433 ? sv_dup_inc(regex, param)
10435 newSViv(PTR2IV(re_dup(
10436 INT2PTR(REGEXP *, SvIVX(regex)), param))))
10438 av_push(PL_regex_padav, sv);
10441 PL_regex_pad = AvARRAY(PL_regex_padav);
10443 /* shortcuts to various I/O objects */
10444 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
10445 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
10446 PL_defgv = gv_dup(proto_perl->Idefgv, param);
10447 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
10448 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
10449 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
10451 /* shortcuts to regexp stuff */
10452 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
10454 /* shortcuts to misc objects */
10455 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
10457 /* shortcuts to debugging objects */
10458 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
10459 PL_DBline = gv_dup(proto_perl->IDBline, param);
10460 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
10461 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
10462 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
10463 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
10464 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
10465 PL_lineary = av_dup(proto_perl->Ilineary, param);
10466 PL_dbargs = av_dup(proto_perl->Idbargs, param);
10468 /* symbol tables */
10469 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
10470 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
10471 PL_debstash = hv_dup(proto_perl->Idebstash, param);
10472 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
10473 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
10475 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
10476 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
10477 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
10478 PL_endav = av_dup_inc(proto_perl->Iendav, param);
10479 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
10480 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
10482 PL_sub_generation = proto_perl->Isub_generation;
10484 /* funky return mechanisms */
10485 PL_forkprocess = proto_perl->Iforkprocess;
10487 /* subprocess state */
10488 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
10490 /* internal state */
10491 PL_maxo = proto_perl->Imaxo;
10492 if (proto_perl->Iop_mask)
10493 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
10496 /* PL_asserting = proto_perl->Iasserting; */
10498 /* current interpreter roots */
10499 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
10500 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
10501 PL_main_start = proto_perl->Imain_start;
10502 PL_eval_root = proto_perl->Ieval_root;
10503 PL_eval_start = proto_perl->Ieval_start;
10505 /* runtime control stuff */
10506 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
10507 PL_copline = proto_perl->Icopline;
10509 PL_filemode = proto_perl->Ifilemode;
10510 PL_lastfd = proto_perl->Ilastfd;
10511 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
10514 PL_gensym = proto_perl->Igensym;
10515 PL_preambled = proto_perl->Ipreambled;
10516 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
10517 PL_laststatval = proto_perl->Ilaststatval;
10518 PL_laststype = proto_perl->Ilaststype;
10521 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
10523 /* interpreter atexit processing */
10524 PL_exitlistlen = proto_perl->Iexitlistlen;
10525 if (PL_exitlistlen) {
10526 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10527 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10530 PL_exitlist = (PerlExitListEntry*)NULL;
10532 PL_my_cxt_size = proto_perl->Imy_cxt_size;
10533 if (PL_my_cxt_size) {
10534 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
10535 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
10538 PL_my_cxt_list = (void**)NULL;
10539 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
10540 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
10541 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
10543 PL_profiledata = NULL;
10544 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
10545 /* PL_rsfp_filters entries have fake IoDIRP() */
10546 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
10548 PL_compcv = cv_dup(proto_perl->Icompcv, param);
10550 PAD_CLONE_VARS(proto_perl, param);
10552 #ifdef HAVE_INTERP_INTERN
10553 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
10556 /* more statics moved here */
10557 PL_generation = proto_perl->Igeneration;
10558 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
10560 PL_in_clean_objs = proto_perl->Iin_clean_objs;
10561 PL_in_clean_all = proto_perl->Iin_clean_all;
10563 PL_uid = proto_perl->Iuid;
10564 PL_euid = proto_perl->Ieuid;
10565 PL_gid = proto_perl->Igid;
10566 PL_egid = proto_perl->Iegid;
10567 PL_nomemok = proto_perl->Inomemok;
10568 PL_an = proto_perl->Ian;
10569 PL_evalseq = proto_perl->Ievalseq;
10570 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
10571 PL_origalen = proto_perl->Iorigalen;
10572 #ifdef PERL_USES_PL_PIDSTATUS
10573 PL_pidstatus = newHV(); /* XXX flag for cloning? */
10575 PL_osname = SAVEPV(proto_perl->Iosname);
10576 PL_sighandlerp = proto_perl->Isighandlerp;
10578 PL_runops = proto_perl->Irunops;
10580 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
10583 PL_cshlen = proto_perl->Icshlen;
10584 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
10587 PL_lex_state = proto_perl->Ilex_state;
10588 PL_lex_defer = proto_perl->Ilex_defer;
10589 PL_lex_expect = proto_perl->Ilex_expect;
10590 PL_lex_formbrack = proto_perl->Ilex_formbrack;
10591 PL_lex_dojoin = proto_perl->Ilex_dojoin;
10592 PL_lex_starts = proto_perl->Ilex_starts;
10593 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
10594 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
10595 PL_lex_op = proto_perl->Ilex_op;
10596 PL_lex_inpat = proto_perl->Ilex_inpat;
10597 PL_lex_inwhat = proto_perl->Ilex_inwhat;
10598 PL_lex_brackets = proto_perl->Ilex_brackets;
10599 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
10600 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
10601 PL_lex_casemods = proto_perl->Ilex_casemods;
10602 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
10603 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
10605 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
10606 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
10607 PL_nexttoke = proto_perl->Inexttoke;
10609 /* XXX This is probably masking the deeper issue of why
10610 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
10611 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
10612 * (A little debugging with a watchpoint on it may help.)
10614 if (SvANY(proto_perl->Ilinestr)) {
10615 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
10616 i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
10617 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10618 i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
10619 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10620 i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
10621 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10622 i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
10623 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10626 PL_linestr = newSV(79);
10627 sv_upgrade(PL_linestr,SVt_PVIV);
10628 sv_setpvn(PL_linestr,"",0);
10629 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
10631 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10632 PL_pending_ident = proto_perl->Ipending_ident;
10633 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
10635 PL_expect = proto_perl->Iexpect;
10637 PL_multi_start = proto_perl->Imulti_start;
10638 PL_multi_end = proto_perl->Imulti_end;
10639 PL_multi_open = proto_perl->Imulti_open;
10640 PL_multi_close = proto_perl->Imulti_close;
10642 PL_error_count = proto_perl->Ierror_count;
10643 PL_subline = proto_perl->Isubline;
10644 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
10646 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
10647 if (SvANY(proto_perl->Ilinestr)) {
10648 i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
10649 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10650 i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
10651 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10652 PL_last_lop_op = proto_perl->Ilast_lop_op;
10655 PL_last_uni = SvPVX(PL_linestr);
10656 PL_last_lop = SvPVX(PL_linestr);
10657 PL_last_lop_op = 0;
10659 PL_in_my = proto_perl->Iin_my;
10660 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
10662 PL_cryptseen = proto_perl->Icryptseen;
10665 PL_hints = proto_perl->Ihints;
10667 PL_amagic_generation = proto_perl->Iamagic_generation;
10669 #ifdef USE_LOCALE_COLLATE
10670 PL_collation_ix = proto_perl->Icollation_ix;
10671 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
10672 PL_collation_standard = proto_perl->Icollation_standard;
10673 PL_collxfrm_base = proto_perl->Icollxfrm_base;
10674 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
10675 #endif /* USE_LOCALE_COLLATE */
10677 #ifdef USE_LOCALE_NUMERIC
10678 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
10679 PL_numeric_standard = proto_perl->Inumeric_standard;
10680 PL_numeric_local = proto_perl->Inumeric_local;
10681 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
10682 #endif /* !USE_LOCALE_NUMERIC */
10684 /* utf8 character classes */
10685 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
10686 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
10687 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
10688 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
10689 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
10690 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
10691 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
10692 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
10693 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
10694 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
10695 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
10696 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
10697 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
10698 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
10699 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
10700 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
10701 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
10702 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
10703 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
10704 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
10706 /* Did the locale setup indicate UTF-8? */
10707 PL_utf8locale = proto_perl->Iutf8locale;
10708 /* Unicode features (see perlrun/-C) */
10709 PL_unicode = proto_perl->Iunicode;
10711 /* Pre-5.8 signals control */
10712 PL_signals = proto_perl->Isignals;
10714 /* times() ticks per second */
10715 PL_clocktick = proto_perl->Iclocktick;
10717 /* Recursion stopper for PerlIO_find_layer */
10718 PL_in_load_module = proto_perl->Iin_load_module;
10720 /* sort() routine */
10721 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
10723 /* Not really needed/useful since the reenrant_retint is "volatile",
10724 * but do it for consistency's sake. */
10725 PL_reentrant_retint = proto_perl->Ireentrant_retint;
10727 /* Hooks to shared SVs and locks. */
10728 PL_sharehook = proto_perl->Isharehook;
10729 PL_lockhook = proto_perl->Ilockhook;
10730 PL_unlockhook = proto_perl->Iunlockhook;
10731 PL_threadhook = proto_perl->Ithreadhook;
10733 PL_runops_std = proto_perl->Irunops_std;
10734 PL_runops_dbg = proto_perl->Irunops_dbg;
10736 #ifdef THREADS_HAVE_PIDS
10737 PL_ppid = proto_perl->Ippid;
10741 PL_last_swash_hv = NULL; /* reinits on demand */
10742 PL_last_swash_klen = 0;
10743 PL_last_swash_key[0]= '\0';
10744 PL_last_swash_tmps = (U8*)NULL;
10745 PL_last_swash_slen = 0;
10747 PL_glob_index = proto_perl->Iglob_index;
10748 PL_srand_called = proto_perl->Isrand_called;
10749 PL_uudmap['M'] = 0; /* reinits on demand */
10750 PL_bitcount = NULL; /* reinits on demand */
10752 if (proto_perl->Ipsig_pend) {
10753 Newxz(PL_psig_pend, SIG_SIZE, int);
10756 PL_psig_pend = (int*)NULL;
10759 if (proto_perl->Ipsig_ptr) {
10760 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
10761 Newxz(PL_psig_name, SIG_SIZE, SV*);
10762 for (i = 1; i < SIG_SIZE; i++) {
10763 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
10764 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
10768 PL_psig_ptr = (SV**)NULL;
10769 PL_psig_name = (SV**)NULL;
10772 /* thrdvar.h stuff */
10774 if (flags & CLONEf_COPY_STACKS) {
10775 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
10776 PL_tmps_ix = proto_perl->Ttmps_ix;
10777 PL_tmps_max = proto_perl->Ttmps_max;
10778 PL_tmps_floor = proto_perl->Ttmps_floor;
10779 Newxz(PL_tmps_stack, PL_tmps_max, SV*);
10781 while (i <= PL_tmps_ix) {
10782 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
10786 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
10787 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
10788 Newxz(PL_markstack, i, I32);
10789 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
10790 - proto_perl->Tmarkstack);
10791 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
10792 - proto_perl->Tmarkstack);
10793 Copy(proto_perl->Tmarkstack, PL_markstack,
10794 PL_markstack_ptr - PL_markstack + 1, I32);
10796 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
10797 * NOTE: unlike the others! */
10798 PL_scopestack_ix = proto_perl->Tscopestack_ix;
10799 PL_scopestack_max = proto_perl->Tscopestack_max;
10800 Newxz(PL_scopestack, PL_scopestack_max, I32);
10801 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
10803 /* NOTE: si_dup() looks at PL_markstack */
10804 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
10806 /* PL_curstack = PL_curstackinfo->si_stack; */
10807 PL_curstack = av_dup(proto_perl->Tcurstack, param);
10808 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
10810 /* next PUSHs() etc. set *(PL_stack_sp+1) */
10811 PL_stack_base = AvARRAY(PL_curstack);
10812 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
10813 - proto_perl->Tstack_base);
10814 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
10816 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
10817 * NOTE: unlike the others! */
10818 PL_savestack_ix = proto_perl->Tsavestack_ix;
10819 PL_savestack_max = proto_perl->Tsavestack_max;
10820 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
10821 PL_savestack = ss_dup(proto_perl, param);
10825 ENTER; /* perl_destruct() wants to LEAVE; */
10827 /* although we're not duplicating the tmps stack, we should still
10828 * add entries for any SVs on the tmps stack that got cloned by a
10829 * non-refcount means (eg a temp in @_); otherwise they will be
10832 for (i = 0; i<= proto_perl->Ttmps_ix; i++) {
10833 SV * const nsv = (SV*)ptr_table_fetch(PL_ptr_table,
10834 proto_perl->Ttmps_stack[i]);
10835 if (nsv && !SvREFCNT(nsv)) {
10837 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc(nsv);
10842 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
10843 PL_top_env = &PL_start_env;
10845 PL_op = proto_perl->Top;
10848 PL_Xpv = (XPV*)NULL;
10849 PL_na = proto_perl->Tna;
10851 PL_statbuf = proto_perl->Tstatbuf;
10852 PL_statcache = proto_perl->Tstatcache;
10853 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
10854 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
10856 PL_timesbuf = proto_perl->Ttimesbuf;
10859 PL_tainted = proto_perl->Ttainted;
10860 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
10861 PL_rs = sv_dup_inc(proto_perl->Trs, param);
10862 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
10863 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
10864 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
10865 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
10866 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
10867 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
10868 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
10870 PL_restartop = proto_perl->Trestartop;
10871 PL_in_eval = proto_perl->Tin_eval;
10872 PL_delaymagic = proto_perl->Tdelaymagic;
10873 PL_dirty = proto_perl->Tdirty;
10874 PL_localizing = proto_perl->Tlocalizing;
10876 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
10877 PL_hv_fetch_ent_mh = Nullhe;
10878 PL_modcount = proto_perl->Tmodcount;
10879 PL_lastgotoprobe = Nullop;
10880 PL_dumpindent = proto_perl->Tdumpindent;
10882 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
10883 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
10884 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
10885 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
10886 PL_efloatbuf = NULL; /* reinits on demand */
10887 PL_efloatsize = 0; /* reinits on demand */
10891 PL_screamfirst = NULL;
10892 PL_screamnext = NULL;
10893 PL_maxscream = -1; /* reinits on demand */
10894 PL_lastscream = NULL;
10896 PL_watchaddr = NULL;
10899 PL_regdummy = proto_perl->Tregdummy;
10900 PL_regprecomp = NULL;
10903 PL_colorset = 0; /* reinits PL_colors[] */
10904 /*PL_colors[6] = {0,0,0,0,0,0};*/
10905 PL_reginput = NULL;
10908 PL_regstartp = (I32*)NULL;
10909 PL_regendp = (I32*)NULL;
10910 PL_reglastparen = (U32*)NULL;
10911 PL_reglastcloseparen = (U32*)NULL;
10913 PL_reg_start_tmp = (char**)NULL;
10914 PL_reg_start_tmpl = 0;
10915 PL_regdata = (struct reg_data*)NULL;
10918 PL_reg_eval_set = 0;
10920 PL_regprogram = (regnode*)NULL;
10922 PL_regcc = (CURCUR*)NULL;
10923 PL_reg_call_cc = (struct re_cc_state*)NULL;
10924 PL_reg_re = (regexp*)NULL;
10925 PL_reg_ganch = NULL;
10927 PL_reg_match_utf8 = FALSE;
10928 PL_reg_magic = (MAGIC*)NULL;
10930 PL_reg_oldcurpm = (PMOP*)NULL;
10931 PL_reg_curpm = (PMOP*)NULL;
10932 PL_reg_oldsaved = NULL;
10933 PL_reg_oldsavedlen = 0;
10934 #ifdef PERL_OLD_COPY_ON_WRITE
10937 PL_reg_maxiter = 0;
10938 PL_reg_leftiter = 0;
10939 PL_reg_poscache = NULL;
10940 PL_reg_poscache_size= 0;
10942 /* RE engine - function pointers */
10943 PL_regcompp = proto_perl->Tregcompp;
10944 PL_regexecp = proto_perl->Tregexecp;
10945 PL_regint_start = proto_perl->Tregint_start;
10946 PL_regint_string = proto_perl->Tregint_string;
10947 PL_regfree = proto_perl->Tregfree;
10949 PL_reginterp_cnt = 0;
10950 PL_reg_starttry = 0;
10952 /* Pluggable optimizer */
10953 PL_peepp = proto_perl->Tpeepp;
10955 PL_stashcache = newHV();
10957 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
10958 ptr_table_free(PL_ptr_table);
10959 PL_ptr_table = NULL;
10962 /* Call the ->CLONE method, if it exists, for each of the stashes
10963 identified by sv_dup() above.
10965 while(av_len(param->stashes) != -1) {
10966 HV* const stash = (HV*) av_shift(param->stashes);
10967 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
10968 if (cloner && GvCV(cloner)) {
10973 XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
10975 call_sv((SV*)GvCV(cloner), G_DISCARD);
10981 SvREFCNT_dec(param->stashes);
10983 /* orphaned? eg threads->new inside BEGIN or use */
10984 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
10985 (void)SvREFCNT_inc(PL_compcv);
10986 SAVEFREESV(PL_compcv);
10992 #endif /* USE_ITHREADS */
10995 =head1 Unicode Support
10997 =for apidoc sv_recode_to_utf8
10999 The encoding is assumed to be an Encode object, on entry the PV
11000 of the sv is assumed to be octets in that encoding, and the sv
11001 will be converted into Unicode (and UTF-8).
11003 If the sv already is UTF-8 (or if it is not POK), or if the encoding
11004 is not a reference, nothing is done to the sv. If the encoding is not
11005 an C<Encode::XS> Encoding object, bad things will happen.
11006 (See F<lib/encoding.pm> and L<Encode>).
11008 The PV of the sv is returned.
11013 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
11016 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
11030 Passing sv_yes is wrong - it needs to be or'ed set of constants
11031 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
11032 remove converted chars from source.
11034 Both will default the value - let them.
11036 XPUSHs(&PL_sv_yes);
11039 call_method("decode", G_SCALAR);
11043 s = SvPV_const(uni, len);
11044 if (s != SvPVX_const(sv)) {
11045 SvGROW(sv, len + 1);
11046 Move(s, SvPVX(sv), len + 1, char);
11047 SvCUR_set(sv, len);
11054 return SvPOKp(sv) ? SvPVX(sv) : NULL;
11058 =for apidoc sv_cat_decode
11060 The encoding is assumed to be an Encode object, the PV of the ssv is
11061 assumed to be octets in that encoding and decoding the input starts
11062 from the position which (PV + *offset) pointed to. The dsv will be
11063 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
11064 when the string tstr appears in decoding output or the input ends on
11065 the PV of the ssv. The value which the offset points will be modified
11066 to the last input position on the ssv.
11068 Returns TRUE if the terminator was found, else returns FALSE.
11073 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
11074 SV *ssv, int *offset, char *tstr, int tlen)
11078 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
11089 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
11090 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
11092 call_method("cat_decode", G_SCALAR);
11094 ret = SvTRUE(TOPs);
11095 *offset = SvIV(offsv);
11101 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
11106 /* ---------------------------------------------------------------------
11108 * support functions for report_uninit()
11111 /* the maxiumum size of array or hash where we will scan looking
11112 * for the undefined element that triggered the warning */
11114 #define FUV_MAX_SEARCH_SIZE 1000
11116 /* Look for an entry in the hash whose value has the same SV as val;
11117 * If so, return a mortal copy of the key. */
11120 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
11123 register HE **array;
11126 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
11127 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
11130 array = HvARRAY(hv);
11132 for (i=HvMAX(hv); i>0; i--) {
11133 register HE *entry;
11134 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
11135 if (HeVAL(entry) != val)
11137 if ( HeVAL(entry) == &PL_sv_undef ||
11138 HeVAL(entry) == &PL_sv_placeholder)
11142 if (HeKLEN(entry) == HEf_SVKEY)
11143 return sv_mortalcopy(HeKEY_sv(entry));
11144 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
11150 /* Look for an entry in the array whose value has the same SV as val;
11151 * If so, return the index, otherwise return -1. */
11154 S_find_array_subscript(pTHX_ AV *av, SV* val)
11159 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
11160 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
11164 for (i=AvFILLp(av); i>=0; i--) {
11165 if (svp[i] == val && svp[i] != &PL_sv_undef)
11171 /* S_varname(): return the name of a variable, optionally with a subscript.
11172 * If gv is non-zero, use the name of that global, along with gvtype (one
11173 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
11174 * targ. Depending on the value of the subscript_type flag, return:
11177 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
11178 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
11179 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
11180 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
11183 S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
11184 SV* keyname, I32 aindex, int subscript_type)
11187 SV * const name = sv_newmortal();
11190 buffer[0] = gvtype;
11193 /* as gv_fullname4(), but add literal '^' for $^FOO names */
11195 gv_fullname4(name, gv, buffer, 0);
11197 if ((unsigned int)SvPVX(name)[1] <= 26) {
11199 buffer[1] = SvPVX(name)[1] + 'A' - 1;
11201 /* Swap the 1 unprintable control character for the 2 byte pretty
11202 version - ie substr($name, 1, 1) = $buffer; */
11203 sv_insert(name, 1, 1, buffer, 2);
11208 CV * const cv = find_runcv(&unused);
11212 if (!cv || !CvPADLIST(cv))
11214 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
11215 sv = *av_fetch(av, targ, FALSE);
11216 /* SvLEN in a pad name is not to be trusted */
11217 sv_setpv(name, SvPV_nolen_const(sv));
11220 if (subscript_type == FUV_SUBSCRIPT_HASH) {
11221 SV * const sv = newSV(0);
11222 *SvPVX(name) = '$';
11223 Perl_sv_catpvf(aTHX_ name, "{%s}",
11224 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
11227 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
11228 *SvPVX(name) = '$';
11229 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
11231 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
11232 Perl_sv_insert(aTHX_ name, 0, 0, STR_WITH_LEN("within "));
11239 =for apidoc find_uninit_var
11241 Find the name of the undefined variable (if any) that caused the operator o
11242 to issue a "Use of uninitialized value" warning.
11243 If match is true, only return a name if it's value matches uninit_sv.
11244 So roughly speaking, if a unary operator (such as OP_COS) generates a
11245 warning, then following the direct child of the op may yield an
11246 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
11247 other hand, with OP_ADD there are two branches to follow, so we only print
11248 the variable name if we get an exact match.
11250 The name is returned as a mortal SV.
11252 Assumes that PL_op is the op that originally triggered the error, and that
11253 PL_comppad/PL_curpad points to the currently executing pad.
11259 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
11267 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
11268 uninit_sv == &PL_sv_placeholder)))
11271 switch (obase->op_type) {
11278 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
11279 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
11282 int subscript_type = FUV_SUBSCRIPT_WITHIN;
11284 if (pad) { /* @lex, %lex */
11285 sv = PAD_SVl(obase->op_targ);
11289 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
11290 /* @global, %global */
11291 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
11294 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
11296 else /* @{expr}, %{expr} */
11297 return find_uninit_var(cUNOPx(obase)->op_first,
11301 /* attempt to find a match within the aggregate */
11303 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
11305 subscript_type = FUV_SUBSCRIPT_HASH;
11308 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
11310 subscript_type = FUV_SUBSCRIPT_ARRAY;
11313 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
11316 return varname(gv, hash ? '%' : '@', obase->op_targ,
11317 keysv, index, subscript_type);
11321 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
11323 return varname(NULL, '$', obase->op_targ,
11324 NULL, 0, FUV_SUBSCRIPT_NONE);
11327 gv = cGVOPx_gv(obase);
11328 if (!gv || (match && GvSV(gv) != uninit_sv))
11330 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
11333 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
11336 av = (AV*)PAD_SV(obase->op_targ);
11337 if (!av || SvRMAGICAL(av))
11339 svp = av_fetch(av, (I32)obase->op_private, FALSE);
11340 if (!svp || *svp != uninit_sv)
11343 return varname(NULL, '$', obase->op_targ,
11344 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
11347 gv = cGVOPx_gv(obase);
11353 if (!av || SvRMAGICAL(av))
11355 svp = av_fetch(av, (I32)obase->op_private, FALSE);
11356 if (!svp || *svp != uninit_sv)
11359 return varname(gv, '$', 0,
11360 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
11365 o = cUNOPx(obase)->op_first;
11366 if (!o || o->op_type != OP_NULL ||
11367 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
11369 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
11373 if (PL_op == obase)
11374 /* $a[uninit_expr] or $h{uninit_expr} */
11375 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
11378 o = cBINOPx(obase)->op_first;
11379 kid = cBINOPx(obase)->op_last;
11381 /* get the av or hv, and optionally the gv */
11383 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
11384 sv = PAD_SV(o->op_targ);
11386 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
11387 && cUNOPo->op_first->op_type == OP_GV)
11389 gv = cGVOPx_gv(cUNOPo->op_first);
11392 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
11397 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
11398 /* index is constant */
11402 if (obase->op_type == OP_HELEM) {
11403 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
11404 if (!he || HeVAL(he) != uninit_sv)
11408 SV * const * const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
11409 if (!svp || *svp != uninit_sv)
11413 if (obase->op_type == OP_HELEM)
11414 return varname(gv, '%', o->op_targ,
11415 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
11417 return varname(gv, '@', o->op_targ, NULL,
11418 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
11421 /* index is an expression;
11422 * attempt to find a match within the aggregate */
11423 if (obase->op_type == OP_HELEM) {
11424 SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
11426 return varname(gv, '%', o->op_targ,
11427 keysv, 0, FUV_SUBSCRIPT_HASH);
11430 const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
11432 return varname(gv, '@', o->op_targ,
11433 NULL, index, FUV_SUBSCRIPT_ARRAY);
11438 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
11440 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
11446 /* only examine RHS */
11447 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
11450 o = cUNOPx(obase)->op_first;
11451 if (o->op_type == OP_PUSHMARK)
11454 if (!o->op_sibling) {
11455 /* one-arg version of open is highly magical */
11457 if (o->op_type == OP_GV) { /* open FOO; */
11459 if (match && GvSV(gv) != uninit_sv)
11461 return varname(gv, '$', 0,
11462 NULL, 0, FUV_SUBSCRIPT_NONE);
11464 /* other possibilities not handled are:
11465 * open $x; or open my $x; should return '${*$x}'
11466 * open expr; should return '$'.expr ideally
11472 /* ops where $_ may be an implicit arg */
11476 if ( !(obase->op_flags & OPf_STACKED)) {
11477 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
11478 ? PAD_SVl(obase->op_targ)
11481 sv = sv_newmortal();
11482 sv_setpvn(sv, "$_", 2);
11490 /* skip filehandle as it can't produce 'undef' warning */
11491 o = cUNOPx(obase)->op_first;
11492 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
11493 o = o->op_sibling->op_sibling;
11500 match = 1; /* XS or custom code could trigger random warnings */
11505 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
11506 return sv_2mortal(newSVpvs("${$/}"));
11511 if (!(obase->op_flags & OPf_KIDS))
11513 o = cUNOPx(obase)->op_first;
11519 /* if all except one arg are constant, or have no side-effects,
11520 * or are optimized away, then it's unambiguous */
11522 for (kid=o; kid; kid = kid->op_sibling) {
11524 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
11525 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
11526 || (kid->op_type == OP_PUSHMARK)
11530 if (o2) { /* more than one found */
11537 return find_uninit_var(o2, uninit_sv, match);
11539 /* scan all args */
11541 sv = find_uninit_var(o, uninit_sv, 1);
11553 =for apidoc report_uninit
11555 Print appropriate "Use of uninitialized variable" warning
11561 Perl_report_uninit(pTHX_ SV* uninit_sv)
11565 SV* varname = NULL;
11567 varname = find_uninit_var(PL_op, uninit_sv,0);
11569 sv_insert(varname, 0, 0, " ", 1);
11571 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
11572 varname ? SvPV_nolen_const(varname) : "",
11573 " in ", OP_DESC(PL_op));
11576 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
11582 * c-indentation-style: bsd
11583 * c-basic-offset: 4
11584 * indent-tabs-mode: t
11587 * ex: set ts=8 sts=4 sw=4 noet: