3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 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)
183 new_chunk = (void *)(chunk);
184 new_chunk_size = (chunk_size);
185 if (new_chunk_size > PL_nice_chunk_size) {
186 Safefree(PL_nice_chunk);
187 PL_nice_chunk = (char *) new_chunk;
188 PL_nice_chunk_size = new_chunk_size;
195 #ifdef DEBUG_LEAKING_SCALARS
196 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
198 # define FREE_SV_DEBUG_FILE(sv)
202 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
203 /* Whilst I'd love to do this, it seems that things like to check on
205 # define POSION_SV_HEAD(sv) Poison(sv, 1, struct STRUCT_SV)
207 # define POSION_SV_HEAD(sv) Poison(&SvANY(sv), 1, void *), \
208 Poison(&SvREFCNT(sv), 1, U32)
210 # define SvARENA_CHAIN(sv) SvANY(sv)
211 # define POSION_SV_HEAD(sv)
214 #define plant_SV(p) \
216 FREE_SV_DEBUG_FILE(p); \
218 SvARENA_CHAIN(p) = (void *)PL_sv_root; \
219 SvFLAGS(p) = SVTYPEMASK; \
224 /* sv_mutex must be held while calling uproot_SV() */
225 #define uproot_SV(p) \
228 PL_sv_root = (SV*)SvARENA_CHAIN(p); \
233 /* make some more SVs by adding another arena */
235 /* sv_mutex must be held while calling more_sv() */
242 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
243 PL_nice_chunk = Nullch;
244 PL_nice_chunk_size = 0;
247 char *chunk; /* must use New here to match call to */
248 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
249 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
255 /* new_SV(): return a new, empty SV head */
257 #ifdef DEBUG_LEAKING_SCALARS
258 /* provide a real function for a debugger to play with */
268 sv = S_more_sv(aTHX);
273 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
274 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
275 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
276 sv->sv_debug_inpad = 0;
277 sv->sv_debug_cloned = 0;
278 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
282 # define new_SV(p) (p)=S_new_SV(aTHX)
291 (p) = S_more_sv(aTHX); \
300 /* del_SV(): return an empty SV head to the free list */
315 S_del_sv(pTHX_ SV *p)
320 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
321 const SV * const sv = sva + 1;
322 const SV * const svend = &sva[SvREFCNT(sva)];
323 if (p >= sv && p < svend) {
329 if (ckWARN_d(WARN_INTERNAL))
330 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
331 "Attempt to free non-arena SV: 0x%"UVxf
332 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
339 #else /* ! DEBUGGING */
341 #define del_SV(p) plant_SV(p)
343 #endif /* DEBUGGING */
347 =head1 SV Manipulation Functions
349 =for apidoc sv_add_arena
351 Given a chunk of memory, link it to the head of the list of arenas,
352 and split it into a list of free SVs.
358 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
360 SV* const sva = (SV*)ptr;
364 /* The first SV in an arena isn't an SV. */
365 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
366 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
367 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
369 PL_sv_arenaroot = sva;
370 PL_sv_root = sva + 1;
372 svend = &sva[SvREFCNT(sva) - 1];
375 SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1);
379 /* Must always set typemask because it's awlays checked in on cleanup
380 when the arenas are walked looking for objects. */
381 SvFLAGS(sv) = SVTYPEMASK;
384 SvARENA_CHAIN(sv) = 0;
388 SvFLAGS(sv) = SVTYPEMASK;
391 /* visit(): call the named function for each non-free SV in the arenas
392 * whose flags field matches the flags/mask args. */
395 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
400 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
401 register const SV * const svend = &sva[SvREFCNT(sva)];
403 for (sv = sva + 1; sv < svend; ++sv) {
404 if (SvTYPE(sv) != SVTYPEMASK
405 && (sv->sv_flags & mask) == flags
418 /* called by sv_report_used() for each live SV */
421 do_report_used(pTHX_ SV *sv)
423 if (SvTYPE(sv) != SVTYPEMASK) {
424 PerlIO_printf(Perl_debug_log, "****\n");
431 =for apidoc sv_report_used
433 Dump the contents of all SVs not yet freed. (Debugging aid).
439 Perl_sv_report_used(pTHX)
442 visit(do_report_used, 0, 0);
446 /* called by sv_clean_objs() for each live SV */
449 do_clean_objs(pTHX_ SV *ref)
452 SV * const target = SvRV(ref);
453 if (SvOBJECT(target)) {
454 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
455 if (SvWEAKREF(ref)) {
456 sv_del_backref(target, ref);
462 SvREFCNT_dec(target);
467 /* XXX Might want to check arrays, etc. */
470 /* called by sv_clean_objs() for each live SV */
472 #ifndef DISABLE_DESTRUCTOR_KLUDGE
474 do_clean_named_objs(pTHX_ SV *sv)
476 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
478 #ifdef PERL_DONT_CREATE_GVSV
481 SvOBJECT(GvSV(sv))) ||
482 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
483 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
484 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
485 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
487 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
488 SvFLAGS(sv) |= SVf_BREAK;
496 =for apidoc sv_clean_objs
498 Attempt to destroy all objects not yet freed
504 Perl_sv_clean_objs(pTHX)
506 PL_in_clean_objs = TRUE;
507 visit(do_clean_objs, SVf_ROK, SVf_ROK);
508 #ifndef DISABLE_DESTRUCTOR_KLUDGE
509 /* some barnacles may yet remain, clinging to typeglobs */
510 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
512 PL_in_clean_objs = FALSE;
515 /* called by sv_clean_all() for each live SV */
518 do_clean_all(pTHX_ SV *sv)
520 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
521 SvFLAGS(sv) |= SVf_BREAK;
522 if (PL_comppad == (AV*)sv) {
524 PL_curpad = Null(SV**);
530 =for apidoc sv_clean_all
532 Decrement the refcnt of each remaining SV, possibly triggering a
533 cleanup. This function may have to be called multiple times to free
534 SVs which are in complex self-referential hierarchies.
540 Perl_sv_clean_all(pTHX)
543 PL_in_clean_all = TRUE;
544 cleaned = visit(do_clean_all, 0,0);
545 PL_in_clean_all = FALSE;
550 S_free_arena(pTHX_ void **root) {
552 void ** const next = *(void **)root;
559 =for apidoc sv_free_arenas
561 Deallocate the memory used by all arenas. Note that all the individual SV
562 heads and bodies within the arenas must already have been freed.
566 #define free_arena(name) \
568 S_free_arena(aTHX_ (void**) PL_ ## name ## _arenaroot); \
569 PL_ ## name ## _arenaroot = 0; \
570 PL_ ## name ## _root = 0; \
574 Perl_sv_free_arenas(pTHX)
580 /* Free arenas here, but be careful about fake ones. (We assume
581 contiguity of the fake ones with the corresponding real ones.) */
583 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
584 svanext = (SV*) SvANY(sva);
585 while (svanext && SvFAKE(svanext))
586 svanext = (SV*) SvANY(svanext);
592 for (i=0; i<SVt_LAST; i++) {
593 S_free_arena(aTHX_ (void**) PL_body_arenaroots[i]);
594 PL_body_arenaroots[i] = 0;
595 PL_body_roots[i] = 0;
598 Safefree(PL_nice_chunk);
599 PL_nice_chunk = Nullch;
600 PL_nice_chunk_size = 0;
606 Here are mid-level routines that manage the allocation of bodies out
607 of the various arenas. There are 5 kinds of arenas:
609 1. SV-head arenas, which are discussed and handled above
610 2. regular body arenas
611 3. arenas for reduced-size bodies
613 5. pte arenas (thread related)
615 Arena types 2 & 3 are chained by body-type off an array of
616 arena-root pointers, which is indexed by svtype. Some of the
617 larger/less used body types are malloced singly, since a large
618 unused block of them is wasteful. Also, several svtypes dont have
619 bodies; the data fits into the sv-head itself. The arena-root
620 pointer thus has a few unused root-pointers (which may be hijacked
621 later for arena types 4,5)
623 3 differs from 2 as an optimization; some body types have several
624 unused fields in the front of the structure (which are kept in-place
625 for consistency). These bodies can be allocated in smaller chunks,
626 because the leading fields arent accessed. Pointers to such bodies
627 are decremented to point at the unused 'ghost' memory, knowing that
628 the pointers are used with offsets to the real memory.
630 HE, HEK arenas are managed separately, with separate code, but may
631 be merge-able later..
633 PTE arenas are not sv-bodies, but they share these mid-level
634 mechanics, so are considered here. The new mid-level mechanics rely
635 on the sv_type of the body being allocated, so we just reserve one
636 of the unused body-slots for PTEs, then use it in those (2) PTE
637 contexts below (line ~10k)
641 S_more_bodies (pTHX_ size_t size, svtype sv_type)
643 void ** const arena_root = &PL_body_arenaroots[sv_type];
644 void ** const root = &PL_body_roots[sv_type];
647 const size_t count = PERL_ARENA_SIZE / size;
649 Newx(start, count*size, char);
650 *((void **) start) = *arena_root;
651 *arena_root = (void *)start;
653 end = start + (count-1) * size;
655 /* The initial slot is used to link the arenas together, so it isn't to be
656 linked into the list of ready-to-use bodies. */
660 *root = (void *)start;
662 while (start < end) {
663 char * const next = start + size;
664 *(void**) start = (void *)next;
672 /* grab a new thing from the free list, allocating more if necessary */
674 /* 1st, the inline version */
676 #define new_body_inline(xpv, size, sv_type) \
678 void ** const r3wt = &PL_body_roots[sv_type]; \
680 xpv = *((void **)(r3wt)) \
681 ? *((void **)(r3wt)) : S_more_bodies(aTHX_ size, sv_type); \
682 *(r3wt) = *(void**)(xpv); \
686 /* now use the inline version in the proper function */
690 /* This isn't being used with -DPURIFY, so don't declare it. Otherwise
691 compilers issue warnings. */
694 S_new_body(pTHX_ size_t size, svtype sv_type)
697 new_body_inline(xpv, size, sv_type);
703 /* return a thing to the free list */
705 #define del_body(thing, root) \
707 void ** const thing_copy = (void **)thing;\
709 *thing_copy = *root; \
710 *root = (void*)thing_copy; \
715 Revisiting type 3 arenas, there are 4 body-types which have some
716 members that are never accessed. They are XPV, XPVIV, XPVAV,
717 XPVHV, which have corresponding types: xpv_allocated,
718 xpviv_allocated, xpvav_allocated, xpvhv_allocated,
720 For these types, the arenas are carved up into *_allocated size
721 chunks, we thus avoid wasted memory for those unaccessed members.
722 When bodies are allocated, we adjust the pointer back in memory by
723 the size of the bit not allocated, so it's as if we allocated the
724 full structure. (But things will all go boom if you write to the
725 part that is "not there", because you'll be overwriting the last
726 members of the preceding structure in memory.)
728 We calculate the correction using the STRUCT_OFFSET macro. For example, if
729 xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
730 and the pointer is unchanged. If the allocated structure is smaller (no
731 initial NV actually allocated) then the net effect is to subtract the size
732 of the NV from the pointer, to return a new pointer as if an initial NV were
735 This is the same trick as was used for NV and IV bodies. Ironically it
736 doesn't need to be used for NV bodies any more, because NV is now at the
737 start of the structure. IV bodies don't need it either, because they are
738 no longer allocated. */
740 /* The following 2 arrays hide the above details in a pair of
741 lookup-tables, allowing us to be body-type agnostic.
743 size maps svtype to its body's allocated size.
744 offset maps svtype to the body-pointer adjustment needed
746 NB: elements in latter are 0 or <0, and are added during
747 allocation, and subtracted during deallocation. It may be clearer
748 to invert the values, and call it shrinkage_by_svtype.
751 struct body_details {
752 size_t size; /* Size to allocate */
753 size_t copy; /* Size of structure to copy (may be shorter) */
755 bool cant_upgrade; /* Can upgrade this type */
756 bool zero_nv; /* zero the NV when upgrading from this */
757 bool arena; /* Allocated from an arena */
764 /* With -DPURFIY we allocate everything directly, and don't use arenas.
765 This seems a rather elegant way to simplify some of the code below. */
766 #define HASARENA FALSE
768 #define HASARENA TRUE
770 #define NOARENA FALSE
772 /* A macro to work out the offset needed to subtract from a pointer to (say)
779 to make its members accessible via a pointer to (say)
789 #define relative_STRUCT_OFFSET(longer, shorter, member) \
790 (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
792 /* Calculate the length to copy. Specifically work out the length less any
793 final padding the compiler needed to add. See the comment in sv_upgrade
794 for why copying the padding proved to be a bug. */
796 #define copy_length(type, last_member) \
797 STRUCT_OFFSET(type, last_member) \
798 + sizeof (((type*)SvANY((SV*)0))->last_member)
800 static const struct body_details bodies_by_type[] = {
801 {0, 0, 0, FALSE, NONV, NOARENA},
802 /* IVs are in the head, so the allocation size is 0 */
803 {0, sizeof(IV), STRUCT_OFFSET(XPVIV, xiv_iv), FALSE, NONV, NOARENA},
804 /* 8 bytes on most ILP32 with IEEE doubles */
805 {sizeof(NV), sizeof(NV), 0, FALSE, HADNV, HASARENA},
806 /* RVs are in the head now */
807 /* However, this slot is overloaded and used by the pte */
808 {0, 0, 0, FALSE, NONV, NOARENA},
809 /* 8 bytes on most ILP32 with IEEE doubles */
810 {sizeof(xpv_allocated),
811 copy_length(XPV, xpv_len)
812 + relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur),
813 - relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur),
814 FALSE, NONV, HASARENA},
816 {sizeof(xpviv_allocated),
817 copy_length(XPVIV, xiv_u)
818 + relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur),
819 - relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur),
820 FALSE, NONV, HASARENA},
822 {sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, FALSE, HADNV, HASARENA},
824 {sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, FALSE, HADNV, HASARENA},
826 {sizeof(XPVBM), sizeof(XPVBM), 0, TRUE, HADNV, HASARENA},
828 {sizeof(XPVGV), sizeof(XPVGV), 0, TRUE, HADNV, HASARENA},
830 {sizeof(XPVLV), sizeof(XPVLV), 0, TRUE, HADNV, HASARENA},
832 {sizeof(xpvav_allocated),
833 copy_length(XPVAV, xmg_stash)
834 + relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill),
835 - relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill),
836 TRUE, HADNV, HASARENA},
838 {sizeof(xpvhv_allocated),
839 copy_length(XPVHV, xmg_stash)
840 + relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill),
841 - relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill),
842 TRUE, HADNV, HASARENA},
844 {sizeof(XPVCV), sizeof(XPVCV), 0, TRUE, HADNV, HASARENA},
846 {sizeof(XPVFM), sizeof(XPVFM), 0, TRUE, HADNV, NOARENA},
848 {sizeof(XPVIO), sizeof(XPVIO), 0, TRUE, HADNV, NOARENA}
851 #define new_body_type(sv_type) \
852 (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
853 - bodies_by_type[sv_type].offset)
855 #define del_body_type(p, sv_type) \
856 del_body(p, &PL_body_roots[sv_type])
859 #define new_body_allocated(sv_type) \
860 (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
861 - bodies_by_type[sv_type].offset)
863 #define del_body_allocated(p, sv_type) \
864 del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
867 #define my_safemalloc(s) (void*)safemalloc(s)
868 #define my_safecalloc(s) (void*)safecalloc(s, 1)
869 #define my_safefree(p) safefree((char*)p)
873 #define new_XNV() my_safemalloc(sizeof(XPVNV))
874 #define del_XNV(p) my_safefree(p)
876 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
877 #define del_XPVNV(p) my_safefree(p)
879 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
880 #define del_XPVAV(p) my_safefree(p)
882 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
883 #define del_XPVHV(p) my_safefree(p)
885 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
886 #define del_XPVMG(p) my_safefree(p)
888 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
889 #define del_XPVGV(p) my_safefree(p)
893 #define new_XNV() new_body_type(SVt_NV)
894 #define del_XNV(p) del_body_type(p, SVt_NV)
896 #define new_XPVNV() new_body_type(SVt_PVNV)
897 #define del_XPVNV(p) del_body_type(p, SVt_PVNV)
899 #define new_XPVAV() new_body_allocated(SVt_PVAV)
900 #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
902 #define new_XPVHV() new_body_allocated(SVt_PVHV)
903 #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
905 #define new_XPVMG() new_body_type(SVt_PVMG)
906 #define del_XPVMG(p) del_body_type(p, SVt_PVMG)
908 #define new_XPVGV() new_body_type(SVt_PVGV)
909 #define del_XPVGV(p) del_body_type(p, SVt_PVGV)
913 /* no arena for you! */
915 #define new_NOARENA(details) \
916 my_safemalloc((details)->size + (details)->offset)
917 #define new_NOARENAZ(details) \
918 my_safecalloc((details)->size + (details)->offset)
921 =for apidoc sv_upgrade
923 Upgrade an SV to a more complex form. Generally adds a new body type to the
924 SV, then copies across as much information as possible from the old body.
925 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
931 Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
935 const U32 old_type = SvTYPE(sv);
936 const struct body_details *const old_type_details
937 = bodies_by_type + old_type;
938 const struct body_details *new_type_details = bodies_by_type + new_type;
940 if (new_type != SVt_PV && SvIsCOW(sv)) {
941 sv_force_normal_flags(sv, 0);
944 if (old_type == new_type)
947 if (old_type > new_type)
948 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
949 (int)old_type, (int)new_type);
952 old_body = SvANY(sv);
954 /* Copying structures onto other structures that have been neatly zeroed
955 has a subtle gotcha. Consider XPVMG
957 +------+------+------+------+------+-------+-------+
958 | NV | CUR | LEN | IV | MAGIC | STASH |
959 +------+------+------+------+------+-------+-------+
962 where NVs are aligned to 8 bytes, so that sizeof that structure is
963 actually 32 bytes long, with 4 bytes of padding at the end:
965 +------+------+------+------+------+-------+-------+------+
966 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
967 +------+------+------+------+------+-------+-------+------+
968 0 4 8 12 16 20 24 28 32
970 so what happens if you allocate memory for this structure:
972 +------+------+------+------+------+-------+-------+------+------+...
973 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
974 +------+------+------+------+------+-------+-------+------+------+...
975 0 4 8 12 16 20 24 28 32 36
977 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
978 expect, because you copy the area marked ??? onto GP. Now, ??? may have
979 started out as zero once, but it's quite possible that it isn't. So now,
980 rather than a nicely zeroed GP, you have it pointing somewhere random.
983 (In fact, GP ends up pointing at a previous GP structure, because the
984 principle cause of the padding in XPVMG getting garbage is a copy of
985 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
987 So we are careful and work out the size of used parts of all the
994 if (new_type < SVt_PVIV) {
995 new_type = (new_type == SVt_NV)
996 ? SVt_PVNV : SVt_PVIV;
997 new_type_details = bodies_by_type + new_type;
1001 if (new_type < SVt_PVNV) {
1002 new_type = SVt_PVNV;
1003 new_type_details = bodies_by_type + new_type;
1009 assert(new_type > SVt_PV);
1010 assert(SVt_IV < SVt_PV);
1011 assert(SVt_NV < SVt_PV);
1018 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1019 there's no way that it can be safely upgraded, because perl.c
1020 expects to Safefree(SvANY(PL_mess_sv)) */
1021 assert(sv != PL_mess_sv);
1022 /* This flag bit is used to mean other things in other scalar types.
1023 Given that it only has meaning inside the pad, it shouldn't be set
1024 on anything that can get upgraded. */
1025 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1028 if (old_type_details->cant_upgrade)
1029 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1032 SvFLAGS(sv) &= ~SVTYPEMASK;
1033 SvFLAGS(sv) |= new_type;
1037 Perl_croak(aTHX_ "Can't upgrade to undef");
1039 assert(old_type == SVt_NULL);
1040 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1044 assert(old_type == SVt_NULL);
1045 SvANY(sv) = new_XNV();
1049 assert(old_type == SVt_NULL);
1050 SvANY(sv) = &sv->sv_u.svu_rv;
1054 SvANY(sv) = new_XPVHV();
1057 HvTOTALKEYS(sv) = 0;
1062 SvANY(sv) = new_XPVAV();
1069 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1070 The target created by newSVrv also is, and it can have magic.
1071 However, it never has SvPVX set.
1073 if (old_type >= SVt_RV) {
1074 assert(SvPVX_const(sv) == 0);
1077 /* Could put this in the else clause below, as PVMG must have SvPVX
1078 0 already (the assertion above) */
1079 SvPV_set(sv, (char*)0);
1081 if (old_type >= SVt_PVMG) {
1082 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
1083 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1092 /* XXX Is this still needed? Was it ever needed? Surely as there is
1093 no route from NV to PVIV, NOK can never be true */
1094 assert(!SvNOKp(sv));
1106 assert(new_type_details->size);
1107 /* We always allocated the full length item with PURIFY. To do this
1108 we fake things so that arena is false for all 16 types.. */
1109 if(new_type_details->arena) {
1110 /* This points to the start of the allocated area. */
1111 new_body_inline(new_body, new_type_details->size, new_type);
1112 Zero(new_body, new_type_details->size, char);
1113 new_body = ((char *)new_body) - new_type_details->offset;
1115 new_body = new_NOARENAZ(new_type_details);
1117 SvANY(sv) = new_body;
1119 if (old_type_details->copy) {
1120 Copy((char *)old_body + old_type_details->offset,
1121 (char *)new_body + old_type_details->offset,
1122 old_type_details->copy, char);
1125 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1126 /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct
1128 if (old_type_details->zero_nv)
1132 if (new_type == SVt_PVIO)
1133 IoPAGE_LEN(sv) = 60;
1134 if (old_type < SVt_RV)
1138 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", new_type);
1141 if (old_type_details->size) {
1142 /* If the old body had an allocated size, then we need to free it. */
1144 my_safefree(old_body);
1146 del_body((void*)((char*)old_body + old_type_details->offset),
1147 &PL_body_roots[old_type]);
1153 =for apidoc sv_backoff
1155 Remove any string offset. You should normally use the C<SvOOK_off> macro
1162 Perl_sv_backoff(pTHX_ register SV *sv)
1165 assert(SvTYPE(sv) != SVt_PVHV);
1166 assert(SvTYPE(sv) != SVt_PVAV);
1168 const char * const s = SvPVX_const(sv);
1169 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1170 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1172 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1174 SvFLAGS(sv) &= ~SVf_OOK;
1181 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1182 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1183 Use the C<SvGROW> wrapper instead.
1189 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1193 #ifdef HAS_64K_LIMIT
1194 if (newlen >= 0x10000) {
1195 PerlIO_printf(Perl_debug_log,
1196 "Allocation too large: %"UVxf"\n", (UV)newlen);
1199 #endif /* HAS_64K_LIMIT */
1202 if (SvTYPE(sv) < SVt_PV) {
1203 sv_upgrade(sv, SVt_PV);
1204 s = SvPVX_mutable(sv);
1206 else if (SvOOK(sv)) { /* pv is offset? */
1208 s = SvPVX_mutable(sv);
1209 if (newlen > SvLEN(sv))
1210 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1211 #ifdef HAS_64K_LIMIT
1212 if (newlen >= 0x10000)
1217 s = SvPVX_mutable(sv);
1219 if (newlen > SvLEN(sv)) { /* need more room? */
1220 newlen = PERL_STRLEN_ROUNDUP(newlen);
1221 if (SvLEN(sv) && s) {
1223 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1229 s = saferealloc(s, newlen);
1232 s = safemalloc(newlen);
1233 if (SvPVX_const(sv) && SvCUR(sv)) {
1234 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1238 SvLEN_set(sv, newlen);
1244 =for apidoc sv_setiv
1246 Copies an integer into the given SV, upgrading first if necessary.
1247 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1253 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1255 SV_CHECK_THINKFIRST_COW_DROP(sv);
1256 switch (SvTYPE(sv)) {
1258 sv_upgrade(sv, SVt_IV);
1261 sv_upgrade(sv, SVt_PVNV);
1265 sv_upgrade(sv, SVt_PVIV);
1274 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1277 (void)SvIOK_only(sv); /* validate number */
1283 =for apidoc sv_setiv_mg
1285 Like C<sv_setiv>, but also handles 'set' magic.
1291 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1298 =for apidoc sv_setuv
1300 Copies an unsigned integer into the given SV, upgrading first if necessary.
1301 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1307 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1309 /* With these two if statements:
1310 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1313 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1315 If you wish to remove them, please benchmark to see what the effect is
1317 if (u <= (UV)IV_MAX) {
1318 sv_setiv(sv, (IV)u);
1327 =for apidoc sv_setuv_mg
1329 Like C<sv_setuv>, but also handles 'set' magic.
1335 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1344 =for apidoc sv_setnv
1346 Copies a double into the given SV, upgrading first if necessary.
1347 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1353 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1355 SV_CHECK_THINKFIRST_COW_DROP(sv);
1356 switch (SvTYPE(sv)) {
1359 sv_upgrade(sv, SVt_NV);
1364 sv_upgrade(sv, SVt_PVNV);
1373 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1377 (void)SvNOK_only(sv); /* validate number */
1382 =for apidoc sv_setnv_mg
1384 Like C<sv_setnv>, but also handles 'set' magic.
1390 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1396 /* Print an "isn't numeric" warning, using a cleaned-up,
1397 * printable version of the offending string
1401 S_not_a_number(pTHX_ SV *sv)
1408 dsv = sv_2mortal(newSVpvn("", 0));
1409 pv = sv_uni_display(dsv, sv, 10, 0);
1412 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1413 /* each *s can expand to 4 chars + "...\0",
1414 i.e. need room for 8 chars */
1416 const char *s = SvPVX_const(sv);
1417 const char * const end = s + SvCUR(sv);
1418 for ( ; s < end && d < limit; s++ ) {
1420 if (ch & 128 && !isPRINT_LC(ch)) {
1429 else if (ch == '\r') {
1433 else if (ch == '\f') {
1437 else if (ch == '\\') {
1441 else if (ch == '\0') {
1445 else if (isPRINT_LC(ch))
1462 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1463 "Argument \"%s\" isn't numeric in %s", pv,
1466 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1467 "Argument \"%s\" isn't numeric", pv);
1471 =for apidoc looks_like_number
1473 Test if the content of an SV looks like a number (or is a number).
1474 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1475 non-numeric warning), even if your atof() doesn't grok them.
1481 Perl_looks_like_number(pTHX_ SV *sv)
1483 register const char *sbegin;
1487 sbegin = SvPVX_const(sv);
1490 else if (SvPOKp(sv))
1491 sbegin = SvPV_const(sv, len);
1493 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1494 return grok_number(sbegin, len, NULL);
1497 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1498 until proven guilty, assume that things are not that bad... */
1503 As 64 bit platforms often have an NV that doesn't preserve all bits of
1504 an IV (an assumption perl has been based on to date) it becomes necessary
1505 to remove the assumption that the NV always carries enough precision to
1506 recreate the IV whenever needed, and that the NV is the canonical form.
1507 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1508 precision as a side effect of conversion (which would lead to insanity
1509 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1510 1) to distinguish between IV/UV/NV slots that have cached a valid
1511 conversion where precision was lost and IV/UV/NV slots that have a
1512 valid conversion which has lost no precision
1513 2) to ensure that if a numeric conversion to one form is requested that
1514 would lose precision, the precise conversion (or differently
1515 imprecise conversion) is also performed and cached, to prevent
1516 requests for different numeric formats on the same SV causing
1517 lossy conversion chains. (lossless conversion chains are perfectly
1522 SvIOKp is true if the IV slot contains a valid value
1523 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1524 SvNOKp is true if the NV slot contains a valid value
1525 SvNOK is true only if the NV value is accurate
1528 while converting from PV to NV, check to see if converting that NV to an
1529 IV(or UV) would lose accuracy over a direct conversion from PV to
1530 IV(or UV). If it would, cache both conversions, return NV, but mark
1531 SV as IOK NOKp (ie not NOK).
1533 While converting from PV to IV, check to see if converting that IV to an
1534 NV would lose accuracy over a direct conversion from PV to NV. If it
1535 would, cache both conversions, flag similarly.
1537 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1538 correctly because if IV & NV were set NV *always* overruled.
1539 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1540 changes - now IV and NV together means that the two are interchangeable:
1541 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1543 The benefit of this is that operations such as pp_add know that if
1544 SvIOK is true for both left and right operands, then integer addition
1545 can be used instead of floating point (for cases where the result won't
1546 overflow). Before, floating point was always used, which could lead to
1547 loss of precision compared with integer addition.
1549 * making IV and NV equal status should make maths accurate on 64 bit
1551 * may speed up maths somewhat if pp_add and friends start to use
1552 integers when possible instead of fp. (Hopefully the overhead in
1553 looking for SvIOK and checking for overflow will not outweigh the
1554 fp to integer speedup)
1555 * will slow down integer operations (callers of SvIV) on "inaccurate"
1556 values, as the change from SvIOK to SvIOKp will cause a call into
1557 sv_2iv each time rather than a macro access direct to the IV slot
1558 * should speed up number->string conversion on integers as IV is
1559 favoured when IV and NV are equally accurate
1561 ####################################################################
1562 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1563 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1564 On the other hand, SvUOK is true iff UV.
1565 ####################################################################
1567 Your mileage will vary depending your CPU's relative fp to integer
1571 #ifndef NV_PRESERVES_UV
1572 # define IS_NUMBER_UNDERFLOW_IV 1
1573 # define IS_NUMBER_UNDERFLOW_UV 2
1574 # define IS_NUMBER_IV_AND_UV 2
1575 # define IS_NUMBER_OVERFLOW_IV 4
1576 # define IS_NUMBER_OVERFLOW_UV 5
1578 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1580 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1582 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1584 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));
1585 if (SvNVX(sv) < (NV)IV_MIN) {
1586 (void)SvIOKp_on(sv);
1588 SvIV_set(sv, IV_MIN);
1589 return IS_NUMBER_UNDERFLOW_IV;
1591 if (SvNVX(sv) > (NV)UV_MAX) {
1592 (void)SvIOKp_on(sv);
1595 SvUV_set(sv, UV_MAX);
1596 return IS_NUMBER_OVERFLOW_UV;
1598 (void)SvIOKp_on(sv);
1600 /* Can't use strtol etc to convert this string. (See truth table in
1602 if (SvNVX(sv) <= (UV)IV_MAX) {
1603 SvIV_set(sv, I_V(SvNVX(sv)));
1604 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1605 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1607 /* Integer is imprecise. NOK, IOKp */
1609 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1612 SvUV_set(sv, U_V(SvNVX(sv)));
1613 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1614 if (SvUVX(sv) == UV_MAX) {
1615 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1616 possibly be preserved by NV. Hence, it must be overflow.
1618 return IS_NUMBER_OVERFLOW_UV;
1620 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1622 /* Integer is imprecise. NOK, IOKp */
1624 return IS_NUMBER_OVERFLOW_IV;
1626 #endif /* !NV_PRESERVES_UV*/
1629 S_sv_2iuv_common(pTHX_ SV *sv) {
1631 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1632 * without also getting a cached IV/UV from it at the same time
1633 * (ie PV->NV conversion should detect loss of accuracy and cache
1634 * IV or UV at same time to avoid this. */
1635 /* IV-over-UV optimisation - choose to cache IV if possible */
1637 if (SvTYPE(sv) == SVt_NV)
1638 sv_upgrade(sv, SVt_PVNV);
1640 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1641 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1642 certainly cast into the IV range at IV_MAX, whereas the correct
1643 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1645 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1646 SvIV_set(sv, I_V(SvNVX(sv)));
1647 if (SvNVX(sv) == (NV) SvIVX(sv)
1648 #ifndef NV_PRESERVES_UV
1649 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1650 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1651 /* Don't flag it as "accurately an integer" if the number
1652 came from a (by definition imprecise) NV operation, and
1653 we're outside the range of NV integer precision */
1656 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1657 DEBUG_c(PerlIO_printf(Perl_debug_log,
1658 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
1664 /* IV not precise. No need to convert from PV, as NV
1665 conversion would already have cached IV if it detected
1666 that PV->IV would be better than PV->NV->IV
1667 flags already correct - don't set public IOK. */
1668 DEBUG_c(PerlIO_printf(Perl_debug_log,
1669 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
1674 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1675 but the cast (NV)IV_MIN rounds to a the value less (more
1676 negative) than IV_MIN which happens to be equal to SvNVX ??
1677 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1678 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1679 (NV)UVX == NVX are both true, but the values differ. :-(
1680 Hopefully for 2s complement IV_MIN is something like
1681 0x8000000000000000 which will be exact. NWC */
1684 SvUV_set(sv, U_V(SvNVX(sv)));
1686 (SvNVX(sv) == (NV) SvUVX(sv))
1687 #ifndef NV_PRESERVES_UV
1688 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1689 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1690 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1691 /* Don't flag it as "accurately an integer" if the number
1692 came from a (by definition imprecise) NV operation, and
1693 we're outside the range of NV integer precision */
1698 DEBUG_c(PerlIO_printf(Perl_debug_log,
1699 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1705 else if (SvPOKp(sv) && SvLEN(sv)) {
1707 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
1708 /* We want to avoid a possible problem when we cache an IV/ a UV which
1709 may be later translated to an NV, and the resulting NV is not
1710 the same as the direct translation of the initial string
1711 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
1712 be careful to ensure that the value with the .456 is around if the
1713 NV value is requested in the future).
1715 This means that if we cache such an IV/a UV, we need to cache the
1716 NV as well. Moreover, we trade speed for space, and do not
1717 cache the NV if we are sure it's not needed.
1720 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
1721 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1722 == IS_NUMBER_IN_UV) {
1723 /* It's definitely an integer, only upgrade to PVIV */
1724 if (SvTYPE(sv) < SVt_PVIV)
1725 sv_upgrade(sv, SVt_PVIV);
1727 } else if (SvTYPE(sv) < SVt_PVNV)
1728 sv_upgrade(sv, SVt_PVNV);
1730 /* If NV preserves UV then we only use the UV value if we know that
1731 we aren't going to call atof() below. If NVs don't preserve UVs
1732 then the value returned may have more precision than atof() will
1733 return, even though value isn't perfectly accurate. */
1734 if ((numtype & (IS_NUMBER_IN_UV
1735 #ifdef NV_PRESERVES_UV
1738 )) == IS_NUMBER_IN_UV) {
1739 /* This won't turn off the public IOK flag if it was set above */
1740 (void)SvIOKp_on(sv);
1742 if (!(numtype & IS_NUMBER_NEG)) {
1744 if (value <= (UV)IV_MAX) {
1745 SvIV_set(sv, (IV)value);
1747 /* it didn't overflow, and it was positive. */
1748 SvUV_set(sv, value);
1752 /* 2s complement assumption */
1753 if (value <= (UV)IV_MIN) {
1754 SvIV_set(sv, -(IV)value);
1756 /* Too negative for an IV. This is a double upgrade, but
1757 I'm assuming it will be rare. */
1758 if (SvTYPE(sv) < SVt_PVNV)
1759 sv_upgrade(sv, SVt_PVNV);
1763 SvNV_set(sv, -(NV)value);
1764 SvIV_set(sv, IV_MIN);
1768 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
1769 will be in the previous block to set the IV slot, and the next
1770 block to set the NV slot. So no else here. */
1772 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1773 != IS_NUMBER_IN_UV) {
1774 /* It wasn't an (integer that doesn't overflow the UV). */
1775 SvNV_set(sv, Atof(SvPVX_const(sv)));
1777 if (! numtype && ckWARN(WARN_NUMERIC))
1780 #if defined(USE_LONG_DOUBLE)
1781 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1782 PTR2UV(sv), SvNVX(sv)));
1784 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
1785 PTR2UV(sv), SvNVX(sv)));
1788 #ifdef NV_PRESERVES_UV
1789 (void)SvIOKp_on(sv);
1791 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1792 SvIV_set(sv, I_V(SvNVX(sv)));
1793 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1796 /* Integer is imprecise. NOK, IOKp */
1798 /* UV will not work better than IV */
1800 if (SvNVX(sv) > (NV)UV_MAX) {
1802 /* Integer is inaccurate. NOK, IOKp, is UV */
1803 SvUV_set(sv, UV_MAX);
1805 SvUV_set(sv, U_V(SvNVX(sv)));
1806 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
1807 NV preservse UV so can do correct comparison. */
1808 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1811 /* Integer is imprecise. NOK, IOKp, is UV */
1816 #else /* NV_PRESERVES_UV */
1817 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1818 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
1819 /* The IV/UV slot will have been set from value returned by
1820 grok_number above. The NV slot has just been set using
1823 assert (SvIOKp(sv));
1825 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1826 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1827 /* Small enough to preserve all bits. */
1828 (void)SvIOKp_on(sv);
1830 SvIV_set(sv, I_V(SvNVX(sv)));
1831 if ((NV)(SvIVX(sv)) == SvNVX(sv))
1833 /* Assumption: first non-preserved integer is < IV_MAX,
1834 this NV is in the preserved range, therefore: */
1835 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1837 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);
1841 0 0 already failed to read UV.
1842 0 1 already failed to read UV.
1843 1 0 you won't get here in this case. IV/UV
1844 slot set, public IOK, Atof() unneeded.
1845 1 1 already read UV.
1846 so there's no point in sv_2iuv_non_preserve() attempting
1847 to use atol, strtol, strtoul etc. */
1848 sv_2iuv_non_preserve (sv, numtype);
1851 #endif /* NV_PRESERVES_UV */
1855 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1856 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
1859 if (SvTYPE(sv) < SVt_IV)
1860 /* Typically the caller expects that sv_any is not NULL now. */
1861 sv_upgrade(sv, SVt_IV);
1862 /* Return 0 from the caller. */
1869 =for apidoc sv_2iv_flags
1871 Return the integer value of an SV, doing any necessary string
1872 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
1873 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
1879 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
1883 if (SvGMAGICAL(sv)) {
1884 if (flags & SV_GMAGIC)
1889 return I_V(SvNVX(sv));
1891 if (SvPOKp(sv) && SvLEN(sv)) {
1894 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
1896 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1897 == IS_NUMBER_IN_UV) {
1898 /* It's definitely an integer */
1899 if (numtype & IS_NUMBER_NEG) {
1900 if (value < (UV)IV_MIN)
1903 if (value < (UV)IV_MAX)
1908 if (ckWARN(WARN_NUMERIC))
1911 return I_V(Atof(SvPVX_const(sv)));
1916 assert(SvTYPE(sv) >= SVt_PVMG);
1917 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
1919 if (SvTHINKFIRST(sv)) {
1923 SV * const tmpstr=AMG_CALLun(sv,numer);
1924 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
1925 return SvIV(tmpstr);
1928 return PTR2IV(SvRV(sv));
1931 sv_force_normal_flags(sv, 0);
1933 if (SvREADONLY(sv) && !SvOK(sv)) {
1934 if (ckWARN(WARN_UNINITIALIZED))
1940 if (S_sv_2iuv_common(aTHX_ sv))
1943 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1944 PTR2UV(sv),SvIVX(sv)));
1945 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1949 =for apidoc sv_2uv_flags
1951 Return the unsigned integer value of an SV, doing any necessary string
1952 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
1953 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
1959 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
1963 if (SvGMAGICAL(sv)) {
1964 if (flags & SV_GMAGIC)
1969 return U_V(SvNVX(sv));
1970 if (SvPOKp(sv) && SvLEN(sv)) {
1973 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
1975 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1976 == IS_NUMBER_IN_UV) {
1977 /* It's definitely an integer */
1978 if (!(numtype & IS_NUMBER_NEG))
1982 if (ckWARN(WARN_NUMERIC))
1985 return U_V(Atof(SvPVX_const(sv)));
1990 assert(SvTYPE(sv) >= SVt_PVMG);
1991 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
1993 if (SvTHINKFIRST(sv)) {
1997 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1998 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
1999 return SvUV(tmpstr);
2000 return PTR2UV(SvRV(sv));
2003 sv_force_normal_flags(sv, 0);
2005 if (SvREADONLY(sv) && !SvOK(sv)) {
2006 if (ckWARN(WARN_UNINITIALIZED))
2012 if (S_sv_2iuv_common(aTHX_ sv))
2016 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2017 PTR2UV(sv),SvUVX(sv)));
2018 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2024 Return the num value of an SV, doing any necessary string or integer
2025 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2032 Perl_sv_2nv(pTHX_ register SV *sv)
2036 if (SvGMAGICAL(sv)) {
2040 if (SvPOKp(sv) && SvLEN(sv)) {
2041 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2042 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2044 return Atof(SvPVX_const(sv));
2048 return (NV)SvUVX(sv);
2050 return (NV)SvIVX(sv);
2055 assert(SvTYPE(sv) >= SVt_PVMG);
2056 /* This falls through to the report_uninit near the end of the
2058 } else if (SvTHINKFIRST(sv)) {
2062 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2063 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2064 return SvNV(tmpstr);
2065 return PTR2NV(SvRV(sv));
2068 sv_force_normal_flags(sv, 0);
2070 if (SvREADONLY(sv) && !SvOK(sv)) {
2071 if (ckWARN(WARN_UNINITIALIZED))
2076 if (SvTYPE(sv) < SVt_NV) {
2077 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2078 sv_upgrade(sv, SVt_NV);
2079 #ifdef USE_LONG_DOUBLE
2081 STORE_NUMERIC_LOCAL_SET_STANDARD();
2082 PerlIO_printf(Perl_debug_log,
2083 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2084 PTR2UV(sv), SvNVX(sv));
2085 RESTORE_NUMERIC_LOCAL();
2089 STORE_NUMERIC_LOCAL_SET_STANDARD();
2090 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2091 PTR2UV(sv), SvNVX(sv));
2092 RESTORE_NUMERIC_LOCAL();
2096 else if (SvTYPE(sv) < SVt_PVNV)
2097 sv_upgrade(sv, SVt_PVNV);
2102 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2103 #ifdef NV_PRESERVES_UV
2106 /* Only set the public NV OK flag if this NV preserves the IV */
2107 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2108 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2109 : (SvIVX(sv) == I_V(SvNVX(sv))))
2115 else if (SvPOKp(sv) && SvLEN(sv)) {
2117 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2118 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2120 #ifdef NV_PRESERVES_UV
2121 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2122 == IS_NUMBER_IN_UV) {
2123 /* It's definitely an integer */
2124 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2126 SvNV_set(sv, Atof(SvPVX_const(sv)));
2129 SvNV_set(sv, Atof(SvPVX_const(sv)));
2130 /* Only set the public NV OK flag if this NV preserves the value in
2131 the PV at least as well as an IV/UV would.
2132 Not sure how to do this 100% reliably. */
2133 /* if that shift count is out of range then Configure's test is
2134 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2136 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2137 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2138 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2139 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2140 /* Can't use strtol etc to convert this string, so don't try.
2141 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2144 /* value has been set. It may not be precise. */
2145 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2146 /* 2s complement assumption for (UV)IV_MIN */
2147 SvNOK_on(sv); /* Integer is too negative. */
2152 if (numtype & IS_NUMBER_NEG) {
2153 SvIV_set(sv, -(IV)value);
2154 } else if (value <= (UV)IV_MAX) {
2155 SvIV_set(sv, (IV)value);
2157 SvUV_set(sv, value);
2161 if (numtype & IS_NUMBER_NOT_INT) {
2162 /* I believe that even if the original PV had decimals,
2163 they are lost beyond the limit of the FP precision.
2164 However, neither is canonical, so both only get p
2165 flags. NWC, 2000/11/25 */
2166 /* Both already have p flags, so do nothing */
2168 const NV nv = SvNVX(sv);
2169 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2170 if (SvIVX(sv) == I_V(nv)) {
2173 /* It had no "." so it must be integer. */
2177 /* between IV_MAX and NV(UV_MAX).
2178 Could be slightly > UV_MAX */
2180 if (numtype & IS_NUMBER_NOT_INT) {
2181 /* UV and NV both imprecise. */
2183 const UV nv_as_uv = U_V(nv);
2185 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2194 #endif /* NV_PRESERVES_UV */
2197 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2199 assert (SvTYPE(sv) >= SVt_NV);
2200 /* Typically the caller expects that sv_any is not NULL now. */
2201 /* XXX Ilya implies that this is a bug in callers that assume this
2202 and ideally should be fixed. */
2205 #if defined(USE_LONG_DOUBLE)
2207 STORE_NUMERIC_LOCAL_SET_STANDARD();
2208 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2209 PTR2UV(sv), SvNVX(sv));
2210 RESTORE_NUMERIC_LOCAL();
2214 STORE_NUMERIC_LOCAL_SET_STANDARD();
2215 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2216 PTR2UV(sv), SvNVX(sv));
2217 RESTORE_NUMERIC_LOCAL();
2223 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2224 * UV as a string towards the end of buf, and return pointers to start and
2227 * We assume that buf is at least TYPE_CHARS(UV) long.
2231 S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2233 char *ptr = buf + TYPE_CHARS(UV);
2234 char * const ebuf = ptr;
2247 *--ptr = '0' + (char)(uv % 10);
2255 /* stringify_regexp(): private routine for use by sv_2pv_flags(): converts
2256 * a regexp to its stringified form.
2260 S_stringify_regexp(pTHX_ SV *sv, MAGIC *mg, STRLEN *lp) {
2261 const regexp * const re = (regexp *)mg->mg_obj;
2264 const char *fptr = "msix";
2269 bool need_newline = 0;
2270 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
2272 while((ch = *fptr++)) {
2274 reflags[left++] = ch;
2277 reflags[right--] = ch;
2282 reflags[left] = '-';
2286 mg->mg_len = re->prelen + 4 + left;
2288 * If /x was used, we have to worry about a regex ending with a
2289 * comment later being embedded within another regex. If so, we don't
2290 * want this regex's "commentization" to leak out to the right part of
2291 * the enclosing regex, we must cap it with a newline.
2293 * So, if /x was used, we scan backwards from the end of the regex. If
2294 * we find a '#' before we find a newline, we need to add a newline
2295 * ourself. If we find a '\n' first (or if we don't find '#' or '\n'),
2296 * we don't need to add anything. -jfriedl
2298 if (PMf_EXTENDED & re->reganch) {
2299 const char *endptr = re->precomp + re->prelen;
2300 while (endptr >= re->precomp) {
2301 const char c = *(endptr--);
2303 break; /* don't need another */
2305 /* we end while in a comment, so we need a newline */
2306 mg->mg_len++; /* save space for it */
2307 need_newline = 1; /* note to add it */
2313 Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
2314 mg->mg_ptr[0] = '(';
2315 mg->mg_ptr[1] = '?';
2316 Copy(reflags, mg->mg_ptr+2, left, char);
2317 *(mg->mg_ptr+left+2) = ':';
2318 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2320 mg->mg_ptr[mg->mg_len - 2] = '\n';
2321 mg->mg_ptr[mg->mg_len - 1] = ')';
2322 mg->mg_ptr[mg->mg_len] = 0;
2324 PL_reginterp_cnt += re->program[0].next_off;
2326 if (re->reganch & ROPT_UTF8)
2336 =for apidoc sv_2pv_flags
2338 Returns a pointer to the string value of an SV, and sets *lp to its length.
2339 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2341 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2342 usually end up here too.
2348 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2358 if (SvGMAGICAL(sv)) {
2359 if (flags & SV_GMAGIC)
2364 if (flags & SV_MUTABLE_RETURN)
2365 return SvPVX_mutable(sv);
2366 if (flags & SV_CONST_RETURN)
2367 return (char *)SvPVX_const(sv);
2370 if (SvIOKp(sv) || SvNOKp(sv)) {
2371 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2375 len = SvIsUV(sv) ? my_sprintf(tbuf,"%"UVuf, (UV)SvUVX(sv))
2376 : my_sprintf(tbuf,"%"IVdf, (IV)SvIVX(sv));
2378 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2381 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2382 /* Sneaky stuff here */
2383 SV * const tsv = newSVpvn(tbuf, len);
2393 #ifdef FIXNEGATIVEZERO
2394 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2400 SvUPGRADE(sv, SVt_PV);
2403 s = SvGROW_mutable(sv, len + 1);
2406 return memcpy(s, tbuf, len + 1);
2412 assert(SvTYPE(sv) >= SVt_PVMG);
2413 /* This falls through to the report_uninit near the end of the
2415 } else if (SvTHINKFIRST(sv)) {
2420 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2421 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2423 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
2426 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2427 if (flags & SV_CONST_RETURN) {
2428 pv = (char *) SvPVX_const(tmpstr);
2430 pv = (flags & SV_MUTABLE_RETURN)
2431 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2434 *lp = SvCUR(tmpstr);
2436 pv = sv_2pv_flags(tmpstr, lp, flags);
2446 const SV *const referent = (SV*)SvRV(sv);
2449 tsv = sv_2mortal(newSVpvn("NULLREF", 7));
2450 } else if (SvTYPE(referent) == SVt_PVMG
2451 && ((SvFLAGS(referent) &
2452 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2453 == (SVs_OBJECT|SVs_SMG))
2454 && (mg = mg_find(referent, PERL_MAGIC_qr))) {
2455 return S_stringify_regexp(aTHX_ sv, mg, lp);
2457 const char *const typestr = sv_reftype(referent, 0);
2459 tsv = sv_newmortal();
2460 if (SvOBJECT(referent)) {
2461 const char *const name = HvNAME_get(SvSTASH(referent));
2462 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
2463 name ? name : "__ANON__" , typestr,
2467 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr,
2475 if (SvREADONLY(sv) && !SvOK(sv)) {
2476 if (ckWARN(WARN_UNINITIALIZED))
2483 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2484 /* I'm assuming that if both IV and NV are equally valid then
2485 converting the IV is going to be more efficient */
2486 const U32 isIOK = SvIOK(sv);
2487 const U32 isUIOK = SvIsUV(sv);
2488 char buf[TYPE_CHARS(UV)];
2491 if (SvTYPE(sv) < SVt_PVIV)
2492 sv_upgrade(sv, SVt_PVIV);
2494 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2496 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2497 /* inlined from sv_setpvn */
2498 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
2499 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
2500 SvCUR_set(sv, ebuf - ptr);
2510 else if (SvNOKp(sv)) {
2511 if (SvTYPE(sv) < SVt_PVNV)
2512 sv_upgrade(sv, SVt_PVNV);
2513 /* The +20 is pure guesswork. Configure test needed. --jhi */
2514 s = SvGROW_mutable(sv, NV_DIG + 20);
2515 olderrno = errno; /* some Xenix systems wipe out errno here */
2517 if (SvNVX(sv) == 0.0)
2518 (void)strcpy(s,"0");
2522 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2525 #ifdef FIXNEGATIVEZERO
2526 if (*s == '-' && s[1] == '0' && !s[2])
2536 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2540 if (SvTYPE(sv) < SVt_PV)
2541 /* Typically the caller expects that sv_any is not NULL now. */
2542 sv_upgrade(sv, SVt_PV);
2546 const STRLEN len = s - SvPVX_const(sv);
2552 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2553 PTR2UV(sv),SvPVX_const(sv)));
2554 if (flags & SV_CONST_RETURN)
2555 return (char *)SvPVX_const(sv);
2556 if (flags & SV_MUTABLE_RETURN)
2557 return SvPVX_mutable(sv);
2562 =for apidoc sv_copypv
2564 Copies a stringified representation of the source SV into the
2565 destination SV. Automatically performs any necessary mg_get and
2566 coercion of numeric values into strings. Guaranteed to preserve
2567 UTF-8 flag even from overloaded objects. Similar in nature to
2568 sv_2pv[_flags] but operates directly on an SV instead of just the
2569 string. Mostly uses sv_2pv_flags to do its work, except when that
2570 would lose the UTF-8'ness of the PV.
2576 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
2579 const char * const s = SvPV_const(ssv,len);
2580 sv_setpvn(dsv,s,len);
2588 =for apidoc sv_2pvbyte
2590 Return a pointer to the byte-encoded representation of the SV, and set *lp
2591 to its length. May cause the SV to be downgraded from UTF-8 as a
2594 Usually accessed via the C<SvPVbyte> macro.
2600 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2602 sv_utf8_downgrade(sv,0);
2603 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2607 =for apidoc sv_2pvutf8
2609 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
2610 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
2612 Usually accessed via the C<SvPVutf8> macro.
2618 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2620 sv_utf8_upgrade(sv);
2621 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2626 =for apidoc sv_2bool
2628 This function is only called on magical items, and is only used by
2629 sv_true() or its macro equivalent.
2635 Perl_sv_2bool(pTHX_ register SV *sv)
2643 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2644 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2645 return (bool)SvTRUE(tmpsv);
2646 return SvRV(sv) != 0;
2649 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
2651 (*sv->sv_u.svu_pv > '0' ||
2652 Xpvtmp->xpv_cur > 1 ||
2653 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
2660 return SvIVX(sv) != 0;
2663 return SvNVX(sv) != 0.0;
2671 =for apidoc sv_utf8_upgrade
2673 Converts the PV of an SV to its UTF-8-encoded form.
2674 Forces the SV to string form if it is not already.
2675 Always sets the SvUTF8 flag to avoid future validity checks even
2676 if all the bytes have hibit clear.
2678 This is not as a general purpose byte encoding to Unicode interface:
2679 use the Encode extension for that.
2681 =for apidoc sv_utf8_upgrade_flags
2683 Converts the PV of an SV to its UTF-8-encoded form.
2684 Forces the SV to string form if it is not already.
2685 Always sets the SvUTF8 flag to avoid future validity checks even
2686 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
2687 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
2688 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
2690 This is not as a general purpose byte encoding to Unicode interface:
2691 use the Encode extension for that.
2697 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
2699 if (sv == &PL_sv_undef)
2703 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
2704 (void) sv_2pv_flags(sv,&len, flags);
2708 (void) SvPV_force(sv,len);
2717 sv_force_normal_flags(sv, 0);
2720 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
2721 sv_recode_to_utf8(sv, PL_encoding);
2722 else { /* Assume Latin-1/EBCDIC */
2723 /* This function could be much more efficient if we
2724 * had a FLAG in SVs to signal if there are any hibit
2725 * chars in the PV. Given that there isn't such a flag
2726 * make the loop as fast as possible. */
2727 const U8 * const s = (U8 *) SvPVX_const(sv);
2728 const U8 * const e = (U8 *) SvEND(sv);
2733 /* Check for hi bit */
2734 if (!NATIVE_IS_INVARIANT(ch)) {
2735 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
2736 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
2738 SvPV_free(sv); /* No longer using what was there before. */
2739 SvPV_set(sv, (char*)recoded);
2740 SvCUR_set(sv, len - 1);
2741 SvLEN_set(sv, len); /* No longer know the real size. */
2745 /* Mark as UTF-8 even if no hibit - saves scanning loop */
2752 =for apidoc sv_utf8_downgrade
2754 Attempts to convert the PV of an SV from characters to bytes.
2755 If the PV contains a character beyond byte, this conversion will fail;
2756 in this case, either returns false or, if C<fail_ok> is not
2759 This is not as a general purpose Unicode to byte encoding interface:
2760 use the Encode extension for that.
2766 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2768 if (SvPOKp(sv) && SvUTF8(sv)) {
2774 sv_force_normal_flags(sv, 0);
2776 s = (U8 *) SvPV(sv, len);
2777 if (!utf8_to_bytes(s, &len)) {
2782 Perl_croak(aTHX_ "Wide character in %s",
2785 Perl_croak(aTHX_ "Wide character");
2796 =for apidoc sv_utf8_encode
2798 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
2799 flag off so that it looks like octets again.
2805 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2807 (void) sv_utf8_upgrade(sv);
2809 sv_force_normal_flags(sv, 0);
2811 if (SvREADONLY(sv)) {
2812 Perl_croak(aTHX_ PL_no_modify);
2818 =for apidoc sv_utf8_decode
2820 If the PV of the SV is an octet sequence in UTF-8
2821 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
2822 so that it looks like a character. If the PV contains only single-byte
2823 characters, the C<SvUTF8> flag stays being off.
2824 Scans PV for validity and returns false if the PV is invalid UTF-8.
2830 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2836 /* The octets may have got themselves encoded - get them back as
2839 if (!sv_utf8_downgrade(sv, TRUE))
2842 /* it is actually just a matter of turning the utf8 flag on, but
2843 * we want to make sure everything inside is valid utf8 first.
2845 c = (const U8 *) SvPVX_const(sv);
2846 if (!is_utf8_string(c, SvCUR(sv)+1))
2848 e = (const U8 *) SvEND(sv);
2851 if (!UTF8_IS_INVARIANT(ch)) {
2861 =for apidoc sv_setsv
2863 Copies the contents of the source SV C<ssv> into the destination SV
2864 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
2865 function if the source SV needs to be reused. Does not handle 'set' magic.
2866 Loosely speaking, it performs a copy-by-value, obliterating any previous
2867 content of the destination.
2869 You probably want to use one of the assortment of wrappers, such as
2870 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
2871 C<SvSetMagicSV_nosteal>.
2873 =for apidoc sv_setsv_flags
2875 Copies the contents of the source SV C<ssv> into the destination SV
2876 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
2877 function if the source SV needs to be reused. Does not handle 'set' magic.
2878 Loosely speaking, it performs a copy-by-value, obliterating any previous
2879 content of the destination.
2880 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
2881 C<ssv> if appropriate, else not. If the C<flags> parameter has the
2882 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
2883 and C<sv_setsv_nomg> are implemented in terms of this function.
2885 You probably want to use one of the assortment of wrappers, such as
2886 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
2887 C<SvSetMagicSV_nosteal>.
2889 This is the primary function for copying scalars, and most other
2890 copy-ish functions and macros use this underneath.
2896 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
2898 register U32 sflags;
2904 SV_CHECK_THINKFIRST_COW_DROP(dstr);
2906 sstr = &PL_sv_undef;
2907 stype = SvTYPE(sstr);
2908 dtype = SvTYPE(dstr);
2913 /* need to nuke the magic */
2915 SvRMAGICAL_off(dstr);
2918 /* There's a lot of redundancy below but we're going for speed here */
2923 if (dtype != SVt_PVGV) {
2924 (void)SvOK_off(dstr);
2932 sv_upgrade(dstr, SVt_IV);
2935 sv_upgrade(dstr, SVt_PVNV);
2939 sv_upgrade(dstr, SVt_PVIV);
2942 (void)SvIOK_only(dstr);
2943 SvIV_set(dstr, SvIVX(sstr));
2946 if (SvTAINTED(sstr))
2957 sv_upgrade(dstr, SVt_NV);
2962 sv_upgrade(dstr, SVt_PVNV);
2965 SvNV_set(dstr, SvNVX(sstr));
2966 (void)SvNOK_only(dstr);
2967 if (SvTAINTED(sstr))
2975 sv_upgrade(dstr, SVt_RV);
2976 else if (dtype == SVt_PVGV &&
2977 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2980 if (GvIMPORTED(dstr) != GVf_IMPORTED
2981 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2983 GvIMPORTED_on(dstr);
2992 #ifdef PERL_OLD_COPY_ON_WRITE
2993 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
2994 if (dtype < SVt_PVIV)
2995 sv_upgrade(dstr, SVt_PVIV);
3002 sv_upgrade(dstr, SVt_PV);
3005 if (dtype < SVt_PVIV)
3006 sv_upgrade(dstr, SVt_PVIV);
3009 if (dtype < SVt_PVNV)
3010 sv_upgrade(dstr, SVt_PVNV);
3017 const char * const type = sv_reftype(sstr,0);
3019 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3021 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3026 if (dtype <= SVt_PVGV) {
3028 if (dtype != SVt_PVGV) {
3029 const char * const name = GvNAME(sstr);
3030 const STRLEN len = GvNAMELEN(sstr);
3031 /* don't upgrade SVt_PVLV: it can hold a glob */
3032 if (dtype != SVt_PVLV)
3033 sv_upgrade(dstr, SVt_PVGV);
3034 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3035 GvSTASH(dstr) = GvSTASH(sstr);
3037 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3038 GvNAME(dstr) = savepvn(name, len);
3039 GvNAMELEN(dstr) = len;
3040 SvFAKE_on(dstr); /* can coerce to non-glob */
3043 #ifdef GV_UNIQUE_CHECK
3044 if (GvUNIQUE((GV*)dstr)) {
3045 Perl_croak(aTHX_ PL_no_modify);
3049 (void)SvOK_off(dstr);
3050 GvINTRO_off(dstr); /* one-shot flag */
3052 GvGP(dstr) = gp_ref(GvGP(sstr));
3053 if (SvTAINTED(sstr))
3055 if (GvIMPORTED(dstr) != GVf_IMPORTED
3056 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3058 GvIMPORTED_on(dstr);
3066 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3068 if ((int)SvTYPE(sstr) != stype) {
3069 stype = SvTYPE(sstr);
3070 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3074 if (stype == SVt_PVLV)
3075 SvUPGRADE(dstr, SVt_PVNV);
3077 SvUPGRADE(dstr, (U32)stype);
3080 sflags = SvFLAGS(sstr);
3082 if (sflags & SVf_ROK) {
3083 if (dtype >= SVt_PV) {
3084 if (dtype == SVt_PVGV) {
3085 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3087 const int intro = GvINTRO(dstr);
3089 #ifdef GV_UNIQUE_CHECK
3090 if (GvUNIQUE((GV*)dstr)) {
3091 Perl_croak(aTHX_ PL_no_modify);
3096 GvINTRO_off(dstr); /* one-shot flag */
3097 GvLINE(dstr) = CopLINE(PL_curcop);
3098 GvEGV(dstr) = (GV*)dstr;
3101 switch (SvTYPE(sref)) {
3104 SAVEGENERICSV(GvAV(dstr));
3106 dref = (SV*)GvAV(dstr);
3107 GvAV(dstr) = (AV*)sref;
3108 if (!GvIMPORTED_AV(dstr)
3109 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3111 GvIMPORTED_AV_on(dstr);
3116 SAVEGENERICSV(GvHV(dstr));
3118 dref = (SV*)GvHV(dstr);
3119 GvHV(dstr) = (HV*)sref;
3120 if (!GvIMPORTED_HV(dstr)
3121 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3123 GvIMPORTED_HV_on(dstr);
3128 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3129 SvREFCNT_dec(GvCV(dstr));
3130 GvCV(dstr) = Nullcv;
3131 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3132 PL_sub_generation++;
3134 SAVEGENERICSV(GvCV(dstr));
3137 dref = (SV*)GvCV(dstr);
3138 if (GvCV(dstr) != (CV*)sref) {
3139 CV* const cv = GvCV(dstr);
3141 if (!GvCVGEN((GV*)dstr) &&
3142 (CvROOT(cv) || CvXSUB(cv)))
3144 /* Redefining a sub - warning is mandatory if
3145 it was a const and its value changed. */
3146 if (ckWARN(WARN_REDEFINE)
3148 && (!CvCONST((CV*)sref)
3149 || sv_cmp(cv_const_sv(cv),
3150 cv_const_sv((CV*)sref)))))
3152 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3154 ? "Constant subroutine %s::%s redefined"
3155 : "Subroutine %s::%s redefined",
3156 HvNAME_get(GvSTASH((GV*)dstr)),
3157 GvENAME((GV*)dstr));
3161 cv_ckproto(cv, (GV*)dstr,
3163 ? SvPVX_const(sref) : Nullch);
3165 GvCV(dstr) = (CV*)sref;
3166 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3167 GvASSUMECV_on(dstr);
3168 PL_sub_generation++;
3170 if (!GvIMPORTED_CV(dstr)
3171 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3173 GvIMPORTED_CV_on(dstr);
3178 SAVEGENERICSV(GvIOp(dstr));
3180 dref = (SV*)GvIOp(dstr);
3181 GvIOp(dstr) = (IO*)sref;
3185 SAVEGENERICSV(GvFORM(dstr));
3187 dref = (SV*)GvFORM(dstr);
3188 GvFORM(dstr) = (CV*)sref;
3192 SAVEGENERICSV(GvSV(dstr));
3194 dref = (SV*)GvSV(dstr);
3196 if (!GvIMPORTED_SV(dstr)
3197 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3199 GvIMPORTED_SV_on(dstr);
3205 if (SvTAINTED(sstr))
3209 if (SvPVX_const(dstr)) {
3215 (void)SvOK_off(dstr);
3216 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3218 if (sflags & SVp_NOK) {
3220 /* Only set the public OK flag if the source has public OK. */
3221 if (sflags & SVf_NOK)
3222 SvFLAGS(dstr) |= SVf_NOK;
3223 SvNV_set(dstr, SvNVX(sstr));
3225 if (sflags & SVp_IOK) {
3226 (void)SvIOKp_on(dstr);
3227 if (sflags & SVf_IOK)
3228 SvFLAGS(dstr) |= SVf_IOK;
3229 if (sflags & SVf_IVisUV)
3231 SvIV_set(dstr, SvIVX(sstr));
3233 if (SvAMAGIC(sstr)) {
3237 else if (sflags & SVp_POK) {
3241 * Check to see if we can just swipe the string. If so, it's a
3242 * possible small lose on short strings, but a big win on long ones.
3243 * It might even be a win on short strings if SvPVX_const(dstr)
3244 * has to be allocated and SvPVX_const(sstr) has to be freed.
3247 /* Whichever path we take through the next code, we want this true,
3248 and doing it now facilitates the COW check. */
3249 (void)SvPOK_only(dstr);
3252 /* We're not already COW */
3253 ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
3254 #ifndef PERL_OLD_COPY_ON_WRITE
3255 /* or we are, but dstr isn't a suitable target. */
3256 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
3261 (sflags & SVs_TEMP) && /* slated for free anyway? */
3262 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3263 (!(flags & SV_NOSTEAL)) &&
3264 /* and we're allowed to steal temps */
3265 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3266 SvLEN(sstr) && /* and really is a string */
3267 /* and won't be needed again, potentially */
3268 !(PL_op && PL_op->op_type == OP_AASSIGN))
3269 #ifdef PERL_OLD_COPY_ON_WRITE
3270 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
3271 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
3272 && SvTYPE(sstr) >= SVt_PVIV)
3275 /* Failed the swipe test, and it's not a shared hash key either.
3276 Have to copy the string. */
3277 STRLEN len = SvCUR(sstr);
3278 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3279 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
3280 SvCUR_set(dstr, len);
3281 *SvEND(dstr) = '\0';
3283 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
3285 /* Either it's a shared hash key, or it's suitable for
3286 copy-on-write or we can swipe the string. */
3288 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
3292 #ifdef PERL_OLD_COPY_ON_WRITE
3294 /* I believe I should acquire a global SV mutex if
3295 it's a COW sv (not a shared hash key) to stop
3296 it going un copy-on-write.
3297 If the source SV has gone un copy on write between up there
3298 and down here, then (assert() that) it is of the correct
3299 form to make it copy on write again */
3300 if ((sflags & (SVf_FAKE | SVf_READONLY))
3301 != (SVf_FAKE | SVf_READONLY)) {
3302 SvREADONLY_on(sstr);
3304 /* Make the source SV into a loop of 1.
3305 (about to become 2) */
3306 SV_COW_NEXT_SV_SET(sstr, sstr);
3310 /* Initial code is common. */
3311 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
3316 /* making another shared SV. */
3317 STRLEN cur = SvCUR(sstr);
3318 STRLEN len = SvLEN(sstr);
3319 #ifdef PERL_OLD_COPY_ON_WRITE
3321 assert (SvTYPE(dstr) >= SVt_PVIV);
3322 /* SvIsCOW_normal */
3323 /* splice us in between source and next-after-source. */
3324 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3325 SV_COW_NEXT_SV_SET(sstr, dstr);
3326 SvPV_set(dstr, SvPVX_mutable(sstr));
3330 /* SvIsCOW_shared_hash */
3331 DEBUG_C(PerlIO_printf(Perl_debug_log,
3332 "Copy on write: Sharing hash\n"));
3334 assert (SvTYPE(dstr) >= SVt_PV);
3336 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
3338 SvLEN_set(dstr, len);
3339 SvCUR_set(dstr, cur);
3340 SvREADONLY_on(dstr);
3342 /* Relesase a global SV mutex. */
3345 { /* Passes the swipe test. */
3346 SvPV_set(dstr, SvPVX_mutable(sstr));
3347 SvLEN_set(dstr, SvLEN(sstr));
3348 SvCUR_set(dstr, SvCUR(sstr));
3351 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3352 SvPV_set(sstr, Nullch);
3358 if (sflags & SVf_UTF8)
3360 if (sflags & SVp_NOK) {
3362 if (sflags & SVf_NOK)
3363 SvFLAGS(dstr) |= SVf_NOK;
3364 SvNV_set(dstr, SvNVX(sstr));
3366 if (sflags & SVp_IOK) {
3367 (void)SvIOKp_on(dstr);
3368 if (sflags & SVf_IOK)
3369 SvFLAGS(dstr) |= SVf_IOK;
3370 if (sflags & SVf_IVisUV)
3372 SvIV_set(dstr, SvIVX(sstr));
3375 const MAGIC * const smg = mg_find(sstr,PERL_MAGIC_vstring);
3376 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
3377 smg->mg_ptr, smg->mg_len);
3378 SvRMAGICAL_on(dstr);
3381 else if (sflags & SVp_IOK) {
3382 if (sflags & SVf_IOK)
3383 (void)SvIOK_only(dstr);
3385 (void)SvOK_off(dstr);
3386 (void)SvIOKp_on(dstr);
3388 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3389 if (sflags & SVf_IVisUV)
3391 SvIV_set(dstr, SvIVX(sstr));
3392 if (sflags & SVp_NOK) {
3393 if (sflags & SVf_NOK)
3394 (void)SvNOK_on(dstr);
3396 (void)SvNOKp_on(dstr);
3397 SvNV_set(dstr, SvNVX(sstr));
3400 else if (sflags & SVp_NOK) {
3401 if (sflags & SVf_NOK)
3402 (void)SvNOK_only(dstr);
3404 (void)SvOK_off(dstr);
3407 SvNV_set(dstr, SvNVX(sstr));
3410 if (dtype == SVt_PVGV) {
3411 if (ckWARN(WARN_MISC))
3412 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
3415 (void)SvOK_off(dstr);
3417 if (SvTAINTED(sstr))
3422 =for apidoc sv_setsv_mg
3424 Like C<sv_setsv>, but also handles 'set' magic.
3430 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3432 sv_setsv(dstr,sstr);
3436 #ifdef PERL_OLD_COPY_ON_WRITE
3438 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
3440 STRLEN cur = SvCUR(sstr);
3441 STRLEN len = SvLEN(sstr);
3442 register char *new_pv;
3445 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
3453 if (SvTHINKFIRST(dstr))
3454 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
3455 else if (SvPVX_const(dstr))
3456 Safefree(SvPVX_const(dstr));
3460 SvUPGRADE(dstr, SVt_PVIV);
3462 assert (SvPOK(sstr));
3463 assert (SvPOKp(sstr));
3464 assert (!SvIOK(sstr));
3465 assert (!SvIOKp(sstr));
3466 assert (!SvNOK(sstr));
3467 assert (!SvNOKp(sstr));
3469 if (SvIsCOW(sstr)) {
3471 if (SvLEN(sstr) == 0) {
3472 /* source is a COW shared hash key. */
3473 DEBUG_C(PerlIO_printf(Perl_debug_log,
3474 "Fast copy on write: Sharing hash\n"));
3475 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
3478 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3480 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
3481 SvUPGRADE(sstr, SVt_PVIV);
3482 SvREADONLY_on(sstr);
3484 DEBUG_C(PerlIO_printf(Perl_debug_log,
3485 "Fast copy on write: Converting sstr to COW\n"));
3486 SV_COW_NEXT_SV_SET(dstr, sstr);
3488 SV_COW_NEXT_SV_SET(sstr, dstr);
3489 new_pv = SvPVX_mutable(sstr);
3492 SvPV_set(dstr, new_pv);
3493 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
3496 SvLEN_set(dstr, len);
3497 SvCUR_set(dstr, cur);
3506 =for apidoc sv_setpvn
3508 Copies a string into an SV. The C<len> parameter indicates the number of
3509 bytes to be copied. If the C<ptr> argument is NULL the SV will become
3510 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3516 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3518 register char *dptr;
3520 SV_CHECK_THINKFIRST_COW_DROP(sv);
3526 /* len is STRLEN which is unsigned, need to copy to signed */
3529 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3531 SvUPGRADE(sv, SVt_PV);
3533 dptr = SvGROW(sv, len + 1);
3534 Move(ptr,dptr,len,char);
3537 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3542 =for apidoc sv_setpvn_mg
3544 Like C<sv_setpvn>, but also handles 'set' magic.
3550 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3552 sv_setpvn(sv,ptr,len);
3557 =for apidoc sv_setpv
3559 Copies a string into an SV. The string must be null-terminated. Does not
3560 handle 'set' magic. See C<sv_setpv_mg>.
3566 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3568 register STRLEN len;
3570 SV_CHECK_THINKFIRST_COW_DROP(sv);
3576 SvUPGRADE(sv, SVt_PV);
3578 SvGROW(sv, len + 1);
3579 Move(ptr,SvPVX(sv),len+1,char);
3581 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3586 =for apidoc sv_setpv_mg
3588 Like C<sv_setpv>, but also handles 'set' magic.
3594 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3601 =for apidoc sv_usepvn
3603 Tells an SV to use C<ptr> to find its string value. Normally the string is
3604 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3605 The C<ptr> should point to memory that was allocated by C<malloc>. The
3606 string length, C<len>, must be supplied. This function will realloc the
3607 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3608 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3609 See C<sv_usepvn_mg>.
3615 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3618 SV_CHECK_THINKFIRST_COW_DROP(sv);
3619 SvUPGRADE(sv, SVt_PV);
3624 if (SvPVX_const(sv))
3627 allocate = PERL_STRLEN_ROUNDUP(len + 1);
3628 ptr = saferealloc (ptr, allocate);
3631 SvLEN_set(sv, allocate);
3633 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3638 =for apidoc sv_usepvn_mg
3640 Like C<sv_usepvn>, but also handles 'set' magic.
3646 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3648 sv_usepvn(sv,ptr,len);
3652 #ifdef PERL_OLD_COPY_ON_WRITE
3653 /* Need to do this *after* making the SV normal, as we need the buffer
3654 pointer to remain valid until after we've copied it. If we let go too early,
3655 another thread could invalidate it by unsharing last of the same hash key
3656 (which it can do by means other than releasing copy-on-write Svs)
3657 or by changing the other copy-on-write SVs in the loop. */
3659 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
3661 if (len) { /* this SV was SvIsCOW_normal(sv) */
3662 /* we need to find the SV pointing to us. */
3663 SV * const current = SV_COW_NEXT_SV(after);
3665 if (current == sv) {
3666 /* The SV we point to points back to us (there were only two of us
3668 Hence other SV is no longer copy on write either. */
3670 SvREADONLY_off(after);
3672 /* We need to follow the pointers around the loop. */
3674 while ((next = SV_COW_NEXT_SV(current)) != sv) {
3677 /* don't loop forever if the structure is bust, and we have
3678 a pointer into a closed loop. */
3679 assert (current != after);
3680 assert (SvPVX_const(current) == pvx);
3682 /* Make the SV before us point to the SV after us. */
3683 SV_COW_NEXT_SV_SET(current, after);
3686 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
3691 Perl_sv_release_IVX(pTHX_ register SV *sv)
3694 sv_force_normal_flags(sv, 0);
3700 =for apidoc sv_force_normal_flags
3702 Undo various types of fakery on an SV: if the PV is a shared string, make
3703 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
3704 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
3705 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
3706 then a copy-on-write scalar drops its PV buffer (if any) and becomes
3707 SvPOK_off rather than making a copy. (Used where this scalar is about to be
3708 set to some other value.) In addition, the C<flags> parameter gets passed to
3709 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
3710 with flags set to 0.
3716 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3718 #ifdef PERL_OLD_COPY_ON_WRITE
3719 if (SvREADONLY(sv)) {
3720 /* At this point I believe I should acquire a global SV mutex. */
3722 const char * const pvx = SvPVX_const(sv);
3723 const STRLEN len = SvLEN(sv);
3724 const STRLEN cur = SvCUR(sv);
3725 SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
3727 PerlIO_printf(Perl_debug_log,
3728 "Copy on write: Force normal %ld\n",
3734 /* This SV doesn't own the buffer, so need to Newx() a new one: */
3735 SvPV_set(sv, (char*)0);
3737 if (flags & SV_COW_DROP_PV) {
3738 /* OK, so we don't need to copy our buffer. */
3741 SvGROW(sv, cur + 1);
3742 Move(pvx,SvPVX(sv),cur,char);
3746 sv_release_COW(sv, pvx, len, next);
3751 else if (IN_PERL_RUNTIME)
3752 Perl_croak(aTHX_ PL_no_modify);
3753 /* At this point I believe that I can drop the global SV mutex. */
3756 if (SvREADONLY(sv)) {
3758 const char * const pvx = SvPVX_const(sv);
3759 const STRLEN len = SvCUR(sv);
3762 SvPV_set(sv, Nullch);
3764 SvGROW(sv, len + 1);
3765 Move(pvx,SvPVX(sv),len,char);
3767 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
3769 else if (IN_PERL_RUNTIME)
3770 Perl_croak(aTHX_ PL_no_modify);
3774 sv_unref_flags(sv, flags);
3775 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3782 Efficient removal of characters from the beginning of the string buffer.
3783 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3784 the string buffer. The C<ptr> becomes the first character of the adjusted
3785 string. Uses the "OOK hack".
3786 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
3787 refer to the same chunk of data.
3793 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
3795 register STRLEN delta;
3796 if (!ptr || !SvPOKp(sv))
3798 delta = ptr - SvPVX_const(sv);
3799 SV_CHECK_THINKFIRST(sv);
3800 if (SvTYPE(sv) < SVt_PVIV)
3801 sv_upgrade(sv,SVt_PVIV);
3804 if (!SvLEN(sv)) { /* make copy of shared string */
3805 const char *pvx = SvPVX_const(sv);
3806 const STRLEN len = SvCUR(sv);
3807 SvGROW(sv, len + 1);
3808 Move(pvx,SvPVX(sv),len,char);
3812 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
3813 and we do that anyway inside the SvNIOK_off
3815 SvFLAGS(sv) |= SVf_OOK;
3818 SvLEN_set(sv, SvLEN(sv) - delta);
3819 SvCUR_set(sv, SvCUR(sv) - delta);
3820 SvPV_set(sv, SvPVX(sv) + delta);
3821 SvIV_set(sv, SvIVX(sv) + delta);
3825 =for apidoc sv_catpvn
3827 Concatenates the string onto the end of the string which is in the SV. The
3828 C<len> indicates number of bytes to copy. If the SV has the UTF-8
3829 status set, then the bytes appended should be valid UTF-8.
3830 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
3832 =for apidoc sv_catpvn_flags
3834 Concatenates the string onto the end of the string which is in the SV. The
3835 C<len> indicates number of bytes to copy. If the SV has the UTF-8
3836 status set, then the bytes appended should be valid UTF-8.
3837 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
3838 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
3839 in terms of this function.
3845 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
3848 const char *dstr = SvPV_force_flags(dsv, dlen, flags);
3850 SvGROW(dsv, dlen + slen + 1);
3852 sstr = SvPVX_const(dsv);
3853 Move(sstr, SvPVX(dsv) + dlen, slen, char);
3854 SvCUR_set(dsv, SvCUR(dsv) + slen);
3856 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
3858 if (flags & SV_SMAGIC)
3863 =for apidoc sv_catsv
3865 Concatenates the string from SV C<ssv> onto the end of the string in
3866 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3867 not 'set' magic. See C<sv_catsv_mg>.
3869 =for apidoc sv_catsv_flags
3871 Concatenates the string from SV C<ssv> onto the end of the string in
3872 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
3873 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
3874 and C<sv_catsv_nomg> are implemented in terms of this function.
3879 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
3883 const char *spv = SvPV_const(ssv, slen);
3885 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
3886 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
3887 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
3888 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
3889 dsv->sv_flags doesn't have that bit set.
3890 Andy Dougherty 12 Oct 2001
3892 const I32 sutf8 = DO_UTF8(ssv);
3895 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
3897 dutf8 = DO_UTF8(dsv);
3899 if (dutf8 != sutf8) {
3901 /* Not modifying source SV, so taking a temporary copy. */
3902 SV* const csv = sv_2mortal(newSVpvn(spv, slen));
3904 sv_utf8_upgrade(csv);
3905 spv = SvPV_const(csv, slen);
3908 sv_utf8_upgrade_nomg(dsv);
3910 sv_catpvn_nomg(dsv, spv, slen);
3913 if (flags & SV_SMAGIC)
3918 =for apidoc sv_catpv
3920 Concatenates the string onto the end of the string which is in the SV.
3921 If the SV has the UTF-8 status set, then the bytes appended should be
3922 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3927 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3929 register STRLEN len;
3935 junk = SvPV_force(sv, tlen);
3937 SvGROW(sv, tlen + len + 1);
3939 ptr = SvPVX_const(sv);
3940 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3941 SvCUR_set(sv, SvCUR(sv) + len);
3942 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3947 =for apidoc sv_catpv_mg
3949 Like C<sv_catpv>, but also handles 'set' magic.
3955 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3964 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
3965 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
3972 Perl_newSV(pTHX_ STRLEN len)
3978 sv_upgrade(sv, SVt_PV);
3979 SvGROW(sv, len + 1);
3984 =for apidoc sv_magicext
3986 Adds magic to an SV, upgrading it if necessary. Applies the
3987 supplied vtable and returns a pointer to the magic added.
3989 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
3990 In particular, you can add magic to SvREADONLY SVs, and add more than
3991 one instance of the same 'how'.
3993 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
3994 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
3995 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
3996 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
3998 (This is now used as a subroutine by C<sv_magic>.)
4003 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
4004 const char* name, I32 namlen)
4008 if (SvTYPE(sv) < SVt_PVMG) {
4009 SvUPGRADE(sv, SVt_PVMG);
4011 Newxz(mg, 1, MAGIC);
4012 mg->mg_moremagic = SvMAGIC(sv);
4013 SvMAGIC_set(sv, mg);
4015 /* Sometimes a magic contains a reference loop, where the sv and
4016 object refer to each other. To prevent a reference loop that
4017 would prevent such objects being freed, we look for such loops
4018 and if we find one we avoid incrementing the object refcount.
4020 Note we cannot do this to avoid self-tie loops as intervening RV must
4021 have its REFCNT incremented to keep it in existence.
4024 if (!obj || obj == sv ||
4025 how == PERL_MAGIC_arylen ||
4026 how == PERL_MAGIC_qr ||
4027 how == PERL_MAGIC_symtab ||
4028 (SvTYPE(obj) == SVt_PVGV &&
4029 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4030 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4031 GvFORM(obj) == (CV*)sv)))
4036 mg->mg_obj = SvREFCNT_inc(obj);
4037 mg->mg_flags |= MGf_REFCOUNTED;
4040 /* Normal self-ties simply pass a null object, and instead of
4041 using mg_obj directly, use the SvTIED_obj macro to produce a
4042 new RV as needed. For glob "self-ties", we are tieing the PVIO
4043 with an RV obj pointing to the glob containing the PVIO. In
4044 this case, to avoid a reference loop, we need to weaken the
4048 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4049 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4055 mg->mg_len = namlen;
4058 mg->mg_ptr = savepvn(name, namlen);
4059 else if (namlen == HEf_SVKEY)
4060 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4062 mg->mg_ptr = (char *) name;
4064 mg->mg_virtual = vtable;
4068 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4073 =for apidoc sv_magic
4075 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4076 then adds a new magic item of type C<how> to the head of the magic list.
4078 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4079 handling of the C<name> and C<namlen> arguments.
4081 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4082 to add more than one instance of the same 'how'.
4088 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4090 const MGVTBL *vtable;
4093 #ifdef PERL_OLD_COPY_ON_WRITE
4095 sv_force_normal_flags(sv, 0);
4097 if (SvREADONLY(sv)) {
4099 /* its okay to attach magic to shared strings; the subsequent
4100 * upgrade to PVMG will unshare the string */
4101 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4104 && how != PERL_MAGIC_regex_global
4105 && how != PERL_MAGIC_bm
4106 && how != PERL_MAGIC_fm
4107 && how != PERL_MAGIC_sv
4108 && how != PERL_MAGIC_backref
4111 Perl_croak(aTHX_ PL_no_modify);
4114 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4115 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4116 /* sv_magic() refuses to add a magic of the same 'how' as an
4119 if (how == PERL_MAGIC_taint)
4127 vtable = &PL_vtbl_sv;
4129 case PERL_MAGIC_overload:
4130 vtable = &PL_vtbl_amagic;
4132 case PERL_MAGIC_overload_elem:
4133 vtable = &PL_vtbl_amagicelem;
4135 case PERL_MAGIC_overload_table:
4136 vtable = &PL_vtbl_ovrld;
4139 vtable = &PL_vtbl_bm;
4141 case PERL_MAGIC_regdata:
4142 vtable = &PL_vtbl_regdata;
4144 case PERL_MAGIC_regdatum:
4145 vtable = &PL_vtbl_regdatum;
4147 case PERL_MAGIC_env:
4148 vtable = &PL_vtbl_env;
4151 vtable = &PL_vtbl_fm;
4153 case PERL_MAGIC_envelem:
4154 vtable = &PL_vtbl_envelem;
4156 case PERL_MAGIC_regex_global:
4157 vtable = &PL_vtbl_mglob;
4159 case PERL_MAGIC_isa:
4160 vtable = &PL_vtbl_isa;
4162 case PERL_MAGIC_isaelem:
4163 vtable = &PL_vtbl_isaelem;
4165 case PERL_MAGIC_nkeys:
4166 vtable = &PL_vtbl_nkeys;
4168 case PERL_MAGIC_dbfile:
4171 case PERL_MAGIC_dbline:
4172 vtable = &PL_vtbl_dbline;
4174 #ifdef USE_LOCALE_COLLATE
4175 case PERL_MAGIC_collxfrm:
4176 vtable = &PL_vtbl_collxfrm;
4178 #endif /* USE_LOCALE_COLLATE */
4179 case PERL_MAGIC_tied:
4180 vtable = &PL_vtbl_pack;
4182 case PERL_MAGIC_tiedelem:
4183 case PERL_MAGIC_tiedscalar:
4184 vtable = &PL_vtbl_packelem;
4187 vtable = &PL_vtbl_regexp;
4189 case PERL_MAGIC_sig:
4190 vtable = &PL_vtbl_sig;
4192 case PERL_MAGIC_sigelem:
4193 vtable = &PL_vtbl_sigelem;
4195 case PERL_MAGIC_taint:
4196 vtable = &PL_vtbl_taint;
4198 case PERL_MAGIC_uvar:
4199 vtable = &PL_vtbl_uvar;
4201 case PERL_MAGIC_vec:
4202 vtable = &PL_vtbl_vec;
4204 case PERL_MAGIC_arylen_p:
4205 case PERL_MAGIC_rhash:
4206 case PERL_MAGIC_symtab:
4207 case PERL_MAGIC_vstring:
4210 case PERL_MAGIC_utf8:
4211 vtable = &PL_vtbl_utf8;
4213 case PERL_MAGIC_substr:
4214 vtable = &PL_vtbl_substr;
4216 case PERL_MAGIC_defelem:
4217 vtable = &PL_vtbl_defelem;
4219 case PERL_MAGIC_glob:
4220 vtable = &PL_vtbl_glob;
4222 case PERL_MAGIC_arylen:
4223 vtable = &PL_vtbl_arylen;
4225 case PERL_MAGIC_pos:
4226 vtable = &PL_vtbl_pos;
4228 case PERL_MAGIC_backref:
4229 vtable = &PL_vtbl_backref;
4231 case PERL_MAGIC_ext:
4232 /* Reserved for use by extensions not perl internals. */
4233 /* Useful for attaching extension internal data to perl vars. */
4234 /* Note that multiple extensions may clash if magical scalars */
4235 /* etc holding private data from one are passed to another. */
4239 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4242 /* Rest of work is done else where */
4243 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4246 case PERL_MAGIC_taint:
4249 case PERL_MAGIC_ext:
4250 case PERL_MAGIC_dbfile:
4257 =for apidoc sv_unmagic
4259 Removes all magic of type C<type> from an SV.
4265 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4269 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4272 for (mg = *mgp; mg; mg = *mgp) {
4273 if (mg->mg_type == type) {
4274 const MGVTBL* const vtbl = mg->mg_virtual;
4275 *mgp = mg->mg_moremagic;
4276 if (vtbl && vtbl->svt_free)
4277 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4278 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4280 Safefree(mg->mg_ptr);
4281 else if (mg->mg_len == HEf_SVKEY)
4282 SvREFCNT_dec((SV*)mg->mg_ptr);
4283 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
4284 Safefree(mg->mg_ptr);
4286 if (mg->mg_flags & MGf_REFCOUNTED)
4287 SvREFCNT_dec(mg->mg_obj);
4291 mgp = &mg->mg_moremagic;
4295 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4302 =for apidoc sv_rvweaken
4304 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4305 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4306 push a back-reference to this RV onto the array of backreferences
4307 associated with that magic.
4313 Perl_sv_rvweaken(pTHX_ SV *sv)
4316 if (!SvOK(sv)) /* let undefs pass */
4319 Perl_croak(aTHX_ "Can't weaken a nonreference");
4320 else if (SvWEAKREF(sv)) {
4321 if (ckWARN(WARN_MISC))
4322 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
4326 Perl_sv_add_backref(aTHX_ tsv, sv);
4332 /* Give tsv backref magic if it hasn't already got it, then push a
4333 * back-reference to sv onto the array associated with the backref magic.
4337 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4341 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4342 av = (AV*)mg->mg_obj;
4345 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4346 /* av now has a refcnt of 2, which avoids it getting freed
4347 * before us during global cleanup. The extra ref is removed
4348 * by magic_killbackrefs() when tsv is being freed */
4350 if (AvFILLp(av) >= AvMAX(av)) {
4351 av_extend(av, AvFILLp(av)+1);
4353 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
4356 /* delete a back-reference to ourselves from the backref magic associated
4357 * with the SV we point to.
4361 S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
4367 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) {
4368 if (PL_in_clean_all)
4371 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4372 Perl_croak(aTHX_ "panic: del_backref");
4373 av = (AV *)mg->mg_obj;
4375 /* We shouldn't be in here more than once, but for paranoia reasons lets
4377 for (i = AvFILLp(av); i >= 0; i--) {
4379 const SSize_t fill = AvFILLp(av);
4381 /* We weren't the last entry.
4382 An unordered list has this property that you can take the
4383 last element off the end to fill the hole, and it's still
4384 an unordered list :-)
4389 AvFILLp(av) = fill - 1;
4395 =for apidoc sv_insert
4397 Inserts a string at the specified offset/length within the SV. Similar to
4398 the Perl substr() function.
4404 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
4408 register char *midend;
4409 register char *bigend;
4415 Perl_croak(aTHX_ "Can't modify non-existent substring");
4416 SvPV_force(bigstr, curlen);
4417 (void)SvPOK_only_UTF8(bigstr);
4418 if (offset + len > curlen) {
4419 SvGROW(bigstr, offset+len+1);
4420 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4421 SvCUR_set(bigstr, offset+len);
4425 i = littlelen - len;
4426 if (i > 0) { /* string might grow */
4427 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4428 mid = big + offset + len;
4429 midend = bigend = big + SvCUR(bigstr);
4432 while (midend > mid) /* shove everything down */
4433 *--bigend = *--midend;
4434 Move(little,big+offset,littlelen,char);
4435 SvCUR_set(bigstr, SvCUR(bigstr) + i);
4440 Move(little,SvPVX(bigstr)+offset,len,char);
4445 big = SvPVX(bigstr);
4448 bigend = big + SvCUR(bigstr);
4450 if (midend > bigend)
4451 Perl_croak(aTHX_ "panic: sv_insert");
4453 if (mid - big > bigend - midend) { /* faster to shorten from end */
4455 Move(little, mid, littlelen,char);
4458 i = bigend - midend;
4460 Move(midend, mid, i,char);
4464 SvCUR_set(bigstr, mid - big);
4466 else if ((i = mid - big)) { /* faster from front */
4467 midend -= littlelen;
4469 sv_chop(bigstr,midend-i);
4474 Move(little, mid, littlelen,char);
4476 else if (littlelen) {
4477 midend -= littlelen;
4478 sv_chop(bigstr,midend);
4479 Move(little,midend,littlelen,char);
4482 sv_chop(bigstr,midend);
4488 =for apidoc sv_replace
4490 Make the first argument a copy of the second, then delete the original.
4491 The target SV physically takes over ownership of the body of the source SV
4492 and inherits its flags; however, the target keeps any magic it owns,
4493 and any magic in the source is discarded.
4494 Note that this is a rather specialist SV copying operation; most of the
4495 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
4501 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4503 const U32 refcnt = SvREFCNT(sv);
4504 SV_CHECK_THINKFIRST_COW_DROP(sv);
4505 if (SvREFCNT(nsv) != 1) {
4506 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
4507 UVuf " != 1)", (UV) SvREFCNT(nsv));
4509 if (SvMAGICAL(sv)) {
4513 sv_upgrade(nsv, SVt_PVMG);
4514 SvMAGIC_set(nsv, SvMAGIC(sv));
4515 SvFLAGS(nsv) |= SvMAGICAL(sv);
4517 SvMAGIC_set(sv, NULL);
4521 assert(!SvREFCNT(sv));
4522 #ifdef DEBUG_LEAKING_SCALARS
4523 sv->sv_flags = nsv->sv_flags;
4524 sv->sv_any = nsv->sv_any;
4525 sv->sv_refcnt = nsv->sv_refcnt;
4526 sv->sv_u = nsv->sv_u;
4528 StructCopy(nsv,sv,SV);
4530 /* Currently could join these into one piece of pointer arithmetic, but
4531 it would be unclear. */
4532 if(SvTYPE(sv) == SVt_IV)
4534 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
4535 else if (SvTYPE(sv) == SVt_RV) {
4536 SvANY(sv) = &sv->sv_u.svu_rv;
4540 #ifdef PERL_OLD_COPY_ON_WRITE
4541 if (SvIsCOW_normal(nsv)) {
4542 /* We need to follow the pointers around the loop to make the
4543 previous SV point to sv, rather than nsv. */
4546 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
4549 assert(SvPVX_const(current) == SvPVX_const(nsv));
4551 /* Make the SV before us point to the SV after us. */
4553 PerlIO_printf(Perl_debug_log, "previous is\n");
4555 PerlIO_printf(Perl_debug_log,
4556 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
4557 (UV) SV_COW_NEXT_SV(current), (UV) sv);
4559 SV_COW_NEXT_SV_SET(current, sv);
4562 SvREFCNT(sv) = refcnt;
4563 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4569 =for apidoc sv_clear
4571 Clear an SV: call any destructors, free up any memory used by the body,
4572 and free the body itself. The SV's head is I<not> freed, although
4573 its type is set to all 1's so that it won't inadvertently be assumed
4574 to be live during global destruction etc.
4575 This function should only be called when REFCNT is zero. Most of the time
4576 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
4583 Perl_sv_clear(pTHX_ register SV *sv)
4586 const U32 type = SvTYPE(sv);
4587 const struct body_details *const sv_type_details
4588 = bodies_by_type + type;
4591 assert(SvREFCNT(sv) == 0);
4597 if (PL_defstash) { /* Still have a symbol table? */
4602 stash = SvSTASH(sv);
4603 destructor = StashHANDLER(stash,DESTROY);
4605 SV* const tmpref = newRV(sv);
4606 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
4608 PUSHSTACKi(PERLSI_DESTROY);
4613 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
4619 if(SvREFCNT(tmpref) < 2) {
4620 /* tmpref is not kept alive! */
4622 SvRV_set(tmpref, NULL);
4625 SvREFCNT_dec(tmpref);
4627 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4631 if (PL_in_clean_objs)
4632 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4634 /* DESTROY gave object new lease on life */
4640 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4641 SvOBJECT_off(sv); /* Curse the object. */
4642 if (type != SVt_PVIO)
4643 --PL_sv_objcount; /* XXX Might want something more general */
4646 if (type >= SVt_PVMG) {
4649 if (type == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
4650 SvREFCNT_dec(SvSTASH(sv));
4655 IoIFP(sv) != PerlIO_stdin() &&
4656 IoIFP(sv) != PerlIO_stdout() &&
4657 IoIFP(sv) != PerlIO_stderr())
4659 io_close((IO*)sv, FALSE);
4661 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4662 PerlDir_close(IoDIRP(sv));
4663 IoDIRP(sv) = (DIR*)NULL;
4664 Safefree(IoTOP_NAME(sv));
4665 Safefree(IoFMT_NAME(sv));
4666 Safefree(IoBOTTOM_NAME(sv));
4681 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
4682 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
4683 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
4684 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
4686 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
4687 SvREFCNT_dec(LvTARG(sv));
4691 Safefree(GvNAME(sv));
4692 /* If we're in a stash, we don't own a reference to it. However it does
4693 have a back reference to us, which needs to be cleared. */
4695 sv_del_backref((SV*)GvSTASH(sv), sv);
4700 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
4702 SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
4703 /* Don't even bother with turning off the OOK flag. */
4708 SV *target = SvRV(sv);
4710 sv_del_backref(target, sv);
4712 SvREFCNT_dec(target);
4714 #ifdef PERL_OLD_COPY_ON_WRITE
4715 else if (SvPVX_const(sv)) {
4717 /* I believe I need to grab the global SV mutex here and
4718 then recheck the COW status. */
4720 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
4723 sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv),
4724 SV_COW_NEXT_SV(sv));
4725 /* And drop it here. */
4727 } else if (SvLEN(sv)) {
4728 Safefree(SvPVX_const(sv));
4732 else if (SvPVX_const(sv) && SvLEN(sv))
4733 Safefree(SvPVX_mutable(sv));
4734 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4735 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
4744 SvFLAGS(sv) &= SVf_BREAK;
4745 SvFLAGS(sv) |= SVTYPEMASK;
4747 if (sv_type_details->arena) {
4748 del_body(((char *)SvANY(sv) + sv_type_details->offset),
4749 &PL_body_roots[type]);
4751 else if (sv_type_details->size) {
4752 my_safefree(SvANY(sv));
4757 =for apidoc sv_newref
4759 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
4766 Perl_sv_newref(pTHX_ SV *sv)
4776 Decrement an SV's reference count, and if it drops to zero, call
4777 C<sv_clear> to invoke destructors and free up any memory used by
4778 the body; finally, deallocate the SV's head itself.
4779 Normally called via a wrapper macro C<SvREFCNT_dec>.
4785 Perl_sv_free(pTHX_ SV *sv)
4790 if (SvREFCNT(sv) == 0) {
4791 if (SvFLAGS(sv) & SVf_BREAK)
4792 /* this SV's refcnt has been artificially decremented to
4793 * trigger cleanup */
4795 if (PL_in_clean_all) /* All is fair */
4797 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4798 /* make sure SvREFCNT(sv)==0 happens very seldom */
4799 SvREFCNT(sv) = (~(U32)0)/2;
4802 if (ckWARN_d(WARN_INTERNAL)) {
4803 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
4804 "Attempt to free unreferenced scalar: SV 0x%"UVxf
4805 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
4806 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
4807 Perl_dump_sv_child(aTHX_ sv);
4812 if (--(SvREFCNT(sv)) > 0)
4814 Perl_sv_free2(aTHX_ sv);
4818 Perl_sv_free2(pTHX_ SV *sv)
4823 if (ckWARN_d(WARN_DEBUGGING))
4824 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
4825 "Attempt to free temp prematurely: SV 0x%"UVxf
4826 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
4830 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4831 /* make sure SvREFCNT(sv)==0 happens very seldom */
4832 SvREFCNT(sv) = (~(U32)0)/2;
4843 Returns the length of the string in the SV. Handles magic and type
4844 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
4850 Perl_sv_len(pTHX_ register SV *sv)
4858 len = mg_length(sv);
4860 (void)SvPV_const(sv, len);
4865 =for apidoc sv_len_utf8
4867 Returns the number of characters in the string in an SV, counting wide
4868 UTF-8 bytes as a single character. Handles magic and type coercion.
4874 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
4875 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
4876 * (Note that the mg_len is not the length of the mg_ptr field.)
4881 Perl_sv_len_utf8(pTHX_ register SV *sv)
4887 return mg_length(sv);
4891 const U8 *s = (U8*)SvPV_const(sv, len);
4892 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
4894 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
4896 #ifdef PERL_UTF8_CACHE_ASSERT
4897 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
4901 ulen = Perl_utf8_length(aTHX_ s, s + len);
4902 if (!mg && !SvREADONLY(sv)) {
4903 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
4904 mg = mg_find(sv, PERL_MAGIC_utf8);
4914 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
4915 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
4916 * between UTF-8 and byte offsets. There are two (substr offset and substr
4917 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
4918 * and byte offset) cache positions.
4920 * The mg_len field is used by sv_len_utf8(), see its comments.
4921 * Note that the mg_len is not the length of the mg_ptr field.
4925 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i,
4926 I32 offsetp, const U8 *s, const U8 *start)
4930 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
4932 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
4936 *cachep = (STRLEN *) (*mgp)->mg_ptr;
4938 Newxz(*cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
4939 (*mgp)->mg_ptr = (char *) *cachep;
4943 (*cachep)[i] = offsetp;
4944 (*cachep)[i+1] = s - start;
4952 * S_utf8_mg_pos() is used to query and update mg_ptr field of
4953 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
4954 * between UTF-8 and byte offsets. See also the comments of
4955 * S_utf8_mg_pos_init().
4959 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)
4963 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
4965 *mgp = mg_find(sv, PERL_MAGIC_utf8);
4966 if (*mgp && (*mgp)->mg_ptr) {
4967 *cachep = (STRLEN *) (*mgp)->mg_ptr;
4968 ASSERT_UTF8_CACHE(*cachep);
4969 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
4971 else { /* We will skip to the right spot. */
4976 /* The assumption is that going backward is half
4977 * the speed of going forward (that's where the
4978 * 2 * backw in the below comes from). (The real
4979 * figure of course depends on the UTF-8 data.) */
4981 if ((*cachep)[i] > (STRLEN)uoff) {
4983 backw = (*cachep)[i] - (STRLEN)uoff;
4985 if (forw < 2 * backw)
4988 p = start + (*cachep)[i+1];
4990 /* Try this only for the substr offset (i == 0),
4991 * not for the substr length (i == 2). */
4992 else if (i == 0) { /* (*cachep)[i] < uoff */
4993 const STRLEN ulen = sv_len_utf8(sv);
4995 if ((STRLEN)uoff < ulen) {
4996 forw = (STRLEN)uoff - (*cachep)[i];
4997 backw = ulen - (STRLEN)uoff;
4999 if (forw < 2 * backw)
5000 p = start + (*cachep)[i+1];
5005 /* If the string is not long enough for uoff,
5006 * we could extend it, but not at this low a level. */
5010 if (forw < 2 * backw) {
5017 while (UTF8_IS_CONTINUATION(*p))
5022 /* Update the cache. */
5023 (*cachep)[i] = (STRLEN)uoff;
5024 (*cachep)[i+1] = p - start;
5026 /* Drop the stale "length" cache */
5035 if (found) { /* Setup the return values. */
5036 *offsetp = (*cachep)[i+1];
5037 *sp = start + *offsetp;
5040 *offsetp = send - start;
5042 else if (*sp < start) {
5048 #ifdef PERL_UTF8_CACHE_ASSERT
5053 while (n-- && s < send)
5057 assert(*offsetp == s - start);
5058 assert((*cachep)[0] == (STRLEN)uoff);
5059 assert((*cachep)[1] == *offsetp);
5061 ASSERT_UTF8_CACHE(*cachep);
5070 =for apidoc sv_pos_u2b
5072 Converts the value pointed to by offsetp from a count of UTF-8 chars from
5073 the start of the string, to a count of the equivalent number of bytes; if
5074 lenp is non-zero, it does the same to lenp, but this time starting from
5075 the offset, rather than from the start of the string. Handles magic and
5082 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
5083 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5084 * byte offsets. See also the comments of S_utf8_mg_pos().
5089 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5097 start = (U8*)SvPV_const(sv, len);
5101 const U8 *s = start;
5102 I32 uoffset = *offsetp;
5103 const U8 * const send = s + len;
5107 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
5109 if (!found && uoffset > 0) {
5110 while (s < send && uoffset--)
5114 if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
5116 *offsetp = s - start;
5121 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
5125 if (!found && *lenp > 0) {
5128 while (s < send && ulen--)
5132 utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
5136 ASSERT_UTF8_CACHE(cache);
5148 =for apidoc sv_pos_b2u
5150 Converts the value pointed to by offsetp from a count of bytes from the
5151 start of the string, to a count of the equivalent number of UTF-8 chars.
5152 Handles magic and type coercion.
5158 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
5159 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5160 * byte offsets. See also the comments of S_utf8_mg_pos().
5165 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
5173 s = (const U8*)SvPV_const(sv, len);
5174 if ((I32)len < *offsetp)
5175 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5177 const U8* send = s + *offsetp;
5179 STRLEN *cache = NULL;
5183 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5184 mg = mg_find(sv, PERL_MAGIC_utf8);
5185 if (mg && mg->mg_ptr) {
5186 cache = (STRLEN *) mg->mg_ptr;
5187 if (cache[1] == (STRLEN)*offsetp) {
5188 /* An exact match. */
5189 *offsetp = cache[0];
5193 else if (cache[1] < (STRLEN)*offsetp) {
5194 /* We already know part of the way. */
5197 /* Let the below loop do the rest. */
5199 else { /* cache[1] > *offsetp */
5200 /* We already know all of the way, now we may
5201 * be able to walk back. The same assumption
5202 * is made as in S_utf8_mg_pos(), namely that
5203 * walking backward is twice slower than
5204 * walking forward. */
5205 const STRLEN forw = *offsetp;
5206 STRLEN backw = cache[1] - *offsetp;
5208 if (!(forw < 2 * backw)) {
5209 const U8 *p = s + cache[1];
5216 while (UTF8_IS_CONTINUATION(*p)) {
5224 *offsetp = cache[0];
5226 /* Drop the stale "length" cache */
5234 ASSERT_UTF8_CACHE(cache);
5240 /* Call utf8n_to_uvchr() to validate the sequence
5241 * (unless a simple non-UTF character) */
5242 if (!UTF8_IS_INVARIANT(*s))
5243 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5252 if (!SvREADONLY(sv)) {
5254 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5255 mg = mg_find(sv, PERL_MAGIC_utf8);
5260 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5261 mg->mg_ptr = (char *) cache;
5266 cache[1] = *offsetp;
5267 /* Drop the stale "length" cache */
5280 Returns a boolean indicating whether the strings in the two SVs are
5281 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5282 coerce its args to strings if necessary.
5288 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5296 SV* svrecode = Nullsv;
5303 pv1 = SvPV_const(sv1, cur1);
5310 pv2 = SvPV_const(sv2, cur2);
5312 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5313 /* Differing utf8ness.
5314 * Do not UTF8size the comparands as a side-effect. */
5317 svrecode = newSVpvn(pv2, cur2);
5318 sv_recode_to_utf8(svrecode, PL_encoding);
5319 pv2 = SvPV_const(svrecode, cur2);
5322 svrecode = newSVpvn(pv1, cur1);
5323 sv_recode_to_utf8(svrecode, PL_encoding);
5324 pv1 = SvPV_const(svrecode, cur1);
5326 /* Now both are in UTF-8. */
5328 SvREFCNT_dec(svrecode);
5333 bool is_utf8 = TRUE;
5336 /* sv1 is the UTF-8 one,
5337 * if is equal it must be downgrade-able */
5338 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
5344 /* sv2 is the UTF-8 one,
5345 * if is equal it must be downgrade-able */
5346 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
5352 /* Downgrade not possible - cannot be eq */
5360 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
5363 SvREFCNT_dec(svrecode);
5374 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
5375 string in C<sv1> is less than, equal to, or greater than the string in
5376 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5377 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
5383 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5386 const char *pv1, *pv2;
5389 SV *svrecode = Nullsv;
5396 pv1 = SvPV_const(sv1, cur1);
5403 pv2 = SvPV_const(sv2, cur2);
5405 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5406 /* Differing utf8ness.
5407 * Do not UTF8size the comparands as a side-effect. */
5410 svrecode = newSVpvn(pv2, cur2);
5411 sv_recode_to_utf8(svrecode, PL_encoding);
5412 pv2 = SvPV_const(svrecode, cur2);
5415 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
5420 svrecode = newSVpvn(pv1, cur1);
5421 sv_recode_to_utf8(svrecode, PL_encoding);
5422 pv1 = SvPV_const(svrecode, cur1);
5425 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
5431 cmp = cur2 ? -1 : 0;
5435 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
5438 cmp = retval < 0 ? -1 : 1;
5439 } else if (cur1 == cur2) {
5442 cmp = cur1 < cur2 ? -1 : 1;
5447 SvREFCNT_dec(svrecode);
5456 =for apidoc sv_cmp_locale
5458 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5459 'use bytes' aware, handles get magic, and will coerce its args to strings
5460 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
5466 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5468 #ifdef USE_LOCALE_COLLATE
5474 if (PL_collation_standard)
5478 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5480 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5482 if (!pv1 || !len1) {
5493 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5496 return retval < 0 ? -1 : 1;
5499 * When the result of collation is equality, that doesn't mean
5500 * that there are no differences -- some locales exclude some
5501 * characters from consideration. So to avoid false equalities,
5502 * we use the raw string as a tiebreaker.
5508 #endif /* USE_LOCALE_COLLATE */
5510 return sv_cmp(sv1, sv2);
5514 #ifdef USE_LOCALE_COLLATE
5517 =for apidoc sv_collxfrm
5519 Add Collate Transform magic to an SV if it doesn't already have it.
5521 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5522 scalar data of the variable, but transformed to such a format that a normal
5523 memory comparison can be used to compare the data according to the locale
5530 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5534 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5535 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5541 Safefree(mg->mg_ptr);
5542 s = SvPV_const(sv, len);
5543 if ((xf = mem_collxfrm(s, len, &xlen))) {
5544 if (SvREADONLY(sv)) {
5547 return xf + sizeof(PL_collation_ix);
5550 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5551 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5564 if (mg && mg->mg_ptr) {
5566 return mg->mg_ptr + sizeof(PL_collation_ix);
5574 #endif /* USE_LOCALE_COLLATE */
5579 Get a line from the filehandle and store it into the SV, optionally
5580 appending to the currently-stored string.
5586 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5590 register STDCHAR rslast;
5591 register STDCHAR *bp;
5597 if (SvTHINKFIRST(sv))
5598 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
5599 /* XXX. If you make this PVIV, then copy on write can copy scalars read
5601 However, perlbench says it's slower, because the existing swipe code
5602 is faster than copy on write.
5603 Swings and roundabouts. */
5604 SvUPGRADE(sv, SVt_PV);
5609 if (PerlIO_isutf8(fp)) {
5611 sv_utf8_upgrade_nomg(sv);
5612 sv_pos_u2b(sv,&append,0);
5614 } else if (SvUTF8(sv)) {
5615 SV * const tsv = NEWSV(0,0);
5616 sv_gets(tsv, fp, 0);
5617 sv_utf8_upgrade_nomg(tsv);
5618 SvCUR_set(sv,append);
5621 goto return_string_or_null;
5626 if (PerlIO_isutf8(fp))
5629 if (IN_PERL_COMPILETIME) {
5630 /* we always read code in line mode */
5634 else if (RsSNARF(PL_rs)) {
5635 /* If it is a regular disk file use size from stat() as estimate
5636 of amount we are going to read - may result in malloc-ing
5637 more memory than we realy need if layers bellow reduce
5638 size we read (e.g. CRLF or a gzip layer)
5641 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
5642 const Off_t offset = PerlIO_tell(fp);
5643 if (offset != (Off_t) -1 && st.st_size + append > offset) {
5644 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
5650 else if (RsRECORD(PL_rs)) {
5654 /* Grab the size of the record we're getting */
5655 recsize = SvIV(SvRV(PL_rs));
5656 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
5659 /* VMS wants read instead of fread, because fread doesn't respect */
5660 /* RMS record boundaries. This is not necessarily a good thing to be */
5661 /* doing, but we've got no other real choice - except avoid stdio
5662 as implementation - perhaps write a :vms layer ?
5664 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5666 bytesread = PerlIO_read(fp, buffer, recsize);
5670 SvCUR_set(sv, bytesread += append);
5671 buffer[bytesread] = '\0';
5672 goto return_string_or_null;
5674 else if (RsPARA(PL_rs)) {
5680 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5681 if (PerlIO_isutf8(fp)) {
5682 rsptr = SvPVutf8(PL_rs, rslen);
5685 if (SvUTF8(PL_rs)) {
5686 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5687 Perl_croak(aTHX_ "Wide character in $/");
5690 rsptr = SvPV_const(PL_rs, rslen);
5694 rslast = rslen ? rsptr[rslen - 1] : '\0';
5696 if (rspara) { /* have to do this both before and after */
5697 do { /* to make sure file boundaries work right */
5700 i = PerlIO_getc(fp);
5704 PerlIO_ungetc(fp,i);
5710 /* See if we know enough about I/O mechanism to cheat it ! */
5712 /* This used to be #ifdef test - it is made run-time test for ease
5713 of abstracting out stdio interface. One call should be cheap
5714 enough here - and may even be a macro allowing compile
5718 if (PerlIO_fast_gets(fp)) {
5721 * We're going to steal some values from the stdio struct
5722 * and put EVERYTHING in the innermost loop into registers.
5724 register STDCHAR *ptr;
5728 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5729 /* An ungetc()d char is handled separately from the regular
5730 * buffer, so we getc() it back out and stuff it in the buffer.
5732 i = PerlIO_getc(fp);
5733 if (i == EOF) return 0;
5734 *(--((*fp)->_ptr)) = (unsigned char) i;
5738 /* Here is some breathtakingly efficient cheating */
5740 cnt = PerlIO_get_cnt(fp); /* get count into register */
5741 /* make sure we have the room */
5742 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
5743 /* Not room for all of it
5744 if we are looking for a separator and room for some
5746 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
5747 /* just process what we have room for */
5748 shortbuffered = cnt - SvLEN(sv) + append + 1;
5749 cnt -= shortbuffered;
5753 /* remember that cnt can be negative */
5754 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
5759 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
5760 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5761 DEBUG_P(PerlIO_printf(Perl_debug_log,
5762 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5763 DEBUG_P(PerlIO_printf(Perl_debug_log,
5764 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5765 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5766 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5771 while (cnt > 0) { /* this | eat */
5773 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5774 goto thats_all_folks; /* screams | sed :-) */
5778 Copy(ptr, bp, cnt, char); /* this | eat */
5779 bp += cnt; /* screams | dust */
5780 ptr += cnt; /* louder | sed :-) */
5785 if (shortbuffered) { /* oh well, must extend */
5786 cnt = shortbuffered;
5788 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
5790 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5791 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
5795 DEBUG_P(PerlIO_printf(Perl_debug_log,
5796 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5797 PTR2UV(ptr),(long)cnt));
5798 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
5800 DEBUG_P(PerlIO_printf(Perl_debug_log,
5801 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5802 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5803 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5805 /* This used to call 'filbuf' in stdio form, but as that behaves like
5806 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5807 another abstraction. */
5808 i = PerlIO_getc(fp); /* get more characters */
5810 DEBUG_P(PerlIO_printf(Perl_debug_log,
5811 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5812 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5813 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5815 cnt = PerlIO_get_cnt(fp);
5816 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5817 DEBUG_P(PerlIO_printf(Perl_debug_log,
5818 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5820 if (i == EOF) /* all done for ever? */
5821 goto thats_really_all_folks;
5823 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
5825 SvGROW(sv, bpx + cnt + 2);
5826 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
5828 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
5830 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5831 goto thats_all_folks;
5835 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
5836 memNE((char*)bp - rslen, rsptr, rslen))
5837 goto screamer; /* go back to the fray */
5838 thats_really_all_folks:
5840 cnt += shortbuffered;
5841 DEBUG_P(PerlIO_printf(Perl_debug_log,
5842 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5843 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
5844 DEBUG_P(PerlIO_printf(Perl_debug_log,
5845 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5846 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5847 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5849 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
5850 DEBUG_P(PerlIO_printf(Perl_debug_log,
5851 "Screamer: done, len=%ld, string=|%.*s|\n",
5852 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
5856 /*The big, slow, and stupid way. */
5857 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
5859 Newx(buf, 8192, STDCHAR);
5867 register const STDCHAR * const bpe = buf + sizeof(buf);
5869 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
5870 ; /* keep reading */
5874 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5875 /* Accomodate broken VAXC compiler, which applies U8 cast to
5876 * both args of ?: operator, causing EOF to change into 255
5879 i = (U8)buf[cnt - 1];
5885 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
5887 sv_catpvn(sv, (char *) buf, cnt);
5889 sv_setpvn(sv, (char *) buf, cnt);
5891 if (i != EOF && /* joy */
5893 SvCUR(sv) < rslen ||
5894 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5898 * If we're reading from a TTY and we get a short read,
5899 * indicating that the user hit his EOF character, we need
5900 * to notice it now, because if we try to read from the TTY
5901 * again, the EOF condition will disappear.
5903 * The comparison of cnt to sizeof(buf) is an optimization
5904 * that prevents unnecessary calls to feof().
5908 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5912 #ifdef USE_HEAP_INSTEAD_OF_STACK
5917 if (rspara) { /* have to do this both before and after */
5918 while (i != EOF) { /* to make sure file boundaries work right */
5919 i = PerlIO_getc(fp);
5921 PerlIO_ungetc(fp,i);
5927 return_string_or_null:
5928 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5934 Auto-increment of the value in the SV, doing string to numeric conversion
5935 if necessary. Handles 'get' magic.
5941 Perl_sv_inc(pTHX_ register SV *sv)
5949 if (SvTHINKFIRST(sv)) {
5951 sv_force_normal_flags(sv, 0);
5952 if (SvREADONLY(sv)) {
5953 if (IN_PERL_RUNTIME)
5954 Perl_croak(aTHX_ PL_no_modify);
5958 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5960 i = PTR2IV(SvRV(sv));
5965 flags = SvFLAGS(sv);
5966 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5967 /* It's (privately or publicly) a float, but not tested as an
5968 integer, so test it to see. */
5970 flags = SvFLAGS(sv);
5972 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5973 /* It's publicly an integer, or privately an integer-not-float */
5974 #ifdef PERL_PRESERVE_IVUV
5978 if (SvUVX(sv) == UV_MAX)
5979 sv_setnv(sv, UV_MAX_P1);
5981 (void)SvIOK_only_UV(sv);
5982 SvUV_set(sv, SvUVX(sv) + 1);
5984 if (SvIVX(sv) == IV_MAX)
5985 sv_setuv(sv, (UV)IV_MAX + 1);
5987 (void)SvIOK_only(sv);
5988 SvIV_set(sv, SvIVX(sv) + 1);
5993 if (flags & SVp_NOK) {
5994 (void)SvNOK_only(sv);
5995 SvNV_set(sv, SvNVX(sv) + 1.0);
5999 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
6000 if ((flags & SVTYPEMASK) < SVt_PVIV)
6001 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
6002 (void)SvIOK_only(sv);
6007 while (isALPHA(*d)) d++;
6008 while (isDIGIT(*d)) d++;
6010 #ifdef PERL_PRESERVE_IVUV
6011 /* Got to punt this as an integer if needs be, but we don't issue
6012 warnings. Probably ought to make the sv_iv_please() that does
6013 the conversion if possible, and silently. */
6014 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6015 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6016 /* Need to try really hard to see if it's an integer.
6017 9.22337203685478e+18 is an integer.
6018 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6019 so $a="9.22337203685478e+18"; $a+0; $a++
6020 needs to be the same as $a="9.22337203685478e+18"; $a++
6027 /* sv_2iv *should* have made this an NV */
6028 if (flags & SVp_NOK) {
6029 (void)SvNOK_only(sv);
6030 SvNV_set(sv, SvNVX(sv) + 1.0);
6033 /* I don't think we can get here. Maybe I should assert this
6034 And if we do get here I suspect that sv_setnv will croak. NWC
6036 #if defined(USE_LONG_DOUBLE)
6037 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",
6038 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6040 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6041 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6044 #endif /* PERL_PRESERVE_IVUV */
6045 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
6049 while (d >= SvPVX_const(sv)) {
6057 /* MKS: The original code here died if letters weren't consecutive.
6058 * at least it didn't have to worry about non-C locales. The
6059 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6060 * arranged in order (although not consecutively) and that only
6061 * [A-Za-z] are accepted by isALPHA in the C locale.
6063 if (*d != 'z' && *d != 'Z') {
6064 do { ++*d; } while (!isALPHA(*d));
6067 *(d--) -= 'z' - 'a';
6072 *(d--) -= 'z' - 'a' + 1;
6076 /* oh,oh, the number grew */
6077 SvGROW(sv, SvCUR(sv) + 2);
6078 SvCUR_set(sv, SvCUR(sv) + 1);
6079 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
6090 Auto-decrement of the value in the SV, doing string to numeric conversion
6091 if necessary. Handles 'get' magic.
6097 Perl_sv_dec(pTHX_ register SV *sv)
6104 if (SvTHINKFIRST(sv)) {
6106 sv_force_normal_flags(sv, 0);
6107 if (SvREADONLY(sv)) {
6108 if (IN_PERL_RUNTIME)
6109 Perl_croak(aTHX_ PL_no_modify);
6113 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6115 i = PTR2IV(SvRV(sv));
6120 /* Unlike sv_inc we don't have to worry about string-never-numbers
6121 and keeping them magic. But we mustn't warn on punting */
6122 flags = SvFLAGS(sv);
6123 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6124 /* It's publicly an integer, or privately an integer-not-float */
6125 #ifdef PERL_PRESERVE_IVUV
6129 if (SvUVX(sv) == 0) {
6130 (void)SvIOK_only(sv);
6134 (void)SvIOK_only_UV(sv);
6135 SvUV_set(sv, SvUVX(sv) - 1);
6138 if (SvIVX(sv) == IV_MIN)
6139 sv_setnv(sv, (NV)IV_MIN - 1.0);
6141 (void)SvIOK_only(sv);
6142 SvIV_set(sv, SvIVX(sv) - 1);
6147 if (flags & SVp_NOK) {
6148 SvNV_set(sv, SvNVX(sv) - 1.0);
6149 (void)SvNOK_only(sv);
6152 if (!(flags & SVp_POK)) {
6153 if ((flags & SVTYPEMASK) < SVt_PVIV)
6154 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
6156 (void)SvIOK_only(sv);
6159 #ifdef PERL_PRESERVE_IVUV
6161 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6162 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6163 /* Need to try really hard to see if it's an integer.
6164 9.22337203685478e+18 is an integer.
6165 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6166 so $a="9.22337203685478e+18"; $a+0; $a--
6167 needs to be the same as $a="9.22337203685478e+18"; $a--
6174 /* sv_2iv *should* have made this an NV */
6175 if (flags & SVp_NOK) {
6176 (void)SvNOK_only(sv);
6177 SvNV_set(sv, SvNVX(sv) - 1.0);
6180 /* I don't think we can get here. Maybe I should assert this
6181 And if we do get here I suspect that sv_setnv will croak. NWC
6183 #if defined(USE_LONG_DOUBLE)
6184 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",
6185 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6187 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6188 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6192 #endif /* PERL_PRESERVE_IVUV */
6193 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
6197 =for apidoc sv_mortalcopy
6199 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6200 The new SV is marked as mortal. It will be destroyed "soon", either by an
6201 explicit call to FREETMPS, or by an implicit call at places such as
6202 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
6207 /* Make a string that will exist for the duration of the expression
6208 * evaluation. Actually, it may have to last longer than that, but
6209 * hopefully we won't free it until it has been assigned to a
6210 * permanent location. */
6213 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6218 sv_setsv(sv,oldstr);
6220 PL_tmps_stack[++PL_tmps_ix] = sv;
6226 =for apidoc sv_newmortal
6228 Creates a new null SV which is mortal. The reference count of the SV is
6229 set to 1. It will be destroyed "soon", either by an explicit call to
6230 FREETMPS, or by an implicit call at places such as statement boundaries.
6231 See also C<sv_mortalcopy> and C<sv_2mortal>.
6237 Perl_sv_newmortal(pTHX)
6242 SvFLAGS(sv) = SVs_TEMP;
6244 PL_tmps_stack[++PL_tmps_ix] = sv;
6249 =for apidoc sv_2mortal
6251 Marks an existing SV as mortal. The SV will be destroyed "soon", either
6252 by an explicit call to FREETMPS, or by an implicit call at places such as
6253 statement boundaries. SvTEMP() is turned on which means that the SV's
6254 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
6255 and C<sv_mortalcopy>.
6261 Perl_sv_2mortal(pTHX_ register SV *sv)
6266 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6269 PL_tmps_stack[++PL_tmps_ix] = sv;
6277 Creates a new SV and copies a string into it. The reference count for the
6278 SV is set to 1. If C<len> is zero, Perl will compute the length using
6279 strlen(). For efficiency, consider using C<newSVpvn> instead.
6285 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6290 sv_setpvn(sv,s,len ? len : strlen(s));
6295 =for apidoc newSVpvn
6297 Creates a new SV and copies a string into it. The reference count for the
6298 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
6299 string. You are responsible for ensuring that the source string is at least
6300 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
6306 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6311 sv_setpvn(sv,s,len);
6317 =for apidoc newSVhek
6319 Creates a new SV from the hash key structure. It will generate scalars that
6320 point to the shared string table where possible. Returns a new (undefined)
6321 SV if the hek is NULL.
6327 Perl_newSVhek(pTHX_ const HEK *hek)
6336 if (HEK_LEN(hek) == HEf_SVKEY) {
6337 return newSVsv(*(SV**)HEK_KEY(hek));
6339 const int flags = HEK_FLAGS(hek);
6340 if (flags & HVhek_WASUTF8) {
6342 Andreas would like keys he put in as utf8 to come back as utf8
6344 STRLEN utf8_len = HEK_LEN(hek);
6345 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
6346 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
6349 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
6351 } else if (flags & HVhek_REHASH) {
6352 /* We don't have a pointer to the hv, so we have to replicate the
6353 flag into every HEK. This hv is using custom a hasing
6354 algorithm. Hence we can't return a shared string scalar, as
6355 that would contain the (wrong) hash value, and might get passed
6356 into an hv routine with a regular hash */
6358 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
6363 /* This will be overwhelminly the most common case. */
6364 return newSVpvn_share(HEK_KEY(hek),
6365 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
6371 =for apidoc newSVpvn_share
6373 Creates a new SV with its SvPVX_const pointing to a shared string in the string
6374 table. If the string does not already exist in the table, it is created
6375 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
6376 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6377 otherwise the hash is computed. The idea here is that as the string table
6378 is used for shared hash keys these strings will have SvPVX_const == HeKEY and
6379 hash lookup will avoid string compare.
6385 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6388 bool is_utf8 = FALSE;
6390 STRLEN tmplen = -len;
6392 /* See the note in hv.c:hv_fetch() --jhi */
6393 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
6397 PERL_HASH(hash, src, len);
6399 sv_upgrade(sv, SVt_PV);
6400 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
6412 #if defined(PERL_IMPLICIT_CONTEXT)
6414 /* pTHX_ magic can't cope with varargs, so this is a no-context
6415 * version of the main function, (which may itself be aliased to us).
6416 * Don't access this version directly.
6420 Perl_newSVpvf_nocontext(const char* pat, ...)
6425 va_start(args, pat);
6426 sv = vnewSVpvf(pat, &args);
6433 =for apidoc newSVpvf
6435 Creates a new SV and initializes it with the string formatted like
6442 Perl_newSVpvf(pTHX_ const char* pat, ...)
6446 va_start(args, pat);
6447 sv = vnewSVpvf(pat, &args);
6452 /* backend for newSVpvf() and newSVpvf_nocontext() */
6455 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6459 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6466 Creates a new SV and copies a floating point value into it.
6467 The reference count for the SV is set to 1.
6473 Perl_newSVnv(pTHX_ NV n)
6485 Creates a new SV and copies an integer into it. The reference count for the
6492 Perl_newSViv(pTHX_ IV i)
6504 Creates a new SV and copies an unsigned integer into it.
6505 The reference count for the SV is set to 1.
6511 Perl_newSVuv(pTHX_ UV u)
6521 =for apidoc newRV_noinc
6523 Creates an RV wrapper for an SV. The reference count for the original
6524 SV is B<not> incremented.
6530 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6535 sv_upgrade(sv, SVt_RV);
6537 SvRV_set(sv, tmpRef);
6542 /* newRV_inc is the official function name to use now.
6543 * newRV_inc is in fact #defined to newRV in sv.h
6547 Perl_newRV(pTHX_ SV *tmpRef)
6549 return newRV_noinc(SvREFCNT_inc(tmpRef));
6555 Creates a new SV which is an exact duplicate of the original SV.
6562 Perl_newSVsv(pTHX_ register SV *old)
6568 if (SvTYPE(old) == SVTYPEMASK) {
6569 if (ckWARN_d(WARN_INTERNAL))
6570 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
6574 /* SV_GMAGIC is the default for sv_setv()
6575 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
6576 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
6577 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
6582 =for apidoc sv_reset
6584 Underlying implementation for the C<reset> Perl function.
6585 Note that the perl-level function is vaguely deprecated.
6591 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
6594 char todo[PERL_UCHAR_MAX+1];
6599 if (!*s) { /* reset ?? searches */
6600 MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
6602 PMOP *pm = (PMOP *) mg->mg_obj;
6604 pm->op_pmdynflags &= ~PMdf_USED;
6611 /* reset variables */
6613 if (!HvARRAY(stash))
6616 Zero(todo, 256, char);
6619 I32 i = (unsigned char)*s;
6623 max = (unsigned char)*s++;
6624 for ( ; i <= max; i++) {
6627 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6629 for (entry = HvARRAY(stash)[i];
6631 entry = HeNEXT(entry))
6636 if (!todo[(U8)*HeKEY(entry)])
6638 gv = (GV*)HeVAL(entry);
6641 if (SvTHINKFIRST(sv)) {
6642 if (!SvREADONLY(sv) && SvROK(sv))
6644 /* XXX Is this continue a bug? Why should THINKFIRST
6645 exempt us from resetting arrays and hashes? */
6649 if (SvTYPE(sv) >= SVt_PV) {
6651 if (SvPVX_const(sv) != Nullch)
6659 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
6661 Perl_die(aTHX_ "Can't reset %%ENV on this system");
6664 # if defined(USE_ENVIRON_ARRAY)
6667 # endif /* USE_ENVIRON_ARRAY */
6678 Using various gambits, try to get an IO from an SV: the IO slot if its a
6679 GV; or the recursive result if we're an RV; or the IO slot of the symbol
6680 named after the PV if we're a string.
6686 Perl_sv_2io(pTHX_ SV *sv)
6691 switch (SvTYPE(sv)) {
6699 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6703 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6705 return sv_2io(SvRV(sv));
6706 gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
6712 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
6721 Using various gambits, try to get a CV from an SV; in addition, try if
6722 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
6728 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6735 return *gvp = Nullgv, Nullcv;
6736 switch (SvTYPE(sv)) {
6754 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6755 tryAMAGICunDEREF(to_cv);
6758 if (SvTYPE(sv) == SVt_PVCV) {
6767 Perl_croak(aTHX_ "Not a subroutine reference");
6772 gv = gv_fetchsv(sv, lref, SVt_PVCV);
6778 if (lref && !GvCVu(gv)) {
6781 tmpsv = NEWSV(704,0);
6782 gv_efullname3(tmpsv, gv, Nullch);
6783 /* XXX this is probably not what they think they're getting.
6784 * It has the same effect as "sub name;", i.e. just a forward
6786 newSUB(start_subparse(FALSE, 0),
6787 newSVOP(OP_CONST, 0, tmpsv),
6792 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
6802 Returns true if the SV has a true value by Perl's rules.
6803 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
6804 instead use an in-line version.
6810 Perl_sv_true(pTHX_ register SV *sv)
6815 register const XPV* const tXpv = (XPV*)SvANY(sv);
6817 (tXpv->xpv_cur > 1 ||
6818 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
6825 return SvIVX(sv) != 0;
6828 return SvNVX(sv) != 0.0;
6830 return sv_2bool(sv);
6836 =for apidoc sv_pvn_force
6838 Get a sensible string out of the SV somehow.
6839 A private implementation of the C<SvPV_force> macro for compilers which
6840 can't cope with complex macro expressions. Always use the macro instead.
6842 =for apidoc sv_pvn_force_flags
6844 Get a sensible string out of the SV somehow.
6845 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6846 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6847 implemented in terms of this function.
6848 You normally want to use the various wrapper macros instead: see
6849 C<SvPV_force> and C<SvPV_force_nomg>
6855 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6858 if (SvTHINKFIRST(sv) && !SvROK(sv))
6859 sv_force_normal_flags(sv, 0);
6869 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
6870 const char * const ref = sv_reftype(sv,0);
6872 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
6873 ref, OP_NAME(PL_op));
6875 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
6877 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
6878 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6880 s = sv_2pv_flags(sv, &len, flags);
6884 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
6887 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6888 SvGROW(sv, len + 1);
6889 Move(s,SvPVX(sv),len,char);
6894 SvPOK_on(sv); /* validate pointer */
6896 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6897 PTR2UV(sv),SvPVX_const(sv)));
6900 return SvPVX_mutable(sv);
6904 =for apidoc sv_pvbyten_force
6906 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
6912 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6914 sv_pvn_force(sv,lp);
6915 sv_utf8_downgrade(sv,0);
6921 =for apidoc sv_pvutf8n_force
6923 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
6929 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6931 sv_pvn_force(sv,lp);
6932 sv_utf8_upgrade(sv);
6938 =for apidoc sv_reftype
6940 Returns a string describing what the SV is a reference to.
6946 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
6948 /* The fact that I don't need to downcast to char * everywhere, only in ?:
6949 inside return suggests a const propagation bug in g++. */
6950 if (ob && SvOBJECT(sv)) {
6951 char * const name = HvNAME_get(SvSTASH(sv));
6952 return name ? name : (char *) "__ANON__";
6955 switch (SvTYPE(sv)) {
6972 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
6973 /* tied lvalues should appear to be
6974 * scalars for backwards compatitbility */
6975 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
6976 ? "SCALAR" : "LVALUE");
6977 case SVt_PVAV: return "ARRAY";
6978 case SVt_PVHV: return "HASH";
6979 case SVt_PVCV: return "CODE";
6980 case SVt_PVGV: return "GLOB";
6981 case SVt_PVFM: return "FORMAT";
6982 case SVt_PVIO: return "IO";
6983 default: return "UNKNOWN";
6989 =for apidoc sv_isobject
6991 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6992 object. If the SV is not an RV, or if the object is not blessed, then this
6999 Perl_sv_isobject(pTHX_ SV *sv)
7015 Returns a boolean indicating whether the SV is blessed into the specified
7016 class. This does not check for subtypes; use C<sv_derived_from> to verify
7017 an inheritance relationship.
7023 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7034 hvname = HvNAME_get(SvSTASH(sv));
7038 return strEQ(hvname, name);
7044 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
7045 it will be upgraded to one. If C<classname> is non-null then the new SV will
7046 be blessed in the specified package. The new SV is returned and its
7047 reference count is 1.
7053 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7059 SV_CHECK_THINKFIRST_COW_DROP(rv);
7062 if (SvTYPE(rv) >= SVt_PVMG) {
7063 const U32 refcnt = SvREFCNT(rv);
7067 SvREFCNT(rv) = refcnt;
7070 if (SvTYPE(rv) < SVt_RV)
7071 sv_upgrade(rv, SVt_RV);
7072 else if (SvTYPE(rv) > SVt_RV) {
7083 HV* const stash = gv_stashpv(classname, TRUE);
7084 (void)sv_bless(rv, stash);
7090 =for apidoc sv_setref_pv
7092 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7093 argument will be upgraded to an RV. That RV will be modified to point to
7094 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7095 into the SV. The C<classname> argument indicates the package for the
7096 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7097 will have a reference count of 1, and the RV will be returned.
7099 Do not use with other Perl types such as HV, AV, SV, CV, because those
7100 objects will become corrupted by the pointer copy process.
7102 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7108 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7111 sv_setsv(rv, &PL_sv_undef);
7115 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7120 =for apidoc sv_setref_iv
7122 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7123 argument will be upgraded to an RV. That RV will be modified to point to
7124 the new SV. The C<classname> argument indicates the package for the
7125 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7126 will have a reference count of 1, and the RV will be returned.
7132 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7134 sv_setiv(newSVrv(rv,classname), iv);
7139 =for apidoc sv_setref_uv
7141 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7142 argument will be upgraded to an RV. That RV will be modified to point to
7143 the new SV. The C<classname> argument indicates the package for the
7144 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7145 will have a reference count of 1, and the RV will be returned.
7151 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7153 sv_setuv(newSVrv(rv,classname), uv);
7158 =for apidoc sv_setref_nv
7160 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7161 argument will be upgraded to an RV. That RV will be modified to point to
7162 the new SV. The C<classname> argument indicates the package for the
7163 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7164 will have a reference count of 1, and the RV will be returned.
7170 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7172 sv_setnv(newSVrv(rv,classname), nv);
7177 =for apidoc sv_setref_pvn
7179 Copies a string into a new SV, optionally blessing the SV. The length of the
7180 string must be specified with C<n>. The C<rv> argument will be upgraded to
7181 an RV. That RV will be modified to point to the new SV. The C<classname>
7182 argument indicates the package for the blessing. Set C<classname> to
7183 C<Nullch> to avoid the blessing. The new SV will have a reference count
7184 of 1, and the RV will be returned.
7186 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7192 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n)
7194 sv_setpvn(newSVrv(rv,classname), pv, n);
7199 =for apidoc sv_bless
7201 Blesses an SV into a specified package. The SV must be an RV. The package
7202 must be designated by its stash (see C<gv_stashpv()>). The reference count
7203 of the SV is unaffected.
7209 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7213 Perl_croak(aTHX_ "Can't bless non-reference value");
7215 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7216 if (SvREADONLY(tmpRef))
7217 Perl_croak(aTHX_ PL_no_modify);
7218 if (SvOBJECT(tmpRef)) {
7219 if (SvTYPE(tmpRef) != SVt_PVIO)
7221 SvREFCNT_dec(SvSTASH(tmpRef));
7224 SvOBJECT_on(tmpRef);
7225 if (SvTYPE(tmpRef) != SVt_PVIO)
7227 SvUPGRADE(tmpRef, SVt_PVMG);
7228 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
7235 if(SvSMAGICAL(tmpRef))
7236 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
7244 /* Downgrades a PVGV to a PVMG.
7248 S_sv_unglob(pTHX_ SV *sv)
7252 assert(SvTYPE(sv) == SVt_PVGV);
7257 sv_del_backref((SV*)GvSTASH(sv), sv);
7258 GvSTASH(sv) = Nullhv;
7260 sv_unmagic(sv, PERL_MAGIC_glob);
7261 Safefree(GvNAME(sv));
7264 /* need to keep SvANY(sv) in the right arena */
7265 xpvmg = new_XPVMG();
7266 StructCopy(SvANY(sv), xpvmg, XPVMG);
7267 del_XPVGV(SvANY(sv));
7270 SvFLAGS(sv) &= ~SVTYPEMASK;
7271 SvFLAGS(sv) |= SVt_PVMG;
7275 =for apidoc sv_unref_flags
7277 Unsets the RV status of the SV, and decrements the reference count of
7278 whatever was being referenced by the RV. This can almost be thought of
7279 as a reversal of C<newSVrv>. The C<cflags> argument can contain
7280 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7281 (otherwise the decrementing is conditional on the reference count being
7282 different from one or the reference being a readonly SV).
7289 Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
7291 SV* const target = SvRV(ref);
7293 if (SvWEAKREF(ref)) {
7294 sv_del_backref(target, ref);
7296 SvRV_set(ref, NULL);
7299 SvRV_set(ref, NULL);
7301 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
7302 assigned to as BEGIN {$a = \"Foo"} will fail. */
7303 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
7304 SvREFCNT_dec(target);
7305 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7306 sv_2mortal(target); /* Schedule for freeing later */
7310 =for apidoc sv_untaint
7312 Untaint an SV. Use C<SvTAINTED_off> instead.
7317 Perl_sv_untaint(pTHX_ SV *sv)
7319 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7320 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
7327 =for apidoc sv_tainted
7329 Test an SV for taintedness. Use C<SvTAINTED> instead.
7334 Perl_sv_tainted(pTHX_ SV *sv)
7336 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7337 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
7338 if (mg && (mg->mg_len & 1) )
7345 =for apidoc sv_setpviv
7347 Copies an integer into the given SV, also updating its string value.
7348 Does not handle 'set' magic. See C<sv_setpviv_mg>.
7354 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
7356 char buf[TYPE_CHARS(UV)];
7358 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7360 sv_setpvn(sv, ptr, ebuf - ptr);
7364 =for apidoc sv_setpviv_mg
7366 Like C<sv_setpviv>, but also handles 'set' magic.
7372 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
7378 #if defined(PERL_IMPLICIT_CONTEXT)
7380 /* pTHX_ magic can't cope with varargs, so this is a no-context
7381 * version of the main function, (which may itself be aliased to us).
7382 * Don't access this version directly.
7386 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
7390 va_start(args, pat);
7391 sv_vsetpvf(sv, pat, &args);
7395 /* pTHX_ magic can't cope with varargs, so this is a no-context
7396 * version of the main function, (which may itself be aliased to us).
7397 * Don't access this version directly.
7401 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7405 va_start(args, pat);
7406 sv_vsetpvf_mg(sv, pat, &args);
7412 =for apidoc sv_setpvf
7414 Works like C<sv_catpvf> but copies the text into the SV instead of
7415 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
7421 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7424 va_start(args, pat);
7425 sv_vsetpvf(sv, pat, &args);
7430 =for apidoc sv_vsetpvf
7432 Works like C<sv_vcatpvf> but copies the text into the SV instead of
7433 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
7435 Usually used via its frontend C<sv_setpvf>.
7441 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7443 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7447 =for apidoc sv_setpvf_mg
7449 Like C<sv_setpvf>, but also handles 'set' magic.
7455 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7458 va_start(args, pat);
7459 sv_vsetpvf_mg(sv, pat, &args);
7464 =for apidoc sv_vsetpvf_mg
7466 Like C<sv_vsetpvf>, but also handles 'set' magic.
7468 Usually used via its frontend C<sv_setpvf_mg>.
7474 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7476 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7480 #if defined(PERL_IMPLICIT_CONTEXT)
7482 /* pTHX_ magic can't cope with varargs, so this is a no-context
7483 * version of the main function, (which may itself be aliased to us).
7484 * Don't access this version directly.
7488 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
7492 va_start(args, pat);
7493 sv_vcatpvf(sv, pat, &args);
7497 /* pTHX_ magic can't cope with varargs, so this is a no-context
7498 * version of the main function, (which may itself be aliased to us).
7499 * Don't access this version directly.
7503 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
7507 va_start(args, pat);
7508 sv_vcatpvf_mg(sv, pat, &args);
7514 =for apidoc sv_catpvf
7516 Processes its arguments like C<sprintf> and appends the formatted
7517 output to an SV. If the appended data contains "wide" characters
7518 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
7519 and characters >255 formatted with %c), the original SV might get
7520 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
7521 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
7522 valid UTF-8; if the original SV was bytes, the pattern should be too.
7527 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
7530 va_start(args, pat);
7531 sv_vcatpvf(sv, pat, &args);
7536 =for apidoc sv_vcatpvf
7538 Processes its arguments like C<vsprintf> and appends the formatted output
7539 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
7541 Usually used via its frontend C<sv_catpvf>.
7547 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7549 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7553 =for apidoc sv_catpvf_mg
7555 Like C<sv_catpvf>, but also handles 'set' magic.
7561 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7564 va_start(args, pat);
7565 sv_vcatpvf_mg(sv, pat, &args);
7570 =for apidoc sv_vcatpvf_mg
7572 Like C<sv_vcatpvf>, but also handles 'set' magic.
7574 Usually used via its frontend C<sv_catpvf_mg>.
7580 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7582 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7587 =for apidoc sv_vsetpvfn
7589 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
7592 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
7598 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7600 sv_setpvn(sv, "", 0);
7601 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
7604 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
7607 S_expect_number(pTHX_ char** pattern)
7610 switch (**pattern) {
7611 case '1': case '2': case '3':
7612 case '4': case '5': case '6':
7613 case '7': case '8': case '9':
7614 var = *(*pattern)++ - '0';
7615 while (isDIGIT(**pattern)) {
7616 I32 tmp = var * 10 + (*(*pattern)++ - '0');
7618 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn"));
7624 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
7627 F0convert(NV nv, char *endbuf, STRLEN *len)
7629 const int neg = nv < 0;
7638 if (uv & 1 && uv == nv)
7639 uv--; /* Round to even */
7641 const unsigned dig = uv % 10;
7654 =for apidoc sv_vcatpvfn
7656 Processes its arguments like C<vsprintf> and appends the formatted output
7657 to an SV. Uses an array of SVs if the C style variable argument list is
7658 missing (NULL). When running with taint checks enabled, indicates via
7659 C<maybe_tainted> if results are untrustworthy (often due to the use of
7662 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
7668 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
7669 vecstr = (U8*)SvPV_const(vecsv,veclen);\
7670 vec_utf8 = DO_UTF8(vecsv);
7672 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
7675 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7682 static const char nullstr[] = "(null)";
7684 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
7685 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
7687 /* Times 4: a decimal digit takes more than 3 binary digits.
7688 * NV_DIG: mantissa takes than many decimal digits.
7689 * Plus 32: Playing safe. */
7690 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7691 /* large enough for "%#.#f" --chip */
7692 /* what about long double NVs? --jhi */
7694 PERL_UNUSED_ARG(maybe_tainted);
7696 /* no matter what, this is a string now */
7697 (void)SvPV_force(sv, origlen);
7699 /* special-case "", "%s", and "%-p" (SVf - see below) */
7702 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
7704 const char * const s = va_arg(*args, char*);
7705 sv_catpv(sv, s ? s : nullstr);
7707 else if (svix < svmax) {
7708 sv_catsv(sv, *svargs);
7712 if (args && patlen == 3 && pat[0] == '%' &&
7713 pat[1] == '-' && pat[2] == 'p') {
7714 argsv = va_arg(*args, SV*);
7715 sv_catsv(sv, argsv);
7719 #ifndef USE_LONG_DOUBLE
7720 /* special-case "%.<number>[gf]" */
7721 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
7722 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
7723 unsigned digits = 0;
7727 while (*pp >= '0' && *pp <= '9')
7728 digits = 10 * digits + (*pp++ - '0');
7729 if (pp - pat == (int)patlen - 1) {
7737 /* Add check for digits != 0 because it seems that some
7738 gconverts are buggy in this case, and we don't yet have
7739 a Configure test for this. */
7740 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
7741 /* 0, point, slack */
7742 Gconvert(nv, (int)digits, 0, ebuf);
7744 if (*ebuf) /* May return an empty string for digits==0 */
7747 } else if (!digits) {
7750 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
7751 sv_catpvn(sv, p, l);
7757 #endif /* !USE_LONG_DOUBLE */
7759 if (!args && svix < svmax && DO_UTF8(*svargs))
7762 patend = (char*)pat + patlen;
7763 for (p = (char*)pat; p < patend; p = q) {
7766 bool vectorize = FALSE;
7767 bool vectorarg = FALSE;
7768 bool vec_utf8 = FALSE;
7774 bool has_precis = FALSE;
7777 bool is_utf8 = FALSE; /* is this item utf8? */
7778 #ifdef HAS_LDBL_SPRINTF_BUG
7779 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
7780 with sfio - Allen <allens@cpan.org> */
7781 bool fix_ldbl_sprintf_bug = FALSE;
7785 U8 utf8buf[UTF8_MAXBYTES+1];
7786 STRLEN esignlen = 0;
7788 const char *eptr = Nullch;
7791 const U8 *vecstr = Null(U8*);
7798 /* we need a long double target in case HAS_LONG_DOUBLE but
7801 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
7809 const char *dotstr = ".";
7810 STRLEN dotstrlen = 1;
7811 I32 efix = 0; /* explicit format parameter index */
7812 I32 ewix = 0; /* explicit width index */
7813 I32 epix = 0; /* explicit precision index */
7814 I32 evix = 0; /* explicit vector index */
7815 bool asterisk = FALSE;
7817 /* echo everything up to the next format specification */
7818 for (q = p; q < patend && *q != '%'; ++q) ;
7820 if (has_utf8 && !pat_utf8)
7821 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
7823 sv_catpvn(sv, p, q - p);
7830 We allow format specification elements in this order:
7831 \d+\$ explicit format parameter index
7833 v|\*(\d+\$)?v vector with optional (optionally specified) arg
7834 0 flag (as above): repeated to allow "v02"
7835 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7836 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7838 [%bcdefginopsuxDFOUX] format (mandatory)
7843 As of perl5.9.3, printf format checking is on by default.
7844 Internally, perl uses %p formats to provide an escape to
7845 some extended formatting. This block deals with those
7846 extensions: if it does not match, (char*)q is reset and
7847 the normal format processing code is used.
7849 Currently defined extensions are:
7850 %p include pointer address (standard)
7851 %-p (SVf) include an SV (previously %_)
7852 %-<num>p include an SV with precision <num>
7853 %1p (VDf) include a v-string (as %vd)
7854 %<num>p reserved for future extensions
7856 Robin Barker 2005-07-14
7863 EXPECT_NUMBER(q, n);
7870 argsv = va_arg(*args, SV*);
7871 eptr = SvPVx_const(argsv, elen);
7877 else if (n == vdNUMBER) { /* VDf */
7884 if (ckWARN_d(WARN_INTERNAL))
7885 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
7886 "internal %%<num>p might conflict with future printf extensions");
7892 if (EXPECT_NUMBER(q, width)) {
7933 if (EXPECT_NUMBER(q, ewix))
7942 if ((vectorarg = asterisk)) {
7955 EXPECT_NUMBER(q, width);
7961 vecsv = va_arg(*args, SV*);
7963 vecsv = (evix > 0 && evix <= svmax)
7964 ? svargs[evix-1] : &PL_sv_undef;
7966 vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
7968 dotstr = SvPV_const(vecsv, dotstrlen);
7969 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
7970 bad with tied or overloaded values that return UTF8. */
7973 else if (has_utf8) {
7974 vecsv = sv_mortalcopy(vecsv);
7975 sv_utf8_upgrade(vecsv);
7976 dotstr = SvPV_const(vecsv, dotstrlen);
7983 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
7984 vecsv = svargs[efix ? efix-1 : svix++];
7985 vecstr = (U8*)SvPV_const(vecsv,veclen);
7986 vec_utf8 = DO_UTF8(vecsv);
7987 /* if this is a version object, we need to return the
7988 * stringified representation (which the SvPVX_const has
7989 * already done for us), but not vectorize the args
7991 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
7993 q++; /* skip past the rest of the %vd format */
7994 eptr = (const char *) vecstr;
7996 if (elen && *eptr == 'v') {
8012 i = va_arg(*args, int);
8014 i = (ewix ? ewix <= svmax : svix < svmax) ?
8015 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8017 width = (i < 0) ? -i : i;
8027 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
8029 /* XXX: todo, support specified precision parameter */
8033 i = va_arg(*args, int);
8035 i = (ewix ? ewix <= svmax : svix < svmax)
8036 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8037 precis = (i < 0) ? 0 : i;
8042 precis = precis * 10 + (*q++ - '0');
8051 case 'I': /* Ix, I32x, and I64x */
8053 if (q[1] == '6' && q[2] == '4') {
8059 if (q[1] == '3' && q[2] == '2') {
8069 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8080 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8081 if (*(q + 1) == 'l') { /* lld, llf */
8107 if (!vectorize && !args) {
8109 const I32 i = efix-1;
8110 argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
8112 argsv = (svix >= 0 && svix < svmax)
8113 ? svargs[svix++] : &PL_sv_undef;
8124 uv = (args) ? va_arg(*args, int) : SvIVx(argsv);
8126 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8128 eptr = (char*)utf8buf;
8129 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
8143 eptr = va_arg(*args, char*);
8145 #ifdef MACOS_TRADITIONAL
8146 /* On MacOS, %#s format is used for Pascal strings */
8151 elen = strlen(eptr);
8153 eptr = (char *)nullstr;
8154 elen = sizeof nullstr - 1;
8158 eptr = SvPVx_const(argsv, elen);
8159 if (DO_UTF8(argsv)) {
8160 if (has_precis && precis < elen) {
8162 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
8165 if (width) { /* fudge width (can't fudge elen) */
8166 width += elen - sv_len_utf8(argsv);
8173 if (has_precis && elen > precis)
8180 if (alt || vectorize)
8182 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
8203 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8212 esignbuf[esignlen++] = plus;
8216 case 'h': iv = (short)va_arg(*args, int); break;
8217 case 'l': iv = va_arg(*args, long); break;
8218 case 'V': iv = va_arg(*args, IV); break;
8219 default: iv = va_arg(*args, int); break;
8221 case 'q': iv = va_arg(*args, Quad_t); break;
8226 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
8228 case 'h': iv = (short)tiv; break;
8229 case 'l': iv = (long)tiv; break;
8231 default: iv = tiv; break;
8233 case 'q': iv = (Quad_t)tiv; break;
8237 if ( !vectorize ) /* we already set uv above */
8242 esignbuf[esignlen++] = plus;
8246 esignbuf[esignlen++] = '-';
8289 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8300 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
8301 case 'l': uv = va_arg(*args, unsigned long); break;
8302 case 'V': uv = va_arg(*args, UV); break;
8303 default: uv = va_arg(*args, unsigned); break;
8305 case 'q': uv = va_arg(*args, Uquad_t); break;
8310 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
8312 case 'h': uv = (unsigned short)tuv; break;
8313 case 'l': uv = (unsigned long)tuv; break;
8315 default: uv = tuv; break;
8317 case 'q': uv = (Uquad_t)tuv; break;
8324 char *ptr = ebuf + sizeof ebuf;
8330 p = (char*)((c == 'X')
8331 ? "0123456789ABCDEF" : "0123456789abcdef");
8337 esignbuf[esignlen++] = '0';
8338 esignbuf[esignlen++] = c; /* 'x' or 'X' */
8346 if (alt && *ptr != '0')
8357 esignbuf[esignlen++] = '0';
8358 esignbuf[esignlen++] = 'b';
8361 default: /* it had better be ten or less */
8365 } while (uv /= base);
8368 elen = (ebuf + sizeof ebuf) - ptr;
8372 zeros = precis - elen;
8373 else if (precis == 0 && elen == 1 && *eptr == '0')
8379 /* FLOATING POINT */
8382 c = 'f'; /* maybe %F isn't supported here */
8390 /* This is evil, but floating point is even more evil */
8392 /* for SV-style calling, we can only get NV
8393 for C-style calling, we assume %f is double;
8394 for simplicity we allow any of %Lf, %llf, %qf for long double
8398 #if defined(USE_LONG_DOUBLE)
8402 /* [perl #20339] - we should accept and ignore %lf rather than die */
8406 #if defined(USE_LONG_DOUBLE)
8407 intsize = args ? 0 : 'q';
8411 #if defined(HAS_LONG_DOUBLE)
8420 /* now we need (long double) if intsize == 'q', else (double) */
8422 #if LONG_DOUBLESIZE > DOUBLESIZE
8424 va_arg(*args, long double) :
8425 va_arg(*args, double)
8427 va_arg(*args, double)
8432 if (c != 'e' && c != 'E') {
8434 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
8435 will cast our (long double) to (double) */
8436 (void)Perl_frexp(nv, &i);
8437 if (i == PERL_INT_MIN)
8438 Perl_die(aTHX_ "panic: frexp");
8440 need = BIT_DIGITS(i);
8442 need += has_precis ? precis : 6; /* known default */
8447 #ifdef HAS_LDBL_SPRINTF_BUG
8448 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8449 with sfio - Allen <allens@cpan.org> */
8452 # define MY_DBL_MAX DBL_MAX
8453 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
8454 # if DOUBLESIZE >= 8
8455 # define MY_DBL_MAX 1.7976931348623157E+308L
8457 # define MY_DBL_MAX 3.40282347E+38L
8461 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
8462 # define MY_DBL_MAX_BUG 1L
8464 # define MY_DBL_MAX_BUG MY_DBL_MAX
8468 # define MY_DBL_MIN DBL_MIN
8469 # else /* XXX guessing! -Allen */
8470 # if DOUBLESIZE >= 8
8471 # define MY_DBL_MIN 2.2250738585072014E-308L
8473 # define MY_DBL_MIN 1.17549435E-38L
8477 if ((intsize == 'q') && (c == 'f') &&
8478 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
8480 /* it's going to be short enough that
8481 * long double precision is not needed */
8483 if ((nv <= 0L) && (nv >= -0L))
8484 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
8486 /* would use Perl_fp_class as a double-check but not
8487 * functional on IRIX - see perl.h comments */
8489 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
8490 /* It's within the range that a double can represent */
8491 #if defined(DBL_MAX) && !defined(DBL_MIN)
8492 if ((nv >= ((long double)1/DBL_MAX)) ||
8493 (nv <= (-(long double)1/DBL_MAX)))
8495 fix_ldbl_sprintf_bug = TRUE;
8498 if (fix_ldbl_sprintf_bug == TRUE) {
8508 # undef MY_DBL_MAX_BUG
8511 #endif /* HAS_LDBL_SPRINTF_BUG */
8513 need += 20; /* fudge factor */
8514 if (PL_efloatsize < need) {
8515 Safefree(PL_efloatbuf);
8516 PL_efloatsize = need + 20; /* more fudge */
8517 Newx(PL_efloatbuf, PL_efloatsize, char);
8518 PL_efloatbuf[0] = '\0';
8521 if ( !(width || left || plus || alt) && fill != '0'
8522 && has_precis && intsize != 'q' ) { /* Shortcuts */
8523 /* See earlier comment about buggy Gconvert when digits,
8525 if ( c == 'g' && precis) {
8526 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
8527 /* May return an empty string for digits==0 */
8528 if (*PL_efloatbuf) {
8529 elen = strlen(PL_efloatbuf);
8530 goto float_converted;
8532 } else if ( c == 'f' && !precis) {
8533 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
8538 char *ptr = ebuf + sizeof ebuf;
8541 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
8542 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
8543 if (intsize == 'q') {
8544 /* Copy the one or more characters in a long double
8545 * format before the 'base' ([efgEFG]) character to
8546 * the format string. */
8547 static char const prifldbl[] = PERL_PRIfldbl;
8548 char const *p = prifldbl + sizeof(prifldbl) - 3;
8549 while (p >= prifldbl) { *--ptr = *p--; }
8554 do { *--ptr = '0' + (base % 10); } while (base /= 10);
8559 do { *--ptr = '0' + (base % 10); } while (base /= 10);
8571 /* No taint. Otherwise we are in the strange situation
8572 * where printf() taints but print($float) doesn't.
8574 #if defined(HAS_LONG_DOUBLE)
8575 elen = ((intsize == 'q')
8576 ? my_sprintf(PL_efloatbuf, ptr, nv)
8577 : my_sprintf(PL_efloatbuf, ptr, (double)nv));
8579 elen = my_sprintf(PL_efloatbuf, ptr, nv);
8583 eptr = PL_efloatbuf;
8591 i = SvCUR(sv) - origlen;
8594 case 'h': *(va_arg(*args, short*)) = i; break;
8595 default: *(va_arg(*args, int*)) = i; break;
8596 case 'l': *(va_arg(*args, long*)) = i; break;
8597 case 'V': *(va_arg(*args, IV*)) = i; break;
8599 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
8604 sv_setuv_mg(argsv, (UV)i);
8605 continue; /* not "break" */
8612 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
8613 && ckWARN(WARN_PRINTF))
8615 SV * const msg = sv_newmortal();
8616 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
8617 (PL_op->op_type == OP_PRTF) ? "" : "s");
8620 Perl_sv_catpvf(aTHX_ msg,
8621 "\"%%%c\"", c & 0xFF);
8623 Perl_sv_catpvf(aTHX_ msg,
8624 "\"%%\\%03"UVof"\"",
8627 sv_catpv(msg, "end of string");
8628 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
8631 /* output mangled stuff ... */
8637 /* ... right here, because formatting flags should not apply */
8638 SvGROW(sv, SvCUR(sv) + elen + 1);
8640 Copy(eptr, p, elen, char);
8643 SvCUR_set(sv, p - SvPVX_const(sv));
8645 continue; /* not "break" */
8648 /* calculate width before utf8_upgrade changes it */
8649 have = esignlen + zeros + elen;
8651 Perl_croak_nocontext(PL_memory_wrap);
8653 if (is_utf8 != has_utf8) {
8656 sv_utf8_upgrade(sv);
8659 SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
8660 sv_utf8_upgrade(nsv);
8661 eptr = SvPVX_const(nsv);
8664 SvGROW(sv, SvCUR(sv) + elen + 1);
8669 need = (have > width ? have : width);
8672 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
8673 Perl_croak_nocontext(PL_memory_wrap);
8674 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
8676 if (esignlen && fill == '0') {
8678 for (i = 0; i < (int)esignlen; i++)
8682 memset(p, fill, gap);
8685 if (esignlen && fill != '0') {
8687 for (i = 0; i < (int)esignlen; i++)
8692 for (i = zeros; i; i--)
8696 Copy(eptr, p, elen, char);
8700 memset(p, ' ', gap);
8705 Copy(dotstr, p, dotstrlen, char);
8709 vectorize = FALSE; /* done iterating over vecstr */
8716 SvCUR_set(sv, p - SvPVX_const(sv));
8724 /* =========================================================================
8726 =head1 Cloning an interpreter
8728 All the macros and functions in this section are for the private use of
8729 the main function, perl_clone().
8731 The foo_dup() functions make an exact copy of an existing foo thinngy.
8732 During the course of a cloning, a hash table is used to map old addresses
8733 to new addresses. The table is created and manipulated with the
8734 ptr_table_* functions.
8738 ============================================================================*/
8741 #if defined(USE_ITHREADS)
8743 #ifndef GpREFCNT_inc
8744 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
8748 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8749 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
8750 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8751 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
8752 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8753 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
8754 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8755 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
8756 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
8757 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
8758 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8759 #define SAVEPV(p) (p ? savepv(p) : Nullch)
8760 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
8763 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
8764 regcomp.c. AMS 20010712 */
8767 Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
8772 struct reg_substr_datum *s;
8775 return (REGEXP *)NULL;
8777 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8780 len = r->offsets[0];
8781 npar = r->nparens+1;
8783 Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
8784 Copy(r->program, ret->program, len+1, regnode);
8786 Newx(ret->startp, npar, I32);
8787 Copy(r->startp, ret->startp, npar, I32);
8788 Newx(ret->endp, npar, I32);
8789 Copy(r->startp, ret->startp, npar, I32);
8791 Newx(ret->substrs, 1, struct reg_substr_data);
8792 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8793 s->min_offset = r->substrs->data[i].min_offset;
8794 s->max_offset = r->substrs->data[i].max_offset;
8795 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
8796 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
8799 ret->regstclass = NULL;
8802 const int count = r->data->count;
8805 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
8806 char, struct reg_data);
8807 Newx(d->what, count, U8);
8810 for (i = 0; i < count; i++) {
8811 d->what[i] = r->data->what[i];
8812 switch (d->what[i]) {
8813 /* legal options are one of: sfpont
8814 see also regcomp.h and pregfree() */
8816 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
8819 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
8822 /* This is cheating. */
8823 Newx(d->data[i], 1, struct regnode_charclass_class);
8824 StructCopy(r->data->data[i], d->data[i],
8825 struct regnode_charclass_class);
8826 ret->regstclass = (regnode*)d->data[i];
8829 /* Compiled op trees are readonly, and can thus be
8830 shared without duplication. */
8832 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
8836 d->data[i] = r->data->data[i];
8839 d->data[i] = r->data->data[i];
8841 ((reg_trie_data*)d->data[i])->refcount++;
8845 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
8854 Newx(ret->offsets, 2*len+1, U32);
8855 Copy(r->offsets, ret->offsets, 2*len+1, U32);
8857 ret->precomp = SAVEPVN(r->precomp, r->prelen);
8858 ret->refcnt = r->refcnt;
8859 ret->minlen = r->minlen;
8860 ret->prelen = r->prelen;
8861 ret->nparens = r->nparens;
8862 ret->lastparen = r->lastparen;
8863 ret->lastcloseparen = r->lastcloseparen;
8864 ret->reganch = r->reganch;
8866 ret->sublen = r->sublen;
8868 if (RX_MATCH_COPIED(ret))
8869 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
8871 ret->subbeg = Nullch;
8872 #ifdef PERL_OLD_COPY_ON_WRITE
8873 ret->saved_copy = Nullsv;
8876 ptr_table_store(PL_ptr_table, r, ret);
8880 /* duplicate a file handle */
8883 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
8887 PERL_UNUSED_ARG(type);
8890 return (PerlIO*)NULL;
8892 /* look for it in the table first */
8893 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
8897 /* create anew and remember what it is */
8898 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
8899 ptr_table_store(PL_ptr_table, fp, ret);
8903 /* duplicate a directory handle */
8906 Perl_dirp_dup(pTHX_ DIR *dp)
8914 /* duplicate a typeglob */
8917 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
8922 /* look for it in the table first */
8923 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
8927 /* create anew and remember what it is */
8929 ptr_table_store(PL_ptr_table, gp, ret);
8932 ret->gp_refcnt = 0; /* must be before any other dups! */
8933 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
8934 ret->gp_io = io_dup_inc(gp->gp_io, param);
8935 ret->gp_form = cv_dup_inc(gp->gp_form, param);
8936 ret->gp_av = av_dup_inc(gp->gp_av, param);
8937 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
8938 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
8939 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
8940 ret->gp_cvgen = gp->gp_cvgen;
8941 ret->gp_line = gp->gp_line;
8942 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
8946 /* duplicate a chain of magic */
8949 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
8951 MAGIC *mgprev = (MAGIC*)NULL;
8954 return (MAGIC*)NULL;
8955 /* look for it in the table first */
8956 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
8960 for (; mg; mg = mg->mg_moremagic) {
8962 Newxz(nmg, 1, MAGIC);
8964 mgprev->mg_moremagic = nmg;
8967 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
8968 nmg->mg_private = mg->mg_private;
8969 nmg->mg_type = mg->mg_type;
8970 nmg->mg_flags = mg->mg_flags;
8971 if (mg->mg_type == PERL_MAGIC_qr) {
8972 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
8974 else if(mg->mg_type == PERL_MAGIC_backref) {
8975 const AV * const av = (AV*) mg->mg_obj;
8978 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
8980 for (i = AvFILLp(av); i >= 0; i--) {
8981 if (!svp[i]) continue;
8982 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
8985 else if (mg->mg_type == PERL_MAGIC_symtab) {
8986 nmg->mg_obj = mg->mg_obj;
8989 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
8990 ? sv_dup_inc(mg->mg_obj, param)
8991 : sv_dup(mg->mg_obj, param);
8993 nmg->mg_len = mg->mg_len;
8994 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
8995 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
8996 if (mg->mg_len > 0) {
8997 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
8998 if (mg->mg_type == PERL_MAGIC_overload_table &&
8999 AMT_AMAGIC((AMT*)mg->mg_ptr))
9001 AMT * const amtp = (AMT*)mg->mg_ptr;
9002 AMT * const namtp = (AMT*)nmg->mg_ptr;
9004 for (i = 1; i < NofAMmeth; i++) {
9005 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9009 else if (mg->mg_len == HEf_SVKEY)
9010 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9012 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9013 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
9020 /* create a new pointer-mapping table */
9023 Perl_ptr_table_new(pTHX)
9026 Newxz(tbl, 1, PTR_TBL_t);
9029 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
9033 #define PTR_TABLE_HASH(ptr) \
9034 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
9037 we use the PTE_SVSLOT 'reservation' made above, both here (in the
9038 following define) and at call to new_body_inline made below in
9039 Perl_ptr_table_store()
9042 #define del_pte(p) del_body_type(p, PTE_SVSLOT)
9044 /* map an existing pointer using a table */
9046 STATIC PTR_TBL_ENT_t *
9047 S_ptr_table_find(pTHX_ PTR_TBL_t *tbl, const void *sv) {
9048 PTR_TBL_ENT_t *tblent;
9049 const UV hash = PTR_TABLE_HASH(sv);
9051 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9052 for (; tblent; tblent = tblent->next) {
9053 if (tblent->oldval == sv)
9060 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
9062 PTR_TBL_ENT_t const *const tblent = S_ptr_table_find(aTHX_ tbl, sv);
9063 return tblent ? tblent->newval : (void *) 0;
9066 /* add a new entry to a pointer-mapping table */
9069 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
9071 PTR_TBL_ENT_t *tblent = S_ptr_table_find(aTHX_ tbl, oldsv);
9074 tblent->newval = newsv;
9076 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
9078 new_body_inline(tblent, sizeof(struct ptr_tbl_ent), PTE_SVSLOT);
9079 tblent->oldval = oldsv;
9080 tblent->newval = newsv;
9081 tblent->next = tbl->tbl_ary[entry];
9082 tbl->tbl_ary[entry] = tblent;
9084 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
9085 ptr_table_split(tbl);
9089 /* double the hash bucket size of an existing ptr table */
9092 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9094 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9095 const UV oldsize = tbl->tbl_max + 1;
9096 UV newsize = oldsize * 2;
9099 Renew(ary, newsize, PTR_TBL_ENT_t*);
9100 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9101 tbl->tbl_max = --newsize;
9103 for (i=0; i < oldsize; i++, ary++) {
9104 PTR_TBL_ENT_t **curentp, **entp, *ent;
9107 curentp = ary + oldsize;
9108 for (entp = ary, ent = *ary; ent; ent = *entp) {
9109 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
9111 ent->next = *curentp;
9121 /* remove all the entries from a ptr table */
9124 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9126 if (tbl && tbl->tbl_items) {
9127 register PTR_TBL_ENT_t **array = tbl->tbl_ary;
9128 UV riter = tbl->tbl_max;
9131 PTR_TBL_ENT_t *entry = array[riter];
9134 PTR_TBL_ENT_t * const oentry = entry;
9135 entry = entry->next;
9144 /* clear and free a ptr table */
9147 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
9152 ptr_table_clear(tbl);
9153 Safefree(tbl->tbl_ary);
9159 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
9162 SvRV_set(dstr, SvWEAKREF(sstr)
9163 ? sv_dup(SvRV(sstr), param)
9164 : sv_dup_inc(SvRV(sstr), param));
9167 else if (SvPVX_const(sstr)) {
9168 /* Has something there */
9170 /* Normal PV - clone whole allocated space */
9171 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
9172 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9173 /* Not that normal - actually sstr is copy on write.
9174 But we are a true, independant SV, so: */
9175 SvREADONLY_off(dstr);
9180 /* Special case - not normally malloced for some reason */
9181 if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
9182 /* A "shared" PV - clone it as "shared" PV */
9184 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
9188 /* Some other special case - random pointer */
9189 SvPV_set(dstr, SvPVX(sstr));
9195 if (SvTYPE(dstr) == SVt_RV)
9196 SvRV_set(dstr, NULL);
9202 /* duplicate an SV of any type (including AV, HV etc) */
9205 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
9210 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
9212 /* look for it in the table first */
9213 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
9217 if(param->flags & CLONEf_JOIN_IN) {
9218 /** We are joining here so we don't want do clone
9219 something that is bad **/
9222 if(SvTYPE(sstr) == SVt_PVHV &&
9223 (hvname = HvNAME_get(sstr))) {
9224 /** don't clone stashes if they already exist **/
9225 return (SV*)gv_stashpv(hvname,0);
9229 /* create anew and remember what it is */
9232 #ifdef DEBUG_LEAKING_SCALARS
9233 dstr->sv_debug_optype = sstr->sv_debug_optype;
9234 dstr->sv_debug_line = sstr->sv_debug_line;
9235 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
9236 dstr->sv_debug_cloned = 1;
9238 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
9240 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
9244 ptr_table_store(PL_ptr_table, sstr, dstr);
9247 SvFLAGS(dstr) = SvFLAGS(sstr);
9248 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
9249 SvREFCNT(dstr) = 0; /* must be before any other dups! */
9252 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
9253 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
9254 PL_watch_pvx, SvPVX_const(sstr));
9257 /* don't clone objects whose class has asked us not to */
9258 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
9259 SvFLAGS(dstr) &= ~SVTYPEMASK;
9264 switch (SvTYPE(sstr)) {
9269 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
9270 SvIV_set(dstr, SvIVX(sstr));
9273 SvANY(dstr) = new_XNV();
9274 SvNV_set(dstr, SvNVX(sstr));
9277 SvANY(dstr) = &(dstr->sv_u.svu_rv);
9278 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9282 /* These are all the types that need complex bodies allocating. */
9284 const svtype sv_type = SvTYPE(sstr);
9285 const struct body_details *const sv_type_details
9286 = bodies_by_type + sv_type;
9290 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]",
9295 if (GvUNIQUE((GV*)sstr)) {
9296 /* Do sharing here, and fall through */
9309 assert(sv_type_details->copy);
9310 if (sv_type_details->arena) {
9311 new_body_inline(new_body, sv_type_details->copy, sv_type);
9313 = (void*)((char*)new_body - sv_type_details->offset);
9315 new_body = new_NOARENA(sv_type_details);
9319 SvANY(dstr) = new_body;
9322 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
9323 ((char*)SvANY(dstr)) + sv_type_details->offset,
9324 sv_type_details->copy, char);
9326 Copy(((char*)SvANY(sstr)),
9327 ((char*)SvANY(dstr)),
9328 sv_type_details->size + sv_type_details->offset, char);
9331 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV)
9332 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9334 /* The Copy above means that all the source (unduplicated) pointers
9335 are now in the destination. We can check the flags and the
9336 pointers in either, but it's possible that there's less cache
9337 missing by always going for the destination.
9338 FIXME - instrument and check that assumption */
9339 if (sv_type >= SVt_PVMG) {
9341 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
9343 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
9346 /* The cast silences a GCC warning about unhandled types. */
9347 switch ((int)sv_type) {
9359 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
9360 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
9361 LvTARG(dstr) = dstr;
9362 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
9363 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
9365 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
9368 GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
9369 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
9370 /* Don't call sv_add_backref here as it's going to be created
9371 as part of the magic cloning of the symbol table. */
9372 GvGP(dstr) = gp_dup(GvGP(dstr), param);
9373 (void)GpREFCNT_inc(GvGP(dstr));
9376 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
9377 if (IoOFP(dstr) == IoIFP(sstr))
9378 IoOFP(dstr) = IoIFP(dstr);
9380 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
9381 /* PL_rsfp_filters entries have fake IoDIRP() */
9382 if (IoDIRP(dstr) && !(IoFLAGS(dstr) & IOf_FAKE_DIRP))
9383 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
9384 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
9385 /* I have no idea why fake dirp (rsfps)
9386 should be treated differently but otherwise
9387 we end up with leaks -- sky*/
9388 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
9389 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
9390 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
9392 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
9393 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
9394 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
9396 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
9397 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
9398 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
9401 if (AvARRAY((AV*)sstr)) {
9402 SV **dst_ary, **src_ary;
9403 SSize_t items = AvFILLp((AV*)sstr) + 1;
9405 src_ary = AvARRAY((AV*)sstr);
9406 Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
9407 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
9408 SvPV_set(dstr, (char*)dst_ary);
9409 AvALLOC((AV*)dstr) = dst_ary;
9410 if (AvREAL((AV*)sstr)) {
9412 *dst_ary++ = sv_dup_inc(*src_ary++, param);
9416 *dst_ary++ = sv_dup(*src_ary++, param);
9418 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
9419 while (items-- > 0) {
9420 *dst_ary++ = &PL_sv_undef;
9424 SvPV_set(dstr, Nullch);
9425 AvALLOC((AV*)dstr) = (SV**)NULL;
9432 if (HvARRAY((HV*)sstr)) {
9434 const bool sharekeys = !!HvSHAREKEYS(sstr);
9435 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
9436 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
9438 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
9439 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
9441 HvARRAY(dstr) = (HE**)darray;
9442 while (i <= sxhv->xhv_max) {
9443 const HE *source = HvARRAY(sstr)[i];
9444 HvARRAY(dstr)[i] = source
9445 ? he_dup(source, sharekeys, param) : 0;
9449 struct xpvhv_aux * const saux = HvAUX(sstr);
9450 struct xpvhv_aux * const daux = HvAUX(dstr);
9451 /* This flag isn't copied. */
9452 /* SvOOK_on(hv) attacks the IV flags. */
9453 SvFLAGS(dstr) |= SVf_OOK;
9455 hvname = saux->xhv_name;
9457 = hvname ? hek_dup(hvname, param) : hvname;
9459 daux->xhv_riter = saux->xhv_riter;
9460 daux->xhv_eiter = saux->xhv_eiter
9461 ? he_dup(saux->xhv_eiter,
9462 (bool)!!HvSHAREKEYS(sstr), param) : 0;
9466 SvPV_set(dstr, Nullch);
9468 /* Record stashes for possible cloning in Perl_clone(). */
9470 av_push(param->stashes, dstr);
9475 /* NOTE: not refcounted */
9476 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
9478 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
9480 if (CvCONST(dstr)) {
9481 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
9482 SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
9483 sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
9485 /* don't dup if copying back - CvGV isn't refcounted, so the
9486 * duped GV may never be freed. A bit of a hack! DAPM */
9487 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
9488 Nullgv : gv_dup(CvGV(dstr), param) ;
9489 if (!(param->flags & CLONEf_COPY_STACKS)) {
9492 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
9495 ? cv_dup( CvOUTSIDE(dstr), param)
9496 : cv_dup_inc(CvOUTSIDE(dstr), param);
9498 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
9504 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9510 /* duplicate a context */
9513 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
9518 return (PERL_CONTEXT*)NULL;
9520 /* look for it in the table first */
9521 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
9525 /* create anew and remember what it is */
9526 Newxz(ncxs, max + 1, PERL_CONTEXT);
9527 ptr_table_store(PL_ptr_table, cxs, ncxs);
9530 PERL_CONTEXT *cx = &cxs[ix];
9531 PERL_CONTEXT *ncx = &ncxs[ix];
9532 ncx->cx_type = cx->cx_type;
9533 if (CxTYPE(cx) == CXt_SUBST) {
9534 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
9537 ncx->blk_oldsp = cx->blk_oldsp;
9538 ncx->blk_oldcop = cx->blk_oldcop;
9539 ncx->blk_oldmarksp = cx->blk_oldmarksp;
9540 ncx->blk_oldscopesp = cx->blk_oldscopesp;
9541 ncx->blk_oldpm = cx->blk_oldpm;
9542 ncx->blk_gimme = cx->blk_gimme;
9543 switch (CxTYPE(cx)) {
9545 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
9546 ? cv_dup_inc(cx->blk_sub.cv, param)
9547 : cv_dup(cx->blk_sub.cv,param));
9548 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
9549 ? av_dup_inc(cx->blk_sub.argarray, param)
9551 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
9552 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
9553 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9554 ncx->blk_sub.lval = cx->blk_sub.lval;
9555 ncx->blk_sub.retop = cx->blk_sub.retop;
9558 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
9559 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
9560 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
9561 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
9562 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
9563 ncx->blk_eval.retop = cx->blk_eval.retop;
9566 ncx->blk_loop.label = cx->blk_loop.label;
9567 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
9568 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
9569 ncx->blk_loop.next_op = cx->blk_loop.next_op;
9570 ncx->blk_loop.last_op = cx->blk_loop.last_op;
9571 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
9572 ? cx->blk_loop.iterdata
9573 : gv_dup((GV*)cx->blk_loop.iterdata, param));
9574 ncx->blk_loop.oldcomppad
9575 = (PAD*)ptr_table_fetch(PL_ptr_table,
9576 cx->blk_loop.oldcomppad);
9577 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
9578 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
9579 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
9580 ncx->blk_loop.iterix = cx->blk_loop.iterix;
9581 ncx->blk_loop.itermax = cx->blk_loop.itermax;
9584 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
9585 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
9586 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
9587 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9588 ncx->blk_sub.retop = cx->blk_sub.retop;
9600 /* duplicate a stack info structure */
9603 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
9608 return (PERL_SI*)NULL;
9610 /* look for it in the table first */
9611 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
9615 /* create anew and remember what it is */
9616 Newxz(nsi, 1, PERL_SI);
9617 ptr_table_store(PL_ptr_table, si, nsi);
9619 nsi->si_stack = av_dup_inc(si->si_stack, param);
9620 nsi->si_cxix = si->si_cxix;
9621 nsi->si_cxmax = si->si_cxmax;
9622 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
9623 nsi->si_type = si->si_type;
9624 nsi->si_prev = si_dup(si->si_prev, param);
9625 nsi->si_next = si_dup(si->si_next, param);
9626 nsi->si_markoff = si->si_markoff;
9631 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
9632 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
9633 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
9634 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
9635 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
9636 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
9637 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
9638 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
9639 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
9640 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
9641 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
9642 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
9643 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
9644 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
9647 #define pv_dup_inc(p) SAVEPV(p)
9648 #define pv_dup(p) SAVEPV(p)
9649 #define svp_dup_inc(p,pp) any_dup(p,pp)
9651 /* map any object to the new equivent - either something in the
9652 * ptr table, or something in the interpreter structure
9656 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
9663 /* look for it in the table first */
9664 ret = ptr_table_fetch(PL_ptr_table, v);
9668 /* see if it is part of the interpreter structure */
9669 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
9670 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
9678 /* duplicate the save stack */
9681 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
9683 ANY * const ss = proto_perl->Tsavestack;
9684 const I32 max = proto_perl->Tsavestack_max;
9685 I32 ix = proto_perl->Tsavestack_ix;
9697 void (*dptr) (void*);
9698 void (*dxptr) (pTHX_ void*);
9700 Newxz(nss, max, ANY);
9703 I32 i = POPINT(ss,ix);
9706 case SAVEt_ITEM: /* normal string */
9707 sv = (SV*)POPPTR(ss,ix);
9708 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9709 sv = (SV*)POPPTR(ss,ix);
9710 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9712 case SAVEt_SV: /* scalar reference */
9713 sv = (SV*)POPPTR(ss,ix);
9714 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9715 gv = (GV*)POPPTR(ss,ix);
9716 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9718 case SAVEt_GENERIC_PVREF: /* generic char* */
9719 c = (char*)POPPTR(ss,ix);
9720 TOPPTR(nss,ix) = pv_dup(c);
9721 ptr = POPPTR(ss,ix);
9722 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9724 case SAVEt_SHARED_PVREF: /* char* in shared space */
9725 c = (char*)POPPTR(ss,ix);
9726 TOPPTR(nss,ix) = savesharedpv(c);
9727 ptr = POPPTR(ss,ix);
9728 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9730 case SAVEt_GENERIC_SVREF: /* generic sv */
9731 case SAVEt_SVREF: /* scalar reference */
9732 sv = (SV*)POPPTR(ss,ix);
9733 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9734 ptr = POPPTR(ss,ix);
9735 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
9737 case SAVEt_AV: /* array reference */
9738 av = (AV*)POPPTR(ss,ix);
9739 TOPPTR(nss,ix) = av_dup_inc(av, param);
9740 gv = (GV*)POPPTR(ss,ix);
9741 TOPPTR(nss,ix) = gv_dup(gv, param);
9743 case SAVEt_HV: /* hash reference */
9744 hv = (HV*)POPPTR(ss,ix);
9745 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9746 gv = (GV*)POPPTR(ss,ix);
9747 TOPPTR(nss,ix) = gv_dup(gv, param);
9749 case SAVEt_INT: /* int reference */
9750 ptr = POPPTR(ss,ix);
9751 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9752 intval = (int)POPINT(ss,ix);
9753 TOPINT(nss,ix) = intval;
9755 case SAVEt_LONG: /* long reference */
9756 ptr = POPPTR(ss,ix);
9757 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9758 longval = (long)POPLONG(ss,ix);
9759 TOPLONG(nss,ix) = longval;
9761 case SAVEt_I32: /* I32 reference */
9762 case SAVEt_I16: /* I16 reference */
9763 case SAVEt_I8: /* I8 reference */
9764 ptr = POPPTR(ss,ix);
9765 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9769 case SAVEt_IV: /* IV reference */
9770 ptr = POPPTR(ss,ix);
9771 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9775 case SAVEt_SPTR: /* SV* reference */
9776 ptr = POPPTR(ss,ix);
9777 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9778 sv = (SV*)POPPTR(ss,ix);
9779 TOPPTR(nss,ix) = sv_dup(sv, param);
9781 case SAVEt_VPTR: /* random* reference */
9782 ptr = POPPTR(ss,ix);
9783 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9784 ptr = POPPTR(ss,ix);
9785 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9787 case SAVEt_PPTR: /* char* reference */
9788 ptr = POPPTR(ss,ix);
9789 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9790 c = (char*)POPPTR(ss,ix);
9791 TOPPTR(nss,ix) = pv_dup(c);
9793 case SAVEt_HPTR: /* HV* reference */
9794 ptr = POPPTR(ss,ix);
9795 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9796 hv = (HV*)POPPTR(ss,ix);
9797 TOPPTR(nss,ix) = hv_dup(hv, param);
9799 case SAVEt_APTR: /* AV* reference */
9800 ptr = POPPTR(ss,ix);
9801 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9802 av = (AV*)POPPTR(ss,ix);
9803 TOPPTR(nss,ix) = av_dup(av, param);
9806 gv = (GV*)POPPTR(ss,ix);
9807 TOPPTR(nss,ix) = gv_dup(gv, param);
9809 case SAVEt_GP: /* scalar reference */
9810 gp = (GP*)POPPTR(ss,ix);
9811 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
9812 (void)GpREFCNT_inc(gp);
9813 gv = (GV*)POPPTR(ss,ix);
9814 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9815 c = (char*)POPPTR(ss,ix);
9816 TOPPTR(nss,ix) = pv_dup(c);
9823 case SAVEt_MORTALIZESV:
9824 sv = (SV*)POPPTR(ss,ix);
9825 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9828 ptr = POPPTR(ss,ix);
9829 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
9830 /* these are assumed to be refcounted properly */
9832 switch (((OP*)ptr)->op_type) {
9839 TOPPTR(nss,ix) = ptr;
9844 TOPPTR(nss,ix) = Nullop;
9849 TOPPTR(nss,ix) = Nullop;
9852 c = (char*)POPPTR(ss,ix);
9853 TOPPTR(nss,ix) = pv_dup_inc(c);
9856 longval = POPLONG(ss,ix);
9857 TOPLONG(nss,ix) = longval;
9860 hv = (HV*)POPPTR(ss,ix);
9861 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9862 c = (char*)POPPTR(ss,ix);
9863 TOPPTR(nss,ix) = pv_dup_inc(c);
9867 case SAVEt_DESTRUCTOR:
9868 ptr = POPPTR(ss,ix);
9869 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9870 dptr = POPDPTR(ss,ix);
9871 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
9872 any_dup(FPTR2DPTR(void *, dptr),
9875 case SAVEt_DESTRUCTOR_X:
9876 ptr = POPPTR(ss,ix);
9877 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9878 dxptr = POPDXPTR(ss,ix);
9879 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
9880 any_dup(FPTR2DPTR(void *, dxptr),
9883 case SAVEt_REGCONTEXT:
9889 case SAVEt_STACK_POS: /* Position on Perl stack */
9893 case SAVEt_AELEM: /* array element */
9894 sv = (SV*)POPPTR(ss,ix);
9895 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9898 av = (AV*)POPPTR(ss,ix);
9899 TOPPTR(nss,ix) = av_dup_inc(av, param);
9901 case SAVEt_HELEM: /* hash element */
9902 sv = (SV*)POPPTR(ss,ix);
9903 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9904 sv = (SV*)POPPTR(ss,ix);
9905 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9906 hv = (HV*)POPPTR(ss,ix);
9907 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9910 ptr = POPPTR(ss,ix);
9911 TOPPTR(nss,ix) = ptr;
9918 av = (AV*)POPPTR(ss,ix);
9919 TOPPTR(nss,ix) = av_dup(av, param);
9922 longval = (long)POPLONG(ss,ix);
9923 TOPLONG(nss,ix) = longval;
9924 ptr = POPPTR(ss,ix);
9925 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9926 sv = (SV*)POPPTR(ss,ix);
9927 TOPPTR(nss,ix) = sv_dup(sv, param);
9930 ptr = POPPTR(ss,ix);
9931 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9932 longval = (long)POPBOOL(ss,ix);
9933 TOPBOOL(nss,ix) = (bool)longval;
9935 case SAVEt_SET_SVFLAGS:
9940 sv = (SV*)POPPTR(ss,ix);
9941 TOPPTR(nss,ix) = sv_dup(sv, param);
9944 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
9952 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
9953 * flag to the result. This is done for each stash before cloning starts,
9954 * so we know which stashes want their objects cloned */
9957 do_mark_cloneable_stash(pTHX_ SV *sv)
9959 const HEK * const hvname = HvNAME_HEK((HV*)sv);
9961 GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
9962 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
9963 if (cloner && GvCV(cloner)) {
9970 XPUSHs(sv_2mortal(newSVhek(hvname)));
9972 call_sv((SV*)GvCV(cloner), G_SCALAR);
9979 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
9987 =for apidoc perl_clone
9989 Create and return a new interpreter by cloning the current one.
9991 perl_clone takes these flags as parameters:
9993 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
9994 without it we only clone the data and zero the stacks,
9995 with it we copy the stacks and the new perl interpreter is
9996 ready to run at the exact same point as the previous one.
9997 The pseudo-fork code uses COPY_STACKS while the
9998 threads->new doesn't.
10000 CLONEf_KEEP_PTR_TABLE
10001 perl_clone keeps a ptr_table with the pointer of the old
10002 variable as a key and the new variable as a value,
10003 this allows it to check if something has been cloned and not
10004 clone it again but rather just use the value and increase the
10005 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
10006 the ptr_table using the function
10007 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
10008 reason to keep it around is if you want to dup some of your own
10009 variable who are outside the graph perl scans, example of this
10010 code is in threads.xs create
10013 This is a win32 thing, it is ignored on unix, it tells perls
10014 win32host code (which is c++) to clone itself, this is needed on
10015 win32 if you want to run two threads at the same time,
10016 if you just want to do some stuff in a separate perl interpreter
10017 and then throw it away and return to the original one,
10018 you don't need to do anything.
10023 /* XXX the above needs expanding by someone who actually understands it ! */
10024 EXTERN_C PerlInterpreter *
10025 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10028 perl_clone(PerlInterpreter *proto_perl, UV flags)
10031 #ifdef PERL_IMPLICIT_SYS
10033 /* perlhost.h so we need to call into it
10034 to clone the host, CPerlHost should have a c interface, sky */
10036 if (flags & CLONEf_CLONE_HOST) {
10037 return perl_clone_host(proto_perl,flags);
10039 return perl_clone_using(proto_perl, flags,
10041 proto_perl->IMemShared,
10042 proto_perl->IMemParse,
10044 proto_perl->IStdIO,
10048 proto_perl->IProc);
10052 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10053 struct IPerlMem* ipM, struct IPerlMem* ipMS,
10054 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10055 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10056 struct IPerlDir* ipD, struct IPerlSock* ipS,
10057 struct IPerlProc* ipP)
10059 /* XXX many of the string copies here can be optimized if they're
10060 * constants; they need to be allocated as common memory and just
10061 * their pointers copied. */
10064 CLONE_PARAMS clone_params;
10065 CLONE_PARAMS* param = &clone_params;
10067 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10068 /* for each stash, determine whether its objects should be cloned */
10069 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10070 PERL_SET_THX(my_perl);
10073 Poison(my_perl, 1, PerlInterpreter);
10075 PL_curcop = (COP *)Nullop;
10079 PL_savestack_ix = 0;
10080 PL_savestack_max = -1;
10081 PL_sig_pending = 0;
10082 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10083 # else /* !DEBUGGING */
10084 Zero(my_perl, 1, PerlInterpreter);
10085 # endif /* DEBUGGING */
10087 /* host pointers */
10089 PL_MemShared = ipMS;
10090 PL_MemParse = ipMP;
10097 #else /* !PERL_IMPLICIT_SYS */
10099 CLONE_PARAMS clone_params;
10100 CLONE_PARAMS* param = &clone_params;
10101 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10102 /* for each stash, determine whether its objects should be cloned */
10103 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10104 PERL_SET_THX(my_perl);
10107 Poison(my_perl, 1, PerlInterpreter);
10109 PL_curcop = (COP *)Nullop;
10113 PL_savestack_ix = 0;
10114 PL_savestack_max = -1;
10115 PL_sig_pending = 0;
10116 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10117 # else /* !DEBUGGING */
10118 Zero(my_perl, 1, PerlInterpreter);
10119 # endif /* DEBUGGING */
10120 #endif /* PERL_IMPLICIT_SYS */
10121 param->flags = flags;
10122 param->proto_perl = proto_perl;
10124 Zero(&PL_body_arenaroots, 1, PL_body_arenaroots);
10125 Zero(&PL_body_roots, 1, PL_body_roots);
10127 PL_nice_chunk = NULL;
10128 PL_nice_chunk_size = 0;
10130 PL_sv_objcount = 0;
10131 PL_sv_root = Nullsv;
10132 PL_sv_arenaroot = Nullsv;
10134 PL_debug = proto_perl->Idebug;
10136 PL_hash_seed = proto_perl->Ihash_seed;
10137 PL_rehash_seed = proto_perl->Irehash_seed;
10139 #ifdef USE_REENTRANT_API
10140 /* XXX: things like -Dm will segfault here in perlio, but doing
10141 * PERL_SET_CONTEXT(proto_perl);
10142 * breaks too many other things
10144 Perl_reentrant_init(aTHX);
10147 /* create SV map for pointer relocation */
10148 PL_ptr_table = ptr_table_new();
10150 /* initialize these special pointers as early as possible */
10151 SvANY(&PL_sv_undef) = NULL;
10152 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
10153 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
10154 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
10156 SvANY(&PL_sv_no) = new_XPVNV();
10157 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
10158 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
10159 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10160 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
10161 SvCUR_set(&PL_sv_no, 0);
10162 SvLEN_set(&PL_sv_no, 1);
10163 SvIV_set(&PL_sv_no, 0);
10164 SvNV_set(&PL_sv_no, 0);
10165 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
10167 SvANY(&PL_sv_yes) = new_XPVNV();
10168 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
10169 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
10170 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10171 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
10172 SvCUR_set(&PL_sv_yes, 1);
10173 SvLEN_set(&PL_sv_yes, 2);
10174 SvIV_set(&PL_sv_yes, 1);
10175 SvNV_set(&PL_sv_yes, 1);
10176 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
10178 /* create (a non-shared!) shared string table */
10179 PL_strtab = newHV();
10180 HvSHAREKEYS_off(PL_strtab);
10181 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
10182 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
10184 PL_compiling = proto_perl->Icompiling;
10186 /* These two PVs will be free'd special way so must set them same way op.c does */
10187 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
10188 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
10190 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
10191 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
10193 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
10194 if (!specialWARN(PL_compiling.cop_warnings))
10195 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
10196 if (!specialCopIO(PL_compiling.cop_io))
10197 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
10198 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
10200 /* pseudo environmental stuff */
10201 PL_origargc = proto_perl->Iorigargc;
10202 PL_origargv = proto_perl->Iorigargv;
10204 param->stashes = newAV(); /* Setup array of objects to call clone on */
10206 /* Set tainting stuff before PerlIO_debug can possibly get called */
10207 PL_tainting = proto_perl->Itainting;
10208 PL_taint_warn = proto_perl->Itaint_warn;
10210 #ifdef PERLIO_LAYERS
10211 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
10212 PerlIO_clone(aTHX_ proto_perl, param);
10215 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
10216 PL_incgv = gv_dup(proto_perl->Iincgv, param);
10217 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
10218 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
10219 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
10220 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
10223 PL_minus_c = proto_perl->Iminus_c;
10224 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
10225 PL_localpatches = proto_perl->Ilocalpatches;
10226 PL_splitstr = proto_perl->Isplitstr;
10227 PL_preprocess = proto_perl->Ipreprocess;
10228 PL_minus_n = proto_perl->Iminus_n;
10229 PL_minus_p = proto_perl->Iminus_p;
10230 PL_minus_l = proto_perl->Iminus_l;
10231 PL_minus_a = proto_perl->Iminus_a;
10232 PL_minus_F = proto_perl->Iminus_F;
10233 PL_doswitches = proto_perl->Idoswitches;
10234 PL_dowarn = proto_perl->Idowarn;
10235 PL_doextract = proto_perl->Idoextract;
10236 PL_sawampersand = proto_perl->Isawampersand;
10237 PL_unsafe = proto_perl->Iunsafe;
10238 PL_inplace = SAVEPV(proto_perl->Iinplace);
10239 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
10240 PL_perldb = proto_perl->Iperldb;
10241 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
10242 PL_exit_flags = proto_perl->Iexit_flags;
10244 /* magical thingies */
10245 /* XXX time(&PL_basetime) when asked for? */
10246 PL_basetime = proto_perl->Ibasetime;
10247 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
10249 PL_maxsysfd = proto_perl->Imaxsysfd;
10250 PL_multiline = proto_perl->Imultiline;
10251 PL_statusvalue = proto_perl->Istatusvalue;
10253 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
10255 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
10257 PL_encoding = sv_dup(proto_perl->Iencoding, param);
10259 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
10260 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
10261 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
10263 /* Clone the regex array */
10264 PL_regex_padav = newAV();
10266 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
10267 SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
10269 av_push(PL_regex_padav,
10270 sv_dup_inc(regexen[0],param));
10271 for(i = 1; i <= len; i++) {
10272 if(SvREPADTMP(regexen[i])) {
10273 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
10275 av_push(PL_regex_padav,
10277 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
10278 SvIVX(regexen[i])), param)))
10283 PL_regex_pad = AvARRAY(PL_regex_padav);
10285 /* shortcuts to various I/O objects */
10286 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
10287 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
10288 PL_defgv = gv_dup(proto_perl->Idefgv, param);
10289 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
10290 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
10291 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
10293 /* shortcuts to regexp stuff */
10294 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
10296 /* shortcuts to misc objects */
10297 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
10299 /* shortcuts to debugging objects */
10300 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
10301 PL_DBline = gv_dup(proto_perl->IDBline, param);
10302 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
10303 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
10304 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
10305 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
10306 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
10307 PL_lineary = av_dup(proto_perl->Ilineary, param);
10308 PL_dbargs = av_dup(proto_perl->Idbargs, param);
10310 /* symbol tables */
10311 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
10312 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
10313 PL_debstash = hv_dup(proto_perl->Idebstash, param);
10314 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
10315 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
10317 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
10318 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
10319 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
10320 PL_endav = av_dup_inc(proto_perl->Iendav, param);
10321 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
10322 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
10324 PL_sub_generation = proto_perl->Isub_generation;
10326 /* funky return mechanisms */
10327 PL_forkprocess = proto_perl->Iforkprocess;
10329 /* subprocess state */
10330 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
10332 /* internal state */
10333 PL_maxo = proto_perl->Imaxo;
10334 if (proto_perl->Iop_mask)
10335 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
10337 PL_op_mask = Nullch;
10338 /* PL_asserting = proto_perl->Iasserting; */
10340 /* current interpreter roots */
10341 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
10342 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
10343 PL_main_start = proto_perl->Imain_start;
10344 PL_eval_root = proto_perl->Ieval_root;
10345 PL_eval_start = proto_perl->Ieval_start;
10347 /* runtime control stuff */
10348 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
10349 PL_copline = proto_perl->Icopline;
10351 PL_filemode = proto_perl->Ifilemode;
10352 PL_lastfd = proto_perl->Ilastfd;
10353 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
10356 PL_gensym = proto_perl->Igensym;
10357 PL_preambled = proto_perl->Ipreambled;
10358 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
10359 PL_laststatval = proto_perl->Ilaststatval;
10360 PL_laststype = proto_perl->Ilaststype;
10361 PL_mess_sv = Nullsv;
10363 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
10365 /* interpreter atexit processing */
10366 PL_exitlistlen = proto_perl->Iexitlistlen;
10367 if (PL_exitlistlen) {
10368 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10369 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10372 PL_exitlist = (PerlExitListEntry*)NULL;
10373 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
10374 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
10375 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
10377 PL_profiledata = NULL;
10378 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
10379 /* PL_rsfp_filters entries have fake IoDIRP() */
10380 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
10382 PL_compcv = cv_dup(proto_perl->Icompcv, param);
10384 PAD_CLONE_VARS(proto_perl, param);
10386 #ifdef HAVE_INTERP_INTERN
10387 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
10390 /* more statics moved here */
10391 PL_generation = proto_perl->Igeneration;
10392 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
10394 PL_in_clean_objs = proto_perl->Iin_clean_objs;
10395 PL_in_clean_all = proto_perl->Iin_clean_all;
10397 PL_uid = proto_perl->Iuid;
10398 PL_euid = proto_perl->Ieuid;
10399 PL_gid = proto_perl->Igid;
10400 PL_egid = proto_perl->Iegid;
10401 PL_nomemok = proto_perl->Inomemok;
10402 PL_an = proto_perl->Ian;
10403 PL_evalseq = proto_perl->Ievalseq;
10404 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
10405 PL_origalen = proto_perl->Iorigalen;
10406 #ifdef PERL_USES_PL_PIDSTATUS
10407 PL_pidstatus = newHV(); /* XXX flag for cloning? */
10409 PL_osname = SAVEPV(proto_perl->Iosname);
10410 PL_sighandlerp = proto_perl->Isighandlerp;
10412 PL_runops = proto_perl->Irunops;
10414 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
10417 PL_cshlen = proto_perl->Icshlen;
10418 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
10421 PL_lex_state = proto_perl->Ilex_state;
10422 PL_lex_defer = proto_perl->Ilex_defer;
10423 PL_lex_expect = proto_perl->Ilex_expect;
10424 PL_lex_formbrack = proto_perl->Ilex_formbrack;
10425 PL_lex_dojoin = proto_perl->Ilex_dojoin;
10426 PL_lex_starts = proto_perl->Ilex_starts;
10427 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
10428 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
10429 PL_lex_op = proto_perl->Ilex_op;
10430 PL_lex_inpat = proto_perl->Ilex_inpat;
10431 PL_lex_inwhat = proto_perl->Ilex_inwhat;
10432 PL_lex_brackets = proto_perl->Ilex_brackets;
10433 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
10434 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
10435 PL_lex_casemods = proto_perl->Ilex_casemods;
10436 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
10437 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
10439 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
10440 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
10441 PL_nexttoke = proto_perl->Inexttoke;
10443 /* XXX This is probably masking the deeper issue of why
10444 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
10445 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
10446 * (A little debugging with a watchpoint on it may help.)
10448 if (SvANY(proto_perl->Ilinestr)) {
10449 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
10450 i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
10451 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10452 i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
10453 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10454 i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
10455 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10456 i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
10457 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10460 PL_linestr = NEWSV(65,79);
10461 sv_upgrade(PL_linestr,SVt_PVIV);
10462 sv_setpvn(PL_linestr,"",0);
10463 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
10465 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10466 PL_pending_ident = proto_perl->Ipending_ident;
10467 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
10469 PL_expect = proto_perl->Iexpect;
10471 PL_multi_start = proto_perl->Imulti_start;
10472 PL_multi_end = proto_perl->Imulti_end;
10473 PL_multi_open = proto_perl->Imulti_open;
10474 PL_multi_close = proto_perl->Imulti_close;
10476 PL_error_count = proto_perl->Ierror_count;
10477 PL_subline = proto_perl->Isubline;
10478 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
10480 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
10481 if (SvANY(proto_perl->Ilinestr)) {
10482 i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
10483 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10484 i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
10485 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10486 PL_last_lop_op = proto_perl->Ilast_lop_op;
10489 PL_last_uni = SvPVX(PL_linestr);
10490 PL_last_lop = SvPVX(PL_linestr);
10491 PL_last_lop_op = 0;
10493 PL_in_my = proto_perl->Iin_my;
10494 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
10496 PL_cryptseen = proto_perl->Icryptseen;
10499 PL_hints = proto_perl->Ihints;
10501 PL_amagic_generation = proto_perl->Iamagic_generation;
10503 #ifdef USE_LOCALE_COLLATE
10504 PL_collation_ix = proto_perl->Icollation_ix;
10505 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
10506 PL_collation_standard = proto_perl->Icollation_standard;
10507 PL_collxfrm_base = proto_perl->Icollxfrm_base;
10508 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
10509 #endif /* USE_LOCALE_COLLATE */
10511 #ifdef USE_LOCALE_NUMERIC
10512 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
10513 PL_numeric_standard = proto_perl->Inumeric_standard;
10514 PL_numeric_local = proto_perl->Inumeric_local;
10515 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
10516 #endif /* !USE_LOCALE_NUMERIC */
10518 /* utf8 character classes */
10519 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
10520 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
10521 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
10522 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
10523 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
10524 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
10525 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
10526 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
10527 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
10528 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
10529 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
10530 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
10531 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
10532 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
10533 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
10534 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
10535 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
10536 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
10537 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
10538 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
10540 /* Did the locale setup indicate UTF-8? */
10541 PL_utf8locale = proto_perl->Iutf8locale;
10542 /* Unicode features (see perlrun/-C) */
10543 PL_unicode = proto_perl->Iunicode;
10545 /* Pre-5.8 signals control */
10546 PL_signals = proto_perl->Isignals;
10548 /* times() ticks per second */
10549 PL_clocktick = proto_perl->Iclocktick;
10551 /* Recursion stopper for PerlIO_find_layer */
10552 PL_in_load_module = proto_perl->Iin_load_module;
10554 /* sort() routine */
10555 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
10557 /* Not really needed/useful since the reenrant_retint is "volatile",
10558 * but do it for consistency's sake. */
10559 PL_reentrant_retint = proto_perl->Ireentrant_retint;
10561 /* Hooks to shared SVs and locks. */
10562 PL_sharehook = proto_perl->Isharehook;
10563 PL_lockhook = proto_perl->Ilockhook;
10564 PL_unlockhook = proto_perl->Iunlockhook;
10565 PL_threadhook = proto_perl->Ithreadhook;
10567 PL_runops_std = proto_perl->Irunops_std;
10568 PL_runops_dbg = proto_perl->Irunops_dbg;
10570 #ifdef THREADS_HAVE_PIDS
10571 PL_ppid = proto_perl->Ippid;
10575 PL_last_swash_hv = Nullhv; /* reinits on demand */
10576 PL_last_swash_klen = 0;
10577 PL_last_swash_key[0]= '\0';
10578 PL_last_swash_tmps = (U8*)NULL;
10579 PL_last_swash_slen = 0;
10581 PL_glob_index = proto_perl->Iglob_index;
10582 PL_srand_called = proto_perl->Isrand_called;
10583 PL_uudmap['M'] = 0; /* reinits on demand */
10584 PL_bitcount = Nullch; /* reinits on demand */
10586 if (proto_perl->Ipsig_pend) {
10587 Newxz(PL_psig_pend, SIG_SIZE, int);
10590 PL_psig_pend = (int*)NULL;
10593 if (proto_perl->Ipsig_ptr) {
10594 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
10595 Newxz(PL_psig_name, SIG_SIZE, SV*);
10596 for (i = 1; i < SIG_SIZE; i++) {
10597 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
10598 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
10602 PL_psig_ptr = (SV**)NULL;
10603 PL_psig_name = (SV**)NULL;
10606 /* thrdvar.h stuff */
10608 if (flags & CLONEf_COPY_STACKS) {
10609 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
10610 PL_tmps_ix = proto_perl->Ttmps_ix;
10611 PL_tmps_max = proto_perl->Ttmps_max;
10612 PL_tmps_floor = proto_perl->Ttmps_floor;
10613 Newxz(PL_tmps_stack, PL_tmps_max, SV*);
10615 while (i <= PL_tmps_ix) {
10616 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
10620 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
10621 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
10622 Newxz(PL_markstack, i, I32);
10623 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
10624 - proto_perl->Tmarkstack);
10625 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
10626 - proto_perl->Tmarkstack);
10627 Copy(proto_perl->Tmarkstack, PL_markstack,
10628 PL_markstack_ptr - PL_markstack + 1, I32);
10630 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
10631 * NOTE: unlike the others! */
10632 PL_scopestack_ix = proto_perl->Tscopestack_ix;
10633 PL_scopestack_max = proto_perl->Tscopestack_max;
10634 Newxz(PL_scopestack, PL_scopestack_max, I32);
10635 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
10637 /* NOTE: si_dup() looks at PL_markstack */
10638 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
10640 /* PL_curstack = PL_curstackinfo->si_stack; */
10641 PL_curstack = av_dup(proto_perl->Tcurstack, param);
10642 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
10644 /* next PUSHs() etc. set *(PL_stack_sp+1) */
10645 PL_stack_base = AvARRAY(PL_curstack);
10646 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
10647 - proto_perl->Tstack_base);
10648 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
10650 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
10651 * NOTE: unlike the others! */
10652 PL_savestack_ix = proto_perl->Tsavestack_ix;
10653 PL_savestack_max = proto_perl->Tsavestack_max;
10654 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
10655 PL_savestack = ss_dup(proto_perl, param);
10659 ENTER; /* perl_destruct() wants to LEAVE; */
10662 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
10663 PL_top_env = &PL_start_env;
10665 PL_op = proto_perl->Top;
10668 PL_Xpv = (XPV*)NULL;
10669 PL_na = proto_perl->Tna;
10671 PL_statbuf = proto_perl->Tstatbuf;
10672 PL_statcache = proto_perl->Tstatcache;
10673 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
10674 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
10676 PL_timesbuf = proto_perl->Ttimesbuf;
10679 PL_tainted = proto_perl->Ttainted;
10680 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
10681 PL_rs = sv_dup_inc(proto_perl->Trs, param);
10682 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
10683 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
10684 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
10685 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
10686 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
10687 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
10688 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
10690 PL_restartop = proto_perl->Trestartop;
10691 PL_in_eval = proto_perl->Tin_eval;
10692 PL_delaymagic = proto_perl->Tdelaymagic;
10693 PL_dirty = proto_perl->Tdirty;
10694 PL_localizing = proto_perl->Tlocalizing;
10696 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
10697 PL_hv_fetch_ent_mh = Nullhe;
10698 PL_modcount = proto_perl->Tmodcount;
10699 PL_lastgotoprobe = Nullop;
10700 PL_dumpindent = proto_perl->Tdumpindent;
10702 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
10703 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
10704 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
10705 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
10706 PL_efloatbuf = Nullch; /* reinits on demand */
10707 PL_efloatsize = 0; /* reinits on demand */
10711 PL_screamfirst = NULL;
10712 PL_screamnext = NULL;
10713 PL_maxscream = -1; /* reinits on demand */
10714 PL_lastscream = Nullsv;
10716 PL_watchaddr = NULL;
10717 PL_watchok = Nullch;
10719 PL_regdummy = proto_perl->Tregdummy;
10720 PL_regprecomp = Nullch;
10723 PL_colorset = 0; /* reinits PL_colors[] */
10724 /*PL_colors[6] = {0,0,0,0,0,0};*/
10725 PL_reginput = Nullch;
10726 PL_regbol = Nullch;
10727 PL_regeol = Nullch;
10728 PL_regstartp = (I32*)NULL;
10729 PL_regendp = (I32*)NULL;
10730 PL_reglastparen = (U32*)NULL;
10731 PL_reglastcloseparen = (U32*)NULL;
10732 PL_regtill = Nullch;
10733 PL_reg_start_tmp = (char**)NULL;
10734 PL_reg_start_tmpl = 0;
10735 PL_regdata = (struct reg_data*)NULL;
10738 PL_reg_eval_set = 0;
10740 PL_regprogram = (regnode*)NULL;
10742 PL_regcc = (CURCUR*)NULL;
10743 PL_reg_call_cc = (struct re_cc_state*)NULL;
10744 PL_reg_re = (regexp*)NULL;
10745 PL_reg_ganch = Nullch;
10746 PL_reg_sv = Nullsv;
10747 PL_reg_match_utf8 = FALSE;
10748 PL_reg_magic = (MAGIC*)NULL;
10750 PL_reg_oldcurpm = (PMOP*)NULL;
10751 PL_reg_curpm = (PMOP*)NULL;
10752 PL_reg_oldsaved = Nullch;
10753 PL_reg_oldsavedlen = 0;
10754 #ifdef PERL_OLD_COPY_ON_WRITE
10757 PL_reg_maxiter = 0;
10758 PL_reg_leftiter = 0;
10759 PL_reg_poscache = Nullch;
10760 PL_reg_poscache_size= 0;
10762 /* RE engine - function pointers */
10763 PL_regcompp = proto_perl->Tregcompp;
10764 PL_regexecp = proto_perl->Tregexecp;
10765 PL_regint_start = proto_perl->Tregint_start;
10766 PL_regint_string = proto_perl->Tregint_string;
10767 PL_regfree = proto_perl->Tregfree;
10769 PL_reginterp_cnt = 0;
10770 PL_reg_starttry = 0;
10772 /* Pluggable optimizer */
10773 PL_peepp = proto_perl->Tpeepp;
10775 PL_stashcache = newHV();
10777 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
10778 ptr_table_free(PL_ptr_table);
10779 PL_ptr_table = NULL;
10782 /* Call the ->CLONE method, if it exists, for each of the stashes
10783 identified by sv_dup() above.
10785 while(av_len(param->stashes) != -1) {
10786 HV* const stash = (HV*) av_shift(param->stashes);
10787 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
10788 if (cloner && GvCV(cloner)) {
10793 XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
10795 call_sv((SV*)GvCV(cloner), G_DISCARD);
10801 SvREFCNT_dec(param->stashes);
10803 /* orphaned? eg threads->new inside BEGIN or use */
10804 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
10805 (void)SvREFCNT_inc(PL_compcv);
10806 SAVEFREESV(PL_compcv);
10812 #endif /* USE_ITHREADS */
10815 =head1 Unicode Support
10817 =for apidoc sv_recode_to_utf8
10819 The encoding is assumed to be an Encode object, on entry the PV
10820 of the sv is assumed to be octets in that encoding, and the sv
10821 will be converted into Unicode (and UTF-8).
10823 If the sv already is UTF-8 (or if it is not POK), or if the encoding
10824 is not a reference, nothing is done to the sv. If the encoding is not
10825 an C<Encode::XS> Encoding object, bad things will happen.
10826 (See F<lib/encoding.pm> and L<Encode>).
10828 The PV of the sv is returned.
10833 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
10836 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
10850 Passing sv_yes is wrong - it needs to be or'ed set of constants
10851 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
10852 remove converted chars from source.
10854 Both will default the value - let them.
10856 XPUSHs(&PL_sv_yes);
10859 call_method("decode", G_SCALAR);
10863 s = SvPV_const(uni, len);
10864 if (s != SvPVX_const(sv)) {
10865 SvGROW(sv, len + 1);
10866 Move(s, SvPVX(sv), len + 1, char);
10867 SvCUR_set(sv, len);
10874 return SvPOKp(sv) ? SvPVX(sv) : NULL;
10878 =for apidoc sv_cat_decode
10880 The encoding is assumed to be an Encode object, the PV of the ssv is
10881 assumed to be octets in that encoding and decoding the input starts
10882 from the position which (PV + *offset) pointed to. The dsv will be
10883 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
10884 when the string tstr appears in decoding output or the input ends on
10885 the PV of the ssv. The value which the offset points will be modified
10886 to the last input position on the ssv.
10888 Returns TRUE if the terminator was found, else returns FALSE.
10893 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
10894 SV *ssv, int *offset, char *tstr, int tlen)
10898 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
10909 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
10910 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
10912 call_method("cat_decode", G_SCALAR);
10914 ret = SvTRUE(TOPs);
10915 *offset = SvIV(offsv);
10921 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
10926 /* ---------------------------------------------------------------------
10928 * support functions for report_uninit()
10931 /* the maxiumum size of array or hash where we will scan looking
10932 * for the undefined element that triggered the warning */
10934 #define FUV_MAX_SEARCH_SIZE 1000
10936 /* Look for an entry in the hash whose value has the same SV as val;
10937 * If so, return a mortal copy of the key. */
10940 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
10943 register HE **array;
10946 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
10947 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
10950 array = HvARRAY(hv);
10952 for (i=HvMAX(hv); i>0; i--) {
10953 register HE *entry;
10954 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
10955 if (HeVAL(entry) != val)
10957 if ( HeVAL(entry) == &PL_sv_undef ||
10958 HeVAL(entry) == &PL_sv_placeholder)
10962 if (HeKLEN(entry) == HEf_SVKEY)
10963 return sv_mortalcopy(HeKEY_sv(entry));
10964 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
10970 /* Look for an entry in the array whose value has the same SV as val;
10971 * If so, return the index, otherwise return -1. */
10974 S_find_array_subscript(pTHX_ AV *av, SV* val)
10978 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
10979 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
10983 for (i=AvFILLp(av); i>=0; i--) {
10984 if (svp[i] == val && svp[i] != &PL_sv_undef)
10990 /* S_varname(): return the name of a variable, optionally with a subscript.
10991 * If gv is non-zero, use the name of that global, along with gvtype (one
10992 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
10993 * targ. Depending on the value of the subscript_type flag, return:
10996 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
10997 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
10998 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
10999 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
11002 S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
11003 SV* keyname, I32 aindex, int subscript_type)
11006 SV * const name = sv_newmortal();
11009 buffer[0] = gvtype;
11012 /* as gv_fullname4(), but add literal '^' for $^FOO names */
11014 gv_fullname4(name, gv, buffer, 0);
11016 if ((unsigned int)SvPVX(name)[1] <= 26) {
11018 buffer[1] = SvPVX(name)[1] + 'A' - 1;
11020 /* Swap the 1 unprintable control character for the 2 byte pretty
11021 version - ie substr($name, 1, 1) = $buffer; */
11022 sv_insert(name, 1, 1, buffer, 2);
11027 CV * const cv = find_runcv(&unused);
11031 if (!cv || !CvPADLIST(cv))
11033 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
11034 sv = *av_fetch(av, targ, FALSE);
11035 /* SvLEN in a pad name is not to be trusted */
11036 sv_setpv(name, SvPV_nolen_const(sv));
11039 if (subscript_type == FUV_SUBSCRIPT_HASH) {
11040 SV * const sv = NEWSV(0,0);
11041 *SvPVX(name) = '$';
11042 Perl_sv_catpvf(aTHX_ name, "{%s}",
11043 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
11046 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
11047 *SvPVX(name) = '$';
11048 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
11050 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
11051 sv_insert(name, 0, 0, "within ", 7);
11058 =for apidoc find_uninit_var
11060 Find the name of the undefined variable (if any) that caused the operator o
11061 to issue a "Use of uninitialized value" warning.
11062 If match is true, only return a name if it's value matches uninit_sv.
11063 So roughly speaking, if a unary operator (such as OP_COS) generates a
11064 warning, then following the direct child of the op may yield an
11065 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
11066 other hand, with OP_ADD there are two branches to follow, so we only print
11067 the variable name if we get an exact match.
11069 The name is returned as a mortal SV.
11071 Assumes that PL_op is the op that originally triggered the error, and that
11072 PL_comppad/PL_curpad points to the currently executing pad.
11078 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
11086 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
11087 uninit_sv == &PL_sv_placeholder)))
11090 switch (obase->op_type) {
11097 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
11098 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
11100 SV *keysv = Nullsv;
11101 int subscript_type = FUV_SUBSCRIPT_WITHIN;
11103 if (pad) { /* @lex, %lex */
11104 sv = PAD_SVl(obase->op_targ);
11108 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
11109 /* @global, %global */
11110 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
11113 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
11115 else /* @{expr}, %{expr} */
11116 return find_uninit_var(cUNOPx(obase)->op_first,
11120 /* attempt to find a match within the aggregate */
11122 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
11124 subscript_type = FUV_SUBSCRIPT_HASH;
11127 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
11129 subscript_type = FUV_SUBSCRIPT_ARRAY;
11132 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
11135 return varname(gv, hash ? '%' : '@', obase->op_targ,
11136 keysv, index, subscript_type);
11140 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
11142 return varname(Nullgv, '$', obase->op_targ,
11143 Nullsv, 0, FUV_SUBSCRIPT_NONE);
11146 gv = cGVOPx_gv(obase);
11147 if (!gv || (match && GvSV(gv) != uninit_sv))
11149 return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
11152 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
11155 av = (AV*)PAD_SV(obase->op_targ);
11156 if (!av || SvRMAGICAL(av))
11158 svp = av_fetch(av, (I32)obase->op_private, FALSE);
11159 if (!svp || *svp != uninit_sv)
11162 return varname(Nullgv, '$', obase->op_targ,
11163 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
11166 gv = cGVOPx_gv(obase);
11172 if (!av || SvRMAGICAL(av))
11174 svp = av_fetch(av, (I32)obase->op_private, FALSE);
11175 if (!svp || *svp != uninit_sv)
11178 return varname(gv, '$', 0,
11179 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
11184 o = cUNOPx(obase)->op_first;
11185 if (!o || o->op_type != OP_NULL ||
11186 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
11188 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
11192 if (PL_op == obase)
11193 /* $a[uninit_expr] or $h{uninit_expr} */
11194 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
11197 o = cBINOPx(obase)->op_first;
11198 kid = cBINOPx(obase)->op_last;
11200 /* get the av or hv, and optionally the gv */
11202 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
11203 sv = PAD_SV(o->op_targ);
11205 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
11206 && cUNOPo->op_first->op_type == OP_GV)
11208 gv = cGVOPx_gv(cUNOPo->op_first);
11211 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
11216 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
11217 /* index is constant */
11221 if (obase->op_type == OP_HELEM) {
11222 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
11223 if (!he || HeVAL(he) != uninit_sv)
11227 SV * const * const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
11228 if (!svp || *svp != uninit_sv)
11232 if (obase->op_type == OP_HELEM)
11233 return varname(gv, '%', o->op_targ,
11234 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
11236 return varname(gv, '@', o->op_targ, Nullsv,
11237 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
11240 /* index is an expression;
11241 * attempt to find a match within the aggregate */
11242 if (obase->op_type == OP_HELEM) {
11243 SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
11245 return varname(gv, '%', o->op_targ,
11246 keysv, 0, FUV_SUBSCRIPT_HASH);
11249 const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
11251 return varname(gv, '@', o->op_targ,
11252 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
11257 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
11259 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
11265 /* only examine RHS */
11266 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
11269 o = cUNOPx(obase)->op_first;
11270 if (o->op_type == OP_PUSHMARK)
11273 if (!o->op_sibling) {
11274 /* one-arg version of open is highly magical */
11276 if (o->op_type == OP_GV) { /* open FOO; */
11278 if (match && GvSV(gv) != uninit_sv)
11280 return varname(gv, '$', 0,
11281 Nullsv, 0, FUV_SUBSCRIPT_NONE);
11283 /* other possibilities not handled are:
11284 * open $x; or open my $x; should return '${*$x}'
11285 * open expr; should return '$'.expr ideally
11291 /* ops where $_ may be an implicit arg */
11295 if ( !(obase->op_flags & OPf_STACKED)) {
11296 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
11297 ? PAD_SVl(obase->op_targ)
11300 sv = sv_newmortal();
11301 sv_setpvn(sv, "$_", 2);
11309 /* skip filehandle as it can't produce 'undef' warning */
11310 o = cUNOPx(obase)->op_first;
11311 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
11312 o = o->op_sibling->op_sibling;
11319 match = 1; /* XS or custom code could trigger random warnings */
11324 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
11325 return sv_2mortal(newSVpvn("${$/}", 5));
11330 if (!(obase->op_flags & OPf_KIDS))
11332 o = cUNOPx(obase)->op_first;
11338 /* if all except one arg are constant, or have no side-effects,
11339 * or are optimized away, then it's unambiguous */
11341 for (kid=o; kid; kid = kid->op_sibling) {
11343 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
11344 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
11345 || (kid->op_type == OP_PUSHMARK)
11349 if (o2) { /* more than one found */
11356 return find_uninit_var(o2, uninit_sv, match);
11358 /* scan all args */
11360 sv = find_uninit_var(o, uninit_sv, 1);
11372 =for apidoc report_uninit
11374 Print appropriate "Use of uninitialized variable" warning
11380 Perl_report_uninit(pTHX_ SV* uninit_sv)
11383 SV* varname = Nullsv;
11385 varname = find_uninit_var(PL_op, uninit_sv,0);
11387 sv_insert(varname, 0, 0, " ", 1);
11389 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
11390 varname ? SvPV_nolen_const(varname) : "",
11391 " in ", OP_DESC(PL_op));
11394 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
11400 * c-indentation-style: bsd
11401 * c-basic-offset: 4
11402 * indent-tabs-mode: t
11405 * ex: set ts=8 sts=4 sw=4 noet: