3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'I wonder what the Entish is for "yes" and "no",' he thought.
16 * [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
22 * This file contains the code that creates, manipulates and destroys
23 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
24 * structure of an SV, so their creation and destruction is handled
25 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
26 * level functions (eg. substr, split, join) for each of the types are
38 /* Missing proto on LynxOS */
39 char *gconvert(double, int, int, char *);
42 #ifdef PERL_UTF8_CACHE_ASSERT
43 /* if adding more checks watch out for the following tests:
44 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
45 * lib/utf8.t lib/Unicode/Collate/t/index.t
48 # define ASSERT_UTF8_CACHE(cache) \
49 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
50 assert((cache)[2] <= (cache)[3]); \
51 assert((cache)[3] <= (cache)[1]);} \
54 # define ASSERT_UTF8_CACHE(cache) NOOP
57 #ifdef PERL_OLD_COPY_ON_WRITE
58 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
59 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
60 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
64 /* ============================================================================
66 =head1 Allocation and deallocation of SVs.
68 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
69 sv, av, hv...) contains type and reference count information, and for
70 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
71 contains fields specific to each type. Some types store all they need
72 in the head, so don't have a body.
74 In all but the most memory-paranoid configuations (ex: PURIFY), heads
75 and bodies are allocated out of arenas, which by default are
76 approximately 4K chunks of memory parcelled up into N heads or bodies.
77 Sv-bodies are allocated by their sv-type, guaranteeing size
78 consistency needed to allocate safely from arrays.
80 For SV-heads, the first slot in each arena is reserved, and holds a
81 link to the next arena, some flags, and a note of the number of slots.
82 Snaked through each arena chain is a linked list of free items; when
83 this becomes empty, an extra arena is allocated and divided up into N
84 items which are threaded into the free list.
86 SV-bodies are similar, but they use arena-sets by default, which
87 separate the link and info from the arena itself, and reclaim the 1st
88 slot in the arena. SV-bodies are further described later.
90 The following global variables are associated with arenas:
92 PL_sv_arenaroot pointer to list of SV arenas
93 PL_sv_root pointer to list of free SV structures
95 PL_body_arenas head of linked-list of body arenas
96 PL_body_roots[] array of pointers to list of free bodies of svtype
97 arrays are indexed by the svtype needed
99 A few special SV heads are not allocated from an arena, but are
100 instead directly created in the interpreter structure, eg PL_sv_undef.
101 The size of arenas can be changed from the default by setting
102 PERL_ARENA_SIZE appropriately at compile time.
104 The SV arena serves the secondary purpose of allowing still-live SVs
105 to be located and destroyed during final cleanup.
107 At the lowest level, the macros new_SV() and del_SV() grab and free
108 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
109 to return the SV to the free list with error checking.) new_SV() calls
110 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
111 SVs in the free list have their SvTYPE field set to all ones.
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 The function visit() scans the SV arenas list, and calls a specified
118 function for each SV it finds which is still live - ie which has an SvTYPE
119 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
120 following functions (specified as [function that calls visit()] / [function
121 called by visit() for each SV]):
123 sv_report_used() / do_report_used()
124 dump all remaining SVs (debugging aid)
126 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
127 Attempt to free all objects pointed to by RVs,
128 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
129 try to do the same for all objects indirectly
130 referenced by typeglobs too. Called once from
131 perl_destruct(), prior to calling sv_clean_all()
134 sv_clean_all() / do_clean_all()
135 SvREFCNT_dec(sv) each remaining SV, possibly
136 triggering an sv_free(). It also sets the
137 SVf_BREAK flag on the SV to indicate that the
138 refcnt has been artificially lowered, and thus
139 stopping sv_free() from giving spurious warnings
140 about SVs which unexpectedly have a refcnt
141 of zero. called repeatedly from perl_destruct()
142 until there are no SVs left.
144 =head2 Arena allocator API Summary
146 Private API to rest of sv.c
150 new_XIV(), del_XIV(),
151 new_XNV(), del_XNV(),
156 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
160 * ========================================================================= */
163 * "A time to plant, and a time to uproot what was planted..."
167 Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size)
173 PERL_ARGS_ASSERT_OFFER_NICE_CHUNK;
175 new_chunk = (void *)(chunk);
176 new_chunk_size = (chunk_size);
177 if (new_chunk_size > PL_nice_chunk_size) {
178 Safefree(PL_nice_chunk);
179 PL_nice_chunk = (char *) new_chunk;
180 PL_nice_chunk_size = new_chunk_size;
187 # define MEM_LOG_NEW_SV(sv, file, line, func) \
188 Perl_mem_log_new_sv(sv, file, line, func)
189 # define MEM_LOG_DEL_SV(sv, file, line, func) \
190 Perl_mem_log_del_sv(sv, file, line, func)
192 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
193 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
196 #ifdef DEBUG_LEAKING_SCALARS
197 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
198 # define DEBUG_SV_SERIAL(sv) \
199 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
200 PTR2UV(sv), (long)(sv)->sv_debug_serial))
202 # define FREE_SV_DEBUG_FILE(sv)
203 # define DEBUG_SV_SERIAL(sv) NOOP
207 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
208 # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
209 /* Whilst I'd love to do this, it seems that things like to check on
211 # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
213 # define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
214 PoisonNew(&SvREFCNT(sv), 1, U32)
216 # define SvARENA_CHAIN(sv) SvANY(sv)
217 # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
218 # define POSION_SV_HEAD(sv)
221 /* Mark an SV head as unused, and add to free list.
223 * If SVf_BREAK is set, skip adding it to the free list, as this SV had
224 * its refcount artificially decremented during global destruction, so
225 * there may be dangling pointers to it. The last thing we want in that
226 * case is for it to be reused. */
228 #define plant_SV(p) \
230 const U32 old_flags = SvFLAGS(p); \
231 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
232 DEBUG_SV_SERIAL(p); \
233 FREE_SV_DEBUG_FILE(p); \
235 SvFLAGS(p) = SVTYPEMASK; \
236 if (!(old_flags & SVf_BREAK)) { \
237 SvARENA_CHAIN_SET(p, PL_sv_root); \
243 #define uproot_SV(p) \
246 PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
251 /* make some more SVs by adding another arena */
260 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
261 PL_nice_chunk = NULL;
262 PL_nice_chunk_size = 0;
265 char *chunk; /* must use New here to match call to */
266 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
267 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
273 /* new_SV(): return a new, empty SV head */
275 #ifdef DEBUG_LEAKING_SCALARS
276 /* provide a real function for a debugger to play with */
278 S_new_SV(pTHX_ const char *file, int line, const char *func)
285 sv = S_more_sv(aTHX);
289 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
290 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
296 sv->sv_debug_inpad = 0;
297 sv->sv_debug_cloned = 0;
298 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
300 sv->sv_debug_serial = PL_sv_serial++;
302 MEM_LOG_NEW_SV(sv, file, line, func);
303 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
304 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
308 # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
316 (p) = S_more_sv(aTHX); \
320 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
325 /* del_SV(): return an empty SV head to the free list */
338 S_del_sv(pTHX_ SV *p)
342 PERL_ARGS_ASSERT_DEL_SV;
347 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
348 const SV * const sv = sva + 1;
349 const SV * const svend = &sva[SvREFCNT(sva)];
350 if (p >= sv && p < svend) {
356 if (ckWARN_d(WARN_INTERNAL))
357 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
358 "Attempt to free non-arena SV: 0x%"UVxf
359 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
366 #else /* ! DEBUGGING */
368 #define del_SV(p) plant_SV(p)
370 #endif /* DEBUGGING */
374 =head1 SV Manipulation Functions
376 =for apidoc sv_add_arena
378 Given a chunk of memory, link it to the head of the list of arenas,
379 and split it into a list of free SVs.
385 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
388 SV *const sva = MUTABLE_SV(ptr);
392 PERL_ARGS_ASSERT_SV_ADD_ARENA;
394 /* The first SV in an arena isn't an SV. */
395 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
396 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
397 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
399 PL_sv_arenaroot = sva;
400 PL_sv_root = sva + 1;
402 svend = &sva[SvREFCNT(sva) - 1];
405 SvARENA_CHAIN_SET(sv, (sv + 1));
409 /* Must always set typemask because it's always checked in on cleanup
410 when the arenas are walked looking for objects. */
411 SvFLAGS(sv) = SVTYPEMASK;
414 SvARENA_CHAIN_SET(sv, 0);
418 SvFLAGS(sv) = SVTYPEMASK;
421 /* visit(): call the named function for each non-free SV in the arenas
422 * whose flags field matches the flags/mask args. */
425 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
431 PERL_ARGS_ASSERT_VISIT;
433 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
434 register const SV * const svend = &sva[SvREFCNT(sva)];
436 for (sv = sva + 1; sv < svend; ++sv) {
437 if (SvTYPE(sv) != SVTYPEMASK
438 && (sv->sv_flags & mask) == flags
451 /* called by sv_report_used() for each live SV */
454 do_report_used(pTHX_ SV *const sv)
456 if (SvTYPE(sv) != SVTYPEMASK) {
457 PerlIO_printf(Perl_debug_log, "****\n");
464 =for apidoc sv_report_used
466 Dump the contents of all SVs not yet freed. (Debugging aid).
472 Perl_sv_report_used(pTHX)
475 visit(do_report_used, 0, 0);
481 /* called by sv_clean_objs() for each live SV */
484 do_clean_objs(pTHX_ SV *const ref)
489 SV * const target = SvRV(ref);
490 if (SvOBJECT(target)) {
491 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
492 if (SvWEAKREF(ref)) {
493 sv_del_backref(target, ref);
499 SvREFCNT_dec(target);
504 /* XXX Might want to check arrays, etc. */
507 /* called by sv_clean_objs() for each live SV */
509 #ifndef DISABLE_DESTRUCTOR_KLUDGE
511 do_clean_named_objs(pTHX_ SV *const sv)
514 assert(SvTYPE(sv) == SVt_PVGV);
515 assert(isGV_with_GP(sv));
518 #ifdef PERL_DONT_CREATE_GVSV
521 SvOBJECT(GvSV(sv))) ||
522 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
523 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
524 /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */
525 (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) ||
526 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
528 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
529 SvFLAGS(sv) |= SVf_BREAK;
537 =for apidoc sv_clean_objs
539 Attempt to destroy all objects not yet freed
545 Perl_sv_clean_objs(pTHX)
548 PL_in_clean_objs = TRUE;
549 visit(do_clean_objs, SVf_ROK, SVf_ROK);
550 #ifndef DISABLE_DESTRUCTOR_KLUDGE
551 /* some barnacles may yet remain, clinging to typeglobs */
552 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
554 PL_in_clean_objs = FALSE;
557 /* called by sv_clean_all() for each live SV */
560 do_clean_all(pTHX_ SV *const sv)
563 if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
564 /* don't clean pid table and strtab */
567 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
568 SvFLAGS(sv) |= SVf_BREAK;
573 =for apidoc sv_clean_all
575 Decrement the refcnt of each remaining SV, possibly triggering a
576 cleanup. This function may have to be called multiple times to free
577 SVs which are in complex self-referential hierarchies.
583 Perl_sv_clean_all(pTHX)
587 PL_in_clean_all = TRUE;
588 cleaned = visit(do_clean_all, 0,0);
589 PL_in_clean_all = FALSE;
594 ARENASETS: a meta-arena implementation which separates arena-info
595 into struct arena_set, which contains an array of struct
596 arena_descs, each holding info for a single arena. By separating
597 the meta-info from the arena, we recover the 1st slot, formerly
598 borrowed for list management. The arena_set is about the size of an
599 arena, avoiding the needless malloc overhead of a naive linked-list.
601 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
602 memory in the last arena-set (1/2 on average). In trade, we get
603 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
604 smaller types). The recovery of the wasted space allows use of
605 small arenas for large, rare body types, by changing array* fields
606 in body_details_by_type[] below.
609 char *arena; /* the raw storage, allocated aligned */
610 size_t size; /* its size ~4k typ */
611 U32 misc; /* type, and in future other things. */
616 /* Get the maximum number of elements in set[] such that struct arena_set
617 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
618 therefore likely to be 1 aligned memory page. */
620 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
621 - 2 * sizeof(int)) / sizeof (struct arena_desc))
624 struct arena_set* next;
625 unsigned int set_size; /* ie ARENAS_PER_SET */
626 unsigned int curr; /* index of next available arena-desc */
627 struct arena_desc set[ARENAS_PER_SET];
631 =for apidoc sv_free_arenas
633 Deallocate the memory used by all arenas. Note that all the individual SV
634 heads and bodies within the arenas must already have been freed.
639 Perl_sv_free_arenas(pTHX)
646 /* Free arenas here, but be careful about fake ones. (We assume
647 contiguity of the fake ones with the corresponding real ones.) */
649 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
650 svanext = MUTABLE_SV(SvANY(sva));
651 while (svanext && SvFAKE(svanext))
652 svanext = MUTABLE_SV(SvANY(svanext));
659 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
662 struct arena_set *current = aroot;
665 assert(aroot->set[i].arena);
666 Safefree(aroot->set[i].arena);
674 i = PERL_ARENA_ROOTS_SIZE;
676 PL_body_roots[i] = 0;
678 Safefree(PL_nice_chunk);
679 PL_nice_chunk = NULL;
680 PL_nice_chunk_size = 0;
686 Here are mid-level routines that manage the allocation of bodies out
687 of the various arenas. There are 5 kinds of arenas:
689 1. SV-head arenas, which are discussed and handled above
690 2. regular body arenas
691 3. arenas for reduced-size bodies
693 5. pte arenas (thread related)
695 Arena types 2 & 3 are chained by body-type off an array of
696 arena-root pointers, which is indexed by svtype. Some of the
697 larger/less used body types are malloced singly, since a large
698 unused block of them is wasteful. Also, several svtypes dont have
699 bodies; the data fits into the sv-head itself. The arena-root
700 pointer thus has a few unused root-pointers (which may be hijacked
701 later for arena types 4,5)
703 3 differs from 2 as an optimization; some body types have several
704 unused fields in the front of the structure (which are kept in-place
705 for consistency). These bodies can be allocated in smaller chunks,
706 because the leading fields arent accessed. Pointers to such bodies
707 are decremented to point at the unused 'ghost' memory, knowing that
708 the pointers are used with offsets to the real memory.
710 HE, HEK arenas are managed separately, with separate code, but may
711 be merge-able later..
713 PTE arenas are not sv-bodies, but they share these mid-level
714 mechanics, so are considered here. The new mid-level mechanics rely
715 on the sv_type of the body being allocated, so we just reserve one
716 of the unused body-slots for PTEs, then use it in those (2) PTE
717 contexts below (line ~10k)
720 /* get_arena(size): this creates custom-sized arenas
721 TBD: export properly for hv.c: S_more_he().
724 Perl_get_arena(pTHX_ const size_t arena_size, const U32 misc)
727 struct arena_desc* adesc;
728 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
731 /* shouldnt need this
732 if (!arena_size) arena_size = PERL_ARENA_SIZE;
735 /* may need new arena-set to hold new arena */
736 if (!aroot || aroot->curr >= aroot->set_size) {
737 struct arena_set *newroot;
738 Newxz(newroot, 1, struct arena_set);
739 newroot->set_size = ARENAS_PER_SET;
740 newroot->next = aroot;
742 PL_body_arenas = (void *) newroot;
743 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
746 /* ok, now have arena-set with at least 1 empty/available arena-desc */
747 curr = aroot->curr++;
748 adesc = &(aroot->set[curr]);
749 assert(!adesc->arena);
751 Newx(adesc->arena, arena_size, char);
752 adesc->size = arena_size;
754 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
755 curr, (void*)adesc->arena, (UV)arena_size));
761 /* return a thing to the free list */
763 #define del_body(thing, root) \
765 void ** const thing_copy = (void **)thing;\
766 *thing_copy = *root; \
767 *root = (void*)thing_copy; \
772 =head1 SV-Body Allocation
774 Allocation of SV-bodies is similar to SV-heads, differing as follows;
775 the allocation mechanism is used for many body types, so is somewhat
776 more complicated, it uses arena-sets, and has no need for still-live
779 At the outermost level, (new|del)_X*V macros return bodies of the
780 appropriate type. These macros call either (new|del)_body_type or
781 (new|del)_body_allocated macro pairs, depending on specifics of the
782 type. Most body types use the former pair, the latter pair is used to
783 allocate body types with "ghost fields".
785 "ghost fields" are fields that are unused in certain types, and
786 consequently dont need to actually exist. They are declared because
787 they're part of a "base type", which allows use of functions as
788 methods. The simplest examples are AVs and HVs, 2 aggregate types
789 which don't use the fields which support SCALAR semantics.
791 For these types, the arenas are carved up into *_allocated size
792 chunks, we thus avoid wasted memory for those unaccessed members.
793 When bodies are allocated, we adjust the pointer back in memory by the
794 size of the bit not allocated, so it's as if we allocated the full
795 structure. (But things will all go boom if you write to the part that
796 is "not there", because you'll be overwriting the last members of the
797 preceding structure in memory.)
799 We calculate the correction using the STRUCT_OFFSET macro. For
800 example, if xpv_allocated is the same structure as XPV then the two
801 OFFSETs sum to zero, and the pointer is unchanged. If the allocated
802 structure is smaller (no initial NV actually allocated) then the net
803 effect is to subtract the size of the NV from the pointer, to return a
804 new pointer as if an initial NV were actually allocated.
806 This is the same trick as was used for NV and IV bodies. Ironically it
807 doesn't need to be used for NV bodies any more, because NV is now at
808 the start of the structure. IV bodies don't need it either, because
809 they are no longer allocated.
811 In turn, the new_body_* allocators call S_new_body(), which invokes
812 new_body_inline macro, which takes a lock, and takes a body off the
813 linked list at PL_body_roots[sv_type], calling S_more_bodies() if
814 necessary to refresh an empty list. Then the lock is released, and
815 the body is returned.
817 S_more_bodies calls get_arena(), and carves it up into an array of N
818 bodies, which it strings into a linked list. It looks up arena-size
819 and body-size from the body_details table described below, thus
820 supporting the multiple body-types.
822 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
823 the (new|del)_X*V macros are mapped directly to malloc/free.
829 For each sv-type, struct body_details bodies_by_type[] carries
830 parameters which control these aspects of SV handling:
832 Arena_size determines whether arenas are used for this body type, and if
833 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
834 zero, forcing individual mallocs and frees.
836 Body_size determines how big a body is, and therefore how many fit into
837 each arena. Offset carries the body-pointer adjustment needed for
838 *_allocated body types, and is used in *_allocated macros.
840 But its main purpose is to parameterize info needed in
841 Perl_sv_upgrade(). The info here dramatically simplifies the function
842 vs the implementation in 5.8.7, making it table-driven. All fields
843 are used for this, except for arena_size.
845 For the sv-types that have no bodies, arenas are not used, so those
846 PL_body_roots[sv_type] are unused, and can be overloaded. In
847 something of a special case, SVt_NULL is borrowed for HE arenas;
848 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
849 bodies_by_type[SVt_NULL] slot is not used, as the table is not
852 PTEs also use arenas, but are never seen in Perl_sv_upgrade. Nonetheless,
853 they get their own slot in bodies_by_type[PTE_SVSLOT =SVt_IV], so they can
854 just use the same allocation semantics. At first, PTEs were also
855 overloaded to a non-body sv-type, but this yielded hard-to-find malloc
856 bugs, so was simplified by claiming a new slot. This choice has no
857 consequence at this time.
861 struct body_details {
862 U8 body_size; /* Size to allocate */
863 U8 copy; /* Size of structure to copy (may be shorter) */
865 unsigned int type : 4; /* We have space for a sanity check. */
866 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
867 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
868 unsigned int arena : 1; /* Allocated from an arena */
869 size_t arena_size; /* Size of arena to allocate */
877 /* With -DPURFIY we allocate everything directly, and don't use arenas.
878 This seems a rather elegant way to simplify some of the code below. */
879 #define HASARENA FALSE
881 #define HASARENA TRUE
883 #define NOARENA FALSE
885 /* Size the arenas to exactly fit a given number of bodies. A count
886 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
887 simplifying the default. If count > 0, the arena is sized to fit
888 only that many bodies, allowing arenas to be used for large, rare
889 bodies (XPVFM, XPVIO) without undue waste. The arena size is
890 limited by PERL_ARENA_SIZE, so we can safely oversize the
893 #define FIT_ARENA0(body_size) \
894 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
895 #define FIT_ARENAn(count,body_size) \
896 ( count * body_size <= PERL_ARENA_SIZE) \
897 ? count * body_size \
898 : FIT_ARENA0 (body_size)
899 #define FIT_ARENA(count,body_size) \
901 ? FIT_ARENAn (count, body_size) \
902 : FIT_ARENA0 (body_size)
904 /* A macro to work out the offset needed to subtract from a pointer to (say)
911 to make its members accessible via a pointer to (say)
921 #define relative_STRUCT_OFFSET(longer, shorter, member) \
922 (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
924 /* Calculate the length to copy. Specifically work out the length less any
925 final padding the compiler needed to add. See the comment in sv_upgrade
926 for why copying the padding proved to be a bug. */
928 #define copy_length(type, last_member) \
929 STRUCT_OFFSET(type, last_member) \
930 + sizeof (((type*)SvANY((const SV *)0))->last_member)
932 static const struct body_details bodies_by_type[] = {
933 { sizeof(HE), 0, 0, SVt_NULL,
934 FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
936 /* The bind placeholder pretends to be an RV for now.
937 Also it's marked as "can't upgrade" to stop anyone using it before it's
939 { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
941 /* IVs are in the head, so the allocation size is 0.
942 However, the slot is overloaded for PTEs. */
943 { sizeof(struct ptr_tbl_ent), /* This is used for PTEs. */
944 sizeof(IV), /* This is used to copy out the IV body. */
945 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
946 NOARENA /* IVS don't need an arena */,
947 /* But PTEs need to know the size of their arena */
948 FIT_ARENA(0, sizeof(struct ptr_tbl_ent))
951 /* 8 bytes on most ILP32 with IEEE doubles */
952 { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA,
953 FIT_ARENA(0, sizeof(NV)) },
955 /* 8 bytes on most ILP32 with IEEE doubles */
956 { sizeof(xpv_allocated),
957 copy_length(XPV, xpv_len)
958 - relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
959 + relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
960 SVt_PV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpv_allocated)) },
963 { sizeof(xpviv_allocated),
964 copy_length(XPVIV, xiv_u)
965 - relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
966 + relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
967 SVt_PVIV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpviv_allocated)) },
970 { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV,
971 HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
974 { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
975 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
978 { sizeof(struct regexp_allocated), sizeof(struct regexp_allocated),
979 + relative_STRUCT_OFFSET(struct regexp_allocated, regexp, xpv_cur),
980 SVt_REGEXP, FALSE, NONV, HASARENA,
981 FIT_ARENA(0, sizeof(struct regexp_allocated))
985 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
986 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
989 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
990 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
992 { sizeof(xpvav_allocated),
993 copy_length(XPVAV, xmg_stash)
994 - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
995 + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
996 SVt_PVAV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
998 { sizeof(xpvhv_allocated),
999 copy_length(XPVHV, xmg_stash)
1000 - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
1001 + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
1002 SVt_PVHV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
1005 { sizeof(xpvcv_allocated), sizeof(xpvcv_allocated),
1006 + relative_STRUCT_OFFSET(xpvcv_allocated, XPVCV, xpv_cur),
1007 SVt_PVCV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvcv_allocated)) },
1009 { sizeof(xpvfm_allocated), sizeof(xpvfm_allocated),
1010 + relative_STRUCT_OFFSET(xpvfm_allocated, XPVFM, xpv_cur),
1011 SVt_PVFM, TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) },
1013 /* XPVIO is 84 bytes, fits 48x */
1014 { sizeof(xpvio_allocated), sizeof(xpvio_allocated),
1015 + relative_STRUCT_OFFSET(xpvio_allocated, XPVIO, xpv_cur),
1016 SVt_PVIO, TRUE, NONV, HASARENA, FIT_ARENA(24, sizeof(xpvio_allocated)) },
1019 #define new_body_type(sv_type) \
1020 (void *)((char *)S_new_body(aTHX_ sv_type))
1022 #define del_body_type(p, sv_type) \
1023 del_body(p, &PL_body_roots[sv_type])
1026 #define new_body_allocated(sv_type) \
1027 (void *)((char *)S_new_body(aTHX_ sv_type) \
1028 - bodies_by_type[sv_type].offset)
1030 #define del_body_allocated(p, sv_type) \
1031 del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
1034 #define my_safemalloc(s) (void*)safemalloc(s)
1035 #define my_safecalloc(s) (void*)safecalloc(s, 1)
1036 #define my_safefree(p) safefree((char*)p)
1040 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1041 #define del_XNV(p) my_safefree(p)
1043 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1044 #define del_XPVNV(p) my_safefree(p)
1046 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1047 #define del_XPVAV(p) my_safefree(p)
1049 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1050 #define del_XPVHV(p) my_safefree(p)
1052 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1053 #define del_XPVMG(p) my_safefree(p)
1055 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1056 #define del_XPVGV(p) my_safefree(p)
1060 #define new_XNV() new_body_type(SVt_NV)
1061 #define del_XNV(p) del_body_type(p, SVt_NV)
1063 #define new_XPVNV() new_body_type(SVt_PVNV)
1064 #define del_XPVNV(p) del_body_type(p, SVt_PVNV)
1066 #define new_XPVAV() new_body_allocated(SVt_PVAV)
1067 #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
1069 #define new_XPVHV() new_body_allocated(SVt_PVHV)
1070 #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
1072 #define new_XPVMG() new_body_type(SVt_PVMG)
1073 #define del_XPVMG(p) del_body_type(p, SVt_PVMG)
1075 #define new_XPVGV() new_body_type(SVt_PVGV)
1076 #define del_XPVGV(p) del_body_type(p, SVt_PVGV)
1080 /* no arena for you! */
1082 #define new_NOARENA(details) \
1083 my_safemalloc((details)->body_size + (details)->offset)
1084 #define new_NOARENAZ(details) \
1085 my_safecalloc((details)->body_size + (details)->offset)
1088 S_more_bodies (pTHX_ const svtype sv_type)
1091 void ** const root = &PL_body_roots[sv_type];
1092 const struct body_details * const bdp = &bodies_by_type[sv_type];
1093 const size_t body_size = bdp->body_size;
1096 const size_t arena_size = Perl_malloc_good_size(bdp->arena_size);
1097 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1098 static bool done_sanity_check;
1100 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1101 * variables like done_sanity_check. */
1102 if (!done_sanity_check) {
1103 unsigned int i = SVt_LAST;
1105 done_sanity_check = TRUE;
1108 assert (bodies_by_type[i].type == i);
1112 assert(bdp->arena_size);
1114 start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type);
1116 end = start + arena_size - 2 * body_size;
1118 /* computed count doesnt reflect the 1st slot reservation */
1119 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1120 DEBUG_m(PerlIO_printf(Perl_debug_log,
1121 "arena %p end %p arena-size %d (from %d) type %d "
1123 (void*)start, (void*)end, (int)arena_size,
1124 (int)bdp->arena_size, sv_type, (int)body_size,
1125 (int)arena_size / (int)body_size));
1127 DEBUG_m(PerlIO_printf(Perl_debug_log,
1128 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1129 (void*)start, (void*)end,
1130 (int)bdp->arena_size, sv_type, (int)body_size,
1131 (int)bdp->arena_size / (int)body_size));
1133 *root = (void *)start;
1135 while (start <= end) {
1136 char * const next = start + body_size;
1137 *(void**) start = (void *)next;
1140 *(void **)start = 0;
1145 /* grab a new thing from the free list, allocating more if necessary.
1146 The inline version is used for speed in hot routines, and the
1147 function using it serves the rest (unless PURIFY).
1149 #define new_body_inline(xpv, sv_type) \
1151 void ** const r3wt = &PL_body_roots[sv_type]; \
1152 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1153 ? *((void **)(r3wt)) : more_bodies(sv_type)); \
1154 *(r3wt) = *(void**)(xpv); \
1160 S_new_body(pTHX_ const svtype sv_type)
1164 new_body_inline(xpv, sv_type);
1170 static const struct body_details fake_rv =
1171 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1174 =for apidoc sv_upgrade
1176 Upgrade an SV to a more complex form. Generally adds a new body type to the
1177 SV, then copies across as much information as possible from the old body.
1178 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1184 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1189 const svtype old_type = SvTYPE(sv);
1190 const struct body_details *new_type_details;
1191 const struct body_details *old_type_details
1192 = bodies_by_type + old_type;
1193 SV *referant = NULL;
1195 PERL_ARGS_ASSERT_SV_UPGRADE;
1197 if (new_type != SVt_PV && SvIsCOW(sv)) {
1198 sv_force_normal_flags(sv, 0);
1201 if (old_type == new_type)
1204 old_body = SvANY(sv);
1206 /* Copying structures onto other structures that have been neatly zeroed
1207 has a subtle gotcha. Consider XPVMG
1209 +------+------+------+------+------+-------+-------+
1210 | NV | CUR | LEN | IV | MAGIC | STASH |
1211 +------+------+------+------+------+-------+-------+
1212 0 4 8 12 16 20 24 28
1214 where NVs are aligned to 8 bytes, so that sizeof that structure is
1215 actually 32 bytes long, with 4 bytes of padding at the end:
1217 +------+------+------+------+------+-------+-------+------+
1218 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1219 +------+------+------+------+------+-------+-------+------+
1220 0 4 8 12 16 20 24 28 32
1222 so what happens if you allocate memory for this structure:
1224 +------+------+------+------+------+-------+-------+------+------+...
1225 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1226 +------+------+------+------+------+-------+-------+------+------+...
1227 0 4 8 12 16 20 24 28 32 36
1229 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1230 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1231 started out as zero once, but it's quite possible that it isn't. So now,
1232 rather than a nicely zeroed GP, you have it pointing somewhere random.
1235 (In fact, GP ends up pointing at a previous GP structure, because the
1236 principle cause of the padding in XPVMG getting garbage is a copy of
1237 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1238 this happens to be moot because XPVGV has been re-ordered, with GP
1239 no longer after STASH)
1241 So we are careful and work out the size of used parts of all the
1249 referant = SvRV(sv);
1250 old_type_details = &fake_rv;
1251 if (new_type == SVt_NV)
1252 new_type = SVt_PVNV;
1254 if (new_type < SVt_PVIV) {
1255 new_type = (new_type == SVt_NV)
1256 ? SVt_PVNV : SVt_PVIV;
1261 if (new_type < SVt_PVNV) {
1262 new_type = SVt_PVNV;
1266 assert(new_type > SVt_PV);
1267 assert(SVt_IV < SVt_PV);
1268 assert(SVt_NV < SVt_PV);
1275 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1276 there's no way that it can be safely upgraded, because perl.c
1277 expects to Safefree(SvANY(PL_mess_sv)) */
1278 assert(sv != PL_mess_sv);
1279 /* This flag bit is used to mean other things in other scalar types.
1280 Given that it only has meaning inside the pad, it shouldn't be set
1281 on anything that can get upgraded. */
1282 assert(!SvPAD_TYPED(sv));
1285 if (old_type_details->cant_upgrade)
1286 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1287 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1290 if (old_type > new_type)
1291 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1292 (int)old_type, (int)new_type);
1294 new_type_details = bodies_by_type + new_type;
1296 SvFLAGS(sv) &= ~SVTYPEMASK;
1297 SvFLAGS(sv) |= new_type;
1299 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1300 the return statements above will have triggered. */
1301 assert (new_type != SVt_NULL);
1304 assert(old_type == SVt_NULL);
1305 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1309 assert(old_type == SVt_NULL);
1310 SvANY(sv) = new_XNV();
1315 assert(new_type_details->body_size);
1318 assert(new_type_details->arena);
1319 assert(new_type_details->arena_size);
1320 /* This points to the start of the allocated area. */
1321 new_body_inline(new_body, new_type);
1322 Zero(new_body, new_type_details->body_size, char);
1323 new_body = ((char *)new_body) - new_type_details->offset;
1325 /* We always allocated the full length item with PURIFY. To do this
1326 we fake things so that arena is false for all 16 types.. */
1327 new_body = new_NOARENAZ(new_type_details);
1329 SvANY(sv) = new_body;
1330 if (new_type == SVt_PVAV) {
1334 if (old_type_details->body_size) {
1337 /* It will have been zeroed when the new body was allocated.
1338 Lets not write to it, in case it confuses a write-back
1344 #ifndef NODEFAULT_SHAREKEYS
1345 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1347 HvMAX(sv) = 7; /* (start with 8 buckets) */
1348 if (old_type_details->body_size) {
1351 /* It will have been zeroed when the new body was allocated.
1352 Lets not write to it, in case it confuses a write-back
1357 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1358 The target created by newSVrv also is, and it can have magic.
1359 However, it never has SvPVX set.
1361 if (old_type == SVt_IV) {
1363 } else if (old_type >= SVt_PV) {
1364 assert(SvPVX_const(sv) == 0);
1367 if (old_type >= SVt_PVMG) {
1368 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1369 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1371 sv->sv_u.svu_array = NULL; /* or svu_hash */
1377 /* XXX Is this still needed? Was it ever needed? Surely as there is
1378 no route from NV to PVIV, NOK can never be true */
1379 assert(!SvNOKp(sv));
1391 assert(new_type_details->body_size);
1392 /* We always allocated the full length item with PURIFY. To do this
1393 we fake things so that arena is false for all 16 types.. */
1394 if(new_type_details->arena) {
1395 /* This points to the start of the allocated area. */
1396 new_body_inline(new_body, new_type);
1397 Zero(new_body, new_type_details->body_size, char);
1398 new_body = ((char *)new_body) - new_type_details->offset;
1400 new_body = new_NOARENAZ(new_type_details);
1402 SvANY(sv) = new_body;
1404 if (old_type_details->copy) {
1405 /* There is now the potential for an upgrade from something without
1406 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1407 int offset = old_type_details->offset;
1408 int length = old_type_details->copy;
1410 if (new_type_details->offset > old_type_details->offset) {
1411 const int difference
1412 = new_type_details->offset - old_type_details->offset;
1413 offset += difference;
1414 length -= difference;
1416 assert (length >= 0);
1418 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1422 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1423 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1424 * correct 0.0 for us. Otherwise, if the old body didn't have an
1425 * NV slot, but the new one does, then we need to initialise the
1426 * freshly created NV slot with whatever the correct bit pattern is
1428 if (old_type_details->zero_nv && !new_type_details->zero_nv
1429 && !isGV_with_GP(sv))
1433 if (new_type == SVt_PVIO)
1434 IoPAGE_LEN(sv) = 60;
1435 if (old_type < SVt_PV) {
1436 /* referant will be NULL unless the old type was SVt_IV emulating
1438 sv->sv_u.svu_rv = referant;
1442 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1443 (unsigned long)new_type);
1446 if (old_type_details->arena) {
1447 /* If there was an old body, then we need to free it.
1448 Note that there is an assumption that all bodies of types that
1449 can be upgraded came from arenas. Only the more complex non-
1450 upgradable types are allowed to be directly malloc()ed. */
1452 my_safefree(old_body);
1454 del_body((void*)((char*)old_body + old_type_details->offset),
1455 &PL_body_roots[old_type]);
1461 =for apidoc sv_backoff
1463 Remove any string offset. You should normally use the C<SvOOK_off> macro
1470 Perl_sv_backoff(pTHX_ register SV *const sv)
1473 const char * const s = SvPVX_const(sv);
1475 PERL_ARGS_ASSERT_SV_BACKOFF;
1476 PERL_UNUSED_CONTEXT;
1479 assert(SvTYPE(sv) != SVt_PVHV);
1480 assert(SvTYPE(sv) != SVt_PVAV);
1482 SvOOK_offset(sv, delta);
1484 SvLEN_set(sv, SvLEN(sv) + delta);
1485 SvPV_set(sv, SvPVX(sv) - delta);
1486 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1487 SvFLAGS(sv) &= ~SVf_OOK;
1494 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1495 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1496 Use the C<SvGROW> wrapper instead.
1502 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1506 PERL_ARGS_ASSERT_SV_GROW;
1508 if (PL_madskills && newlen >= 0x100000) {
1509 PerlIO_printf(Perl_debug_log,
1510 "Allocation too large: %"UVxf"\n", (UV)newlen);
1512 #ifdef HAS_64K_LIMIT
1513 if (newlen >= 0x10000) {
1514 PerlIO_printf(Perl_debug_log,
1515 "Allocation too large: %"UVxf"\n", (UV)newlen);
1518 #endif /* HAS_64K_LIMIT */
1521 if (SvTYPE(sv) < SVt_PV) {
1522 sv_upgrade(sv, SVt_PV);
1523 s = SvPVX_mutable(sv);
1525 else if (SvOOK(sv)) { /* pv is offset? */
1527 s = SvPVX_mutable(sv);
1528 if (newlen > SvLEN(sv))
1529 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1530 #ifdef HAS_64K_LIMIT
1531 if (newlen >= 0x10000)
1536 s = SvPVX_mutable(sv);
1538 if (newlen > SvLEN(sv)) { /* need more room? */
1539 #ifndef Perl_safesysmalloc_size
1540 newlen = PERL_STRLEN_ROUNDUP(newlen);
1542 if (SvLEN(sv) && s) {
1543 s = (char*)saferealloc(s, newlen);
1546 s = (char*)safemalloc(newlen);
1547 if (SvPVX_const(sv) && SvCUR(sv)) {
1548 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1552 #ifdef Perl_safesysmalloc_size
1553 /* Do this here, do it once, do it right, and then we will never get
1554 called back into sv_grow() unless there really is some growing
1556 SvLEN_set(sv, Perl_safesysmalloc_size(s));
1558 SvLEN_set(sv, newlen);
1565 =for apidoc sv_setiv
1567 Copies an integer into the given SV, upgrading first if necessary.
1568 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1574 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1578 PERL_ARGS_ASSERT_SV_SETIV;
1580 SV_CHECK_THINKFIRST_COW_DROP(sv);
1581 switch (SvTYPE(sv)) {
1584 sv_upgrade(sv, SVt_IV);
1587 sv_upgrade(sv, SVt_PVIV);
1591 if (!isGV_with_GP(sv))
1598 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1602 (void)SvIOK_only(sv); /* validate number */
1608 =for apidoc sv_setiv_mg
1610 Like C<sv_setiv>, but also handles 'set' magic.
1616 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1618 PERL_ARGS_ASSERT_SV_SETIV_MG;
1625 =for apidoc sv_setuv
1627 Copies an unsigned integer into the given SV, upgrading first if necessary.
1628 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1634 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1636 PERL_ARGS_ASSERT_SV_SETUV;
1638 /* With these two if statements:
1639 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1642 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1644 If you wish to remove them, please benchmark to see what the effect is
1646 if (u <= (UV)IV_MAX) {
1647 sv_setiv(sv, (IV)u);
1656 =for apidoc sv_setuv_mg
1658 Like C<sv_setuv>, but also handles 'set' magic.
1664 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1666 PERL_ARGS_ASSERT_SV_SETUV_MG;
1673 =for apidoc sv_setnv
1675 Copies a double into the given SV, upgrading first if necessary.
1676 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1682 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1686 PERL_ARGS_ASSERT_SV_SETNV;
1688 SV_CHECK_THINKFIRST_COW_DROP(sv);
1689 switch (SvTYPE(sv)) {
1692 sv_upgrade(sv, SVt_NV);
1696 sv_upgrade(sv, SVt_PVNV);
1700 if (!isGV_with_GP(sv))
1707 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1712 (void)SvNOK_only(sv); /* validate number */
1717 =for apidoc sv_setnv_mg
1719 Like C<sv_setnv>, but also handles 'set' magic.
1725 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1727 PERL_ARGS_ASSERT_SV_SETNV_MG;
1733 /* Print an "isn't numeric" warning, using a cleaned-up,
1734 * printable version of the offending string
1738 S_not_a_number(pTHX_ SV *const sv)
1745 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1748 dsv = newSVpvs_flags("", SVs_TEMP);
1749 pv = sv_uni_display(dsv, sv, 10, 0);
1752 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1753 /* each *s can expand to 4 chars + "...\0",
1754 i.e. need room for 8 chars */
1756 const char *s = SvPVX_const(sv);
1757 const char * const end = s + SvCUR(sv);
1758 for ( ; s < end && d < limit; s++ ) {
1760 if (ch & 128 && !isPRINT_LC(ch)) {
1769 else if (ch == '\r') {
1773 else if (ch == '\f') {
1777 else if (ch == '\\') {
1781 else if (ch == '\0') {
1785 else if (isPRINT_LC(ch))
1802 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1803 "Argument \"%s\" isn't numeric in %s", pv,
1806 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1807 "Argument \"%s\" isn't numeric", pv);
1811 =for apidoc looks_like_number
1813 Test if the content of an SV looks like a number (or is a number).
1814 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1815 non-numeric warning), even if your atof() doesn't grok them.
1821 Perl_looks_like_number(pTHX_ SV *const sv)
1823 register const char *sbegin;
1826 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1829 sbegin = SvPVX_const(sv);
1832 else if (SvPOKp(sv))
1833 sbegin = SvPV_const(sv, len);
1835 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1836 return grok_number(sbegin, len, NULL);
1840 S_glob_2number(pTHX_ GV * const gv)
1842 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1843 SV *const buffer = sv_newmortal();
1845 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1847 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1850 gv_efullname3(buffer, gv, "*");
1851 SvFLAGS(gv) |= wasfake;
1853 /* We know that all GVs stringify to something that is not-a-number,
1854 so no need to test that. */
1855 if (ckWARN(WARN_NUMERIC))
1856 not_a_number(buffer);
1857 /* We just want something true to return, so that S_sv_2iuv_common
1858 can tail call us and return true. */
1862 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1863 until proven guilty, assume that things are not that bad... */
1868 As 64 bit platforms often have an NV that doesn't preserve all bits of
1869 an IV (an assumption perl has been based on to date) it becomes necessary
1870 to remove the assumption that the NV always carries enough precision to
1871 recreate the IV whenever needed, and that the NV is the canonical form.
1872 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1873 precision as a side effect of conversion (which would lead to insanity
1874 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1875 1) to distinguish between IV/UV/NV slots that have cached a valid
1876 conversion where precision was lost and IV/UV/NV slots that have a
1877 valid conversion which has lost no precision
1878 2) to ensure that if a numeric conversion to one form is requested that
1879 would lose precision, the precise conversion (or differently
1880 imprecise conversion) is also performed and cached, to prevent
1881 requests for different numeric formats on the same SV causing
1882 lossy conversion chains. (lossless conversion chains are perfectly
1887 SvIOKp is true if the IV slot contains a valid value
1888 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1889 SvNOKp is true if the NV slot contains a valid value
1890 SvNOK is true only if the NV value is accurate
1893 while converting from PV to NV, check to see if converting that NV to an
1894 IV(or UV) would lose accuracy over a direct conversion from PV to
1895 IV(or UV). If it would, cache both conversions, return NV, but mark
1896 SV as IOK NOKp (ie not NOK).
1898 While converting from PV to IV, check to see if converting that IV to an
1899 NV would lose accuracy over a direct conversion from PV to NV. If it
1900 would, cache both conversions, flag similarly.
1902 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1903 correctly because if IV & NV were set NV *always* overruled.
1904 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1905 changes - now IV and NV together means that the two are interchangeable:
1906 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1908 The benefit of this is that operations such as pp_add know that if
1909 SvIOK is true for both left and right operands, then integer addition
1910 can be used instead of floating point (for cases where the result won't
1911 overflow). Before, floating point was always used, which could lead to
1912 loss of precision compared with integer addition.
1914 * making IV and NV equal status should make maths accurate on 64 bit
1916 * may speed up maths somewhat if pp_add and friends start to use
1917 integers when possible instead of fp. (Hopefully the overhead in
1918 looking for SvIOK and checking for overflow will not outweigh the
1919 fp to integer speedup)
1920 * will slow down integer operations (callers of SvIV) on "inaccurate"
1921 values, as the change from SvIOK to SvIOKp will cause a call into
1922 sv_2iv each time rather than a macro access direct to the IV slot
1923 * should speed up number->string conversion on integers as IV is
1924 favoured when IV and NV are equally accurate
1926 ####################################################################
1927 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1928 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1929 On the other hand, SvUOK is true iff UV.
1930 ####################################################################
1932 Your mileage will vary depending your CPU's relative fp to integer
1936 #ifndef NV_PRESERVES_UV
1937 # define IS_NUMBER_UNDERFLOW_IV 1
1938 # define IS_NUMBER_UNDERFLOW_UV 2
1939 # define IS_NUMBER_IV_AND_UV 2
1940 # define IS_NUMBER_OVERFLOW_IV 4
1941 # define IS_NUMBER_OVERFLOW_UV 5
1943 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1945 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1947 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1955 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1957 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));
1958 if (SvNVX(sv) < (NV)IV_MIN) {
1959 (void)SvIOKp_on(sv);
1961 SvIV_set(sv, IV_MIN);
1962 return IS_NUMBER_UNDERFLOW_IV;
1964 if (SvNVX(sv) > (NV)UV_MAX) {
1965 (void)SvIOKp_on(sv);
1968 SvUV_set(sv, UV_MAX);
1969 return IS_NUMBER_OVERFLOW_UV;
1971 (void)SvIOKp_on(sv);
1973 /* Can't use strtol etc to convert this string. (See truth table in
1975 if (SvNVX(sv) <= (UV)IV_MAX) {
1976 SvIV_set(sv, I_V(SvNVX(sv)));
1977 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1978 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1980 /* Integer is imprecise. NOK, IOKp */
1982 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1985 SvUV_set(sv, U_V(SvNVX(sv)));
1986 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1987 if (SvUVX(sv) == UV_MAX) {
1988 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1989 possibly be preserved by NV. Hence, it must be overflow.
1991 return IS_NUMBER_OVERFLOW_UV;
1993 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1995 /* Integer is imprecise. NOK, IOKp */
1997 return IS_NUMBER_OVERFLOW_IV;
1999 #endif /* !NV_PRESERVES_UV*/
2002 S_sv_2iuv_common(pTHX_ SV *const sv)
2006 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2009 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2010 * without also getting a cached IV/UV from it at the same time
2011 * (ie PV->NV conversion should detect loss of accuracy and cache
2012 * IV or UV at same time to avoid this. */
2013 /* IV-over-UV optimisation - choose to cache IV if possible */
2015 if (SvTYPE(sv) == SVt_NV)
2016 sv_upgrade(sv, SVt_PVNV);
2018 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2019 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2020 certainly cast into the IV range at IV_MAX, whereas the correct
2021 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2023 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2024 if (Perl_isnan(SvNVX(sv))) {
2030 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2031 SvIV_set(sv, I_V(SvNVX(sv)));
2032 if (SvNVX(sv) == (NV) SvIVX(sv)
2033 #ifndef NV_PRESERVES_UV
2034 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2035 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2036 /* Don't flag it as "accurately an integer" if the number
2037 came from a (by definition imprecise) NV operation, and
2038 we're outside the range of NV integer precision */
2042 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2044 /* scalar has trailing garbage, eg "42a" */
2046 DEBUG_c(PerlIO_printf(Perl_debug_log,
2047 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2053 /* IV not precise. No need to convert from PV, as NV
2054 conversion would already have cached IV if it detected
2055 that PV->IV would be better than PV->NV->IV
2056 flags already correct - don't set public IOK. */
2057 DEBUG_c(PerlIO_printf(Perl_debug_log,
2058 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2063 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2064 but the cast (NV)IV_MIN rounds to a the value less (more
2065 negative) than IV_MIN which happens to be equal to SvNVX ??
2066 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2067 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2068 (NV)UVX == NVX are both true, but the values differ. :-(
2069 Hopefully for 2s complement IV_MIN is something like
2070 0x8000000000000000 which will be exact. NWC */
2073 SvUV_set(sv, U_V(SvNVX(sv)));
2075 (SvNVX(sv) == (NV) SvUVX(sv))
2076 #ifndef NV_PRESERVES_UV
2077 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2078 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2079 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2080 /* Don't flag it as "accurately an integer" if the number
2081 came from a (by definition imprecise) NV operation, and
2082 we're outside the range of NV integer precision */
2088 DEBUG_c(PerlIO_printf(Perl_debug_log,
2089 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2095 else if (SvPOKp(sv) && SvLEN(sv)) {
2097 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2098 /* We want to avoid a possible problem when we cache an IV/ a UV which
2099 may be later translated to an NV, and the resulting NV is not
2100 the same as the direct translation of the initial string
2101 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2102 be careful to ensure that the value with the .456 is around if the
2103 NV value is requested in the future).
2105 This means that if we cache such an IV/a UV, we need to cache the
2106 NV as well. Moreover, we trade speed for space, and do not
2107 cache the NV if we are sure it's not needed.
2110 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2111 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2112 == IS_NUMBER_IN_UV) {
2113 /* It's definitely an integer, only upgrade to PVIV */
2114 if (SvTYPE(sv) < SVt_PVIV)
2115 sv_upgrade(sv, SVt_PVIV);
2117 } else if (SvTYPE(sv) < SVt_PVNV)
2118 sv_upgrade(sv, SVt_PVNV);
2120 /* If NVs preserve UVs then we only use the UV value if we know that
2121 we aren't going to call atof() below. If NVs don't preserve UVs
2122 then the value returned may have more precision than atof() will
2123 return, even though value isn't perfectly accurate. */
2124 if ((numtype & (IS_NUMBER_IN_UV
2125 #ifdef NV_PRESERVES_UV
2128 )) == IS_NUMBER_IN_UV) {
2129 /* This won't turn off the public IOK flag if it was set above */
2130 (void)SvIOKp_on(sv);
2132 if (!(numtype & IS_NUMBER_NEG)) {
2134 if (value <= (UV)IV_MAX) {
2135 SvIV_set(sv, (IV)value);
2137 /* it didn't overflow, and it was positive. */
2138 SvUV_set(sv, value);
2142 /* 2s complement assumption */
2143 if (value <= (UV)IV_MIN) {
2144 SvIV_set(sv, -(IV)value);
2146 /* Too negative for an IV. This is a double upgrade, but
2147 I'm assuming it will be rare. */
2148 if (SvTYPE(sv) < SVt_PVNV)
2149 sv_upgrade(sv, SVt_PVNV);
2153 SvNV_set(sv, -(NV)value);
2154 SvIV_set(sv, IV_MIN);
2158 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2159 will be in the previous block to set the IV slot, and the next
2160 block to set the NV slot. So no else here. */
2162 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2163 != IS_NUMBER_IN_UV) {
2164 /* It wasn't an (integer that doesn't overflow the UV). */
2165 SvNV_set(sv, Atof(SvPVX_const(sv)));
2167 if (! numtype && ckWARN(WARN_NUMERIC))
2170 #if defined(USE_LONG_DOUBLE)
2171 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2172 PTR2UV(sv), SvNVX(sv)));
2174 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2175 PTR2UV(sv), SvNVX(sv)));
2178 #ifdef NV_PRESERVES_UV
2179 (void)SvIOKp_on(sv);
2181 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2182 SvIV_set(sv, I_V(SvNVX(sv)));
2183 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2186 NOOP; /* Integer is imprecise. NOK, IOKp */
2188 /* UV will not work better than IV */
2190 if (SvNVX(sv) > (NV)UV_MAX) {
2192 /* Integer is inaccurate. NOK, IOKp, is UV */
2193 SvUV_set(sv, UV_MAX);
2195 SvUV_set(sv, U_V(SvNVX(sv)));
2196 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2197 NV preservse UV so can do correct comparison. */
2198 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2201 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
2206 #else /* NV_PRESERVES_UV */
2207 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2208 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2209 /* The IV/UV slot will have been set from value returned by
2210 grok_number above. The NV slot has just been set using
2213 assert (SvIOKp(sv));
2215 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2216 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2217 /* Small enough to preserve all bits. */
2218 (void)SvIOKp_on(sv);
2220 SvIV_set(sv, I_V(SvNVX(sv)));
2221 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2223 /* Assumption: first non-preserved integer is < IV_MAX,
2224 this NV is in the preserved range, therefore: */
2225 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2227 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);
2231 0 0 already failed to read UV.
2232 0 1 already failed to read UV.
2233 1 0 you won't get here in this case. IV/UV
2234 slot set, public IOK, Atof() unneeded.
2235 1 1 already read UV.
2236 so there's no point in sv_2iuv_non_preserve() attempting
2237 to use atol, strtol, strtoul etc. */
2239 sv_2iuv_non_preserve (sv, numtype);
2241 sv_2iuv_non_preserve (sv);
2245 #endif /* NV_PRESERVES_UV */
2246 /* It might be more code efficient to go through the entire logic above
2247 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2248 gets complex and potentially buggy, so more programmer efficient
2249 to do it this way, by turning off the public flags: */
2251 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2255 if (isGV_with_GP(sv))
2256 return glob_2number(MUTABLE_GV(sv));
2258 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2259 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2262 if (SvTYPE(sv) < SVt_IV)
2263 /* Typically the caller expects that sv_any is not NULL now. */
2264 sv_upgrade(sv, SVt_IV);
2265 /* Return 0 from the caller. */
2272 =for apidoc sv_2iv_flags
2274 Return the integer value of an SV, doing any necessary string
2275 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2276 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2282 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2287 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2288 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2289 cache IVs just in case. In practice it seems that they never
2290 actually anywhere accessible by user Perl code, let alone get used
2291 in anything other than a string context. */
2292 if (flags & SV_GMAGIC)
2297 return I_V(SvNVX(sv));
2299 if (SvPOKp(sv) && SvLEN(sv)) {
2302 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2304 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2305 == IS_NUMBER_IN_UV) {
2306 /* It's definitely an integer */
2307 if (numtype & IS_NUMBER_NEG) {
2308 if (value < (UV)IV_MIN)
2311 if (value < (UV)IV_MAX)
2316 if (ckWARN(WARN_NUMERIC))
2319 return I_V(Atof(SvPVX_const(sv)));
2324 assert(SvTYPE(sv) >= SVt_PVMG);
2325 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2326 } else if (SvTHINKFIRST(sv)) {
2330 SV * const tmpstr=AMG_CALLun(sv,numer);
2331 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2332 return SvIV(tmpstr);
2335 return PTR2IV(SvRV(sv));
2338 sv_force_normal_flags(sv, 0);
2340 if (SvREADONLY(sv) && !SvOK(sv)) {
2341 if (ckWARN(WARN_UNINITIALIZED))
2347 if (S_sv_2iuv_common(aTHX_ sv))
2350 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2351 PTR2UV(sv),SvIVX(sv)));
2352 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2356 =for apidoc sv_2uv_flags
2358 Return the unsigned integer value of an SV, doing any necessary string
2359 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2360 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2366 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2371 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2372 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2373 cache IVs just in case. */
2374 if (flags & SV_GMAGIC)
2379 return U_V(SvNVX(sv));
2380 if (SvPOKp(sv) && SvLEN(sv)) {
2383 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2385 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2386 == IS_NUMBER_IN_UV) {
2387 /* It's definitely an integer */
2388 if (!(numtype & IS_NUMBER_NEG))
2392 if (ckWARN(WARN_NUMERIC))
2395 return U_V(Atof(SvPVX_const(sv)));
2400 assert(SvTYPE(sv) >= SVt_PVMG);
2401 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2402 } else if (SvTHINKFIRST(sv)) {
2406 SV *const tmpstr = AMG_CALLun(sv,numer);
2407 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2408 return SvUV(tmpstr);
2411 return PTR2UV(SvRV(sv));
2414 sv_force_normal_flags(sv, 0);
2416 if (SvREADONLY(sv) && !SvOK(sv)) {
2417 if (ckWARN(WARN_UNINITIALIZED))
2423 if (S_sv_2iuv_common(aTHX_ sv))
2427 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2428 PTR2UV(sv),SvUVX(sv)));
2429 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2435 Return the num value of an SV, doing any necessary string or integer
2436 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2443 Perl_sv_2nv(pTHX_ register SV *const sv)
2448 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2449 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2450 cache IVs just in case. */
2454 if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2455 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2456 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2458 return Atof(SvPVX_const(sv));
2462 return (NV)SvUVX(sv);
2464 return (NV)SvIVX(sv);
2469 assert(SvTYPE(sv) >= SVt_PVMG);
2470 /* This falls through to the report_uninit near the end of the
2472 } else if (SvTHINKFIRST(sv)) {
2476 SV *const tmpstr = AMG_CALLun(sv,numer);
2477 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2478 return SvNV(tmpstr);
2481 return PTR2NV(SvRV(sv));
2484 sv_force_normal_flags(sv, 0);
2486 if (SvREADONLY(sv) && !SvOK(sv)) {
2487 if (ckWARN(WARN_UNINITIALIZED))
2492 if (SvTYPE(sv) < SVt_NV) {
2493 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2494 sv_upgrade(sv, SVt_NV);
2495 #ifdef USE_LONG_DOUBLE
2497 STORE_NUMERIC_LOCAL_SET_STANDARD();
2498 PerlIO_printf(Perl_debug_log,
2499 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2500 PTR2UV(sv), SvNVX(sv));
2501 RESTORE_NUMERIC_LOCAL();
2505 STORE_NUMERIC_LOCAL_SET_STANDARD();
2506 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2507 PTR2UV(sv), SvNVX(sv));
2508 RESTORE_NUMERIC_LOCAL();
2512 else if (SvTYPE(sv) < SVt_PVNV)
2513 sv_upgrade(sv, SVt_PVNV);
2518 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2519 #ifdef NV_PRESERVES_UV
2525 /* Only set the public NV OK flag if this NV preserves the IV */
2526 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2528 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2529 : (SvIVX(sv) == I_V(SvNVX(sv))))
2535 else if (SvPOKp(sv) && SvLEN(sv)) {
2537 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2538 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2540 #ifdef NV_PRESERVES_UV
2541 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2542 == IS_NUMBER_IN_UV) {
2543 /* It's definitely an integer */
2544 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2546 SvNV_set(sv, Atof(SvPVX_const(sv)));
2552 SvNV_set(sv, Atof(SvPVX_const(sv)));
2553 /* Only set the public NV OK flag if this NV preserves the value in
2554 the PV at least as well as an IV/UV would.
2555 Not sure how to do this 100% reliably. */
2556 /* if that shift count is out of range then Configure's test is
2557 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2559 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2560 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2561 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2562 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2563 /* Can't use strtol etc to convert this string, so don't try.
2564 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2567 /* value has been set. It may not be precise. */
2568 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2569 /* 2s complement assumption for (UV)IV_MIN */
2570 SvNOK_on(sv); /* Integer is too negative. */
2575 if (numtype & IS_NUMBER_NEG) {
2576 SvIV_set(sv, -(IV)value);
2577 } else if (value <= (UV)IV_MAX) {
2578 SvIV_set(sv, (IV)value);
2580 SvUV_set(sv, value);
2584 if (numtype & IS_NUMBER_NOT_INT) {
2585 /* I believe that even if the original PV had decimals,
2586 they are lost beyond the limit of the FP precision.
2587 However, neither is canonical, so both only get p
2588 flags. NWC, 2000/11/25 */
2589 /* Both already have p flags, so do nothing */
2591 const NV nv = SvNVX(sv);
2592 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2593 if (SvIVX(sv) == I_V(nv)) {
2596 /* It had no "." so it must be integer. */
2600 /* between IV_MAX and NV(UV_MAX).
2601 Could be slightly > UV_MAX */
2603 if (numtype & IS_NUMBER_NOT_INT) {
2604 /* UV and NV both imprecise. */
2606 const UV nv_as_uv = U_V(nv);
2608 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2617 /* It might be more code efficient to go through the entire logic above
2618 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2619 gets complex and potentially buggy, so more programmer efficient
2620 to do it this way, by turning off the public flags: */
2622 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2623 #endif /* NV_PRESERVES_UV */
2626 if (isGV_with_GP(sv)) {
2627 glob_2number(MUTABLE_GV(sv));
2631 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2633 assert (SvTYPE(sv) >= SVt_NV);
2634 /* Typically the caller expects that sv_any is not NULL now. */
2635 /* XXX Ilya implies that this is a bug in callers that assume this
2636 and ideally should be fixed. */
2639 #if defined(USE_LONG_DOUBLE)
2641 STORE_NUMERIC_LOCAL_SET_STANDARD();
2642 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2643 PTR2UV(sv), SvNVX(sv));
2644 RESTORE_NUMERIC_LOCAL();
2648 STORE_NUMERIC_LOCAL_SET_STANDARD();
2649 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2650 PTR2UV(sv), SvNVX(sv));
2651 RESTORE_NUMERIC_LOCAL();
2660 Return an SV with the numeric value of the source SV, doing any necessary
2661 reference or overload conversion. You must use the C<SvNUM(sv)> macro to
2662 access this function.
2668 Perl_sv_2num(pTHX_ register SV *const sv)
2670 PERL_ARGS_ASSERT_SV_2NUM;
2675 SV * const tmpsv = AMG_CALLun(sv,numer);
2676 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2677 return sv_2num(tmpsv);
2679 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2682 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2683 * UV as a string towards the end of buf, and return pointers to start and
2686 * We assume that buf is at least TYPE_CHARS(UV) long.
2690 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2692 char *ptr = buf + TYPE_CHARS(UV);
2693 char * const ebuf = ptr;
2696 PERL_ARGS_ASSERT_UIV_2BUF;
2708 *--ptr = '0' + (char)(uv % 10);
2717 =for apidoc sv_2pv_flags
2719 Returns a pointer to the string value of an SV, and sets *lp to its length.
2720 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2722 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2723 usually end up here too.
2729 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2739 if (SvGMAGICAL(sv)) {
2740 if (flags & SV_GMAGIC)
2745 if (flags & SV_MUTABLE_RETURN)
2746 return SvPVX_mutable(sv);
2747 if (flags & SV_CONST_RETURN)
2748 return (char *)SvPVX_const(sv);
2751 if (SvIOKp(sv) || SvNOKp(sv)) {
2752 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2757 ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2758 : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2760 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2767 #ifdef FIXNEGATIVEZERO
2768 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2774 SvUPGRADE(sv, SVt_PV);
2777 s = SvGROW_mutable(sv, len + 1);
2780 return (char*)memcpy(s, tbuf, len + 1);
2786 assert(SvTYPE(sv) >= SVt_PVMG);
2787 /* This falls through to the report_uninit near the end of the
2789 } else if (SvTHINKFIRST(sv)) {
2793 SV *const tmpstr = AMG_CALLun(sv,string);
2794 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2796 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2800 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2801 if (flags & SV_CONST_RETURN) {
2802 pv = (char *) SvPVX_const(tmpstr);
2804 pv = (flags & SV_MUTABLE_RETURN)
2805 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2808 *lp = SvCUR(tmpstr);
2810 pv = sv_2pv_flags(tmpstr, lp, flags);
2823 SV *const referent = SvRV(sv);
2827 retval = buffer = savepvn("NULLREF", len);
2828 } else if (SvTYPE(referent) == SVt_REGEXP) {
2829 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2834 /* If the regex is UTF-8 we want the containing scalar to
2835 have an UTF-8 flag too */
2841 if ((seen_evals = RX_SEEN_EVALS(re)))
2842 PL_reginterp_cnt += seen_evals;
2845 *lp = RX_WRAPLEN(re);
2847 return RX_WRAPPED(re);
2849 const char *const typestr = sv_reftype(referent, 0);
2850 const STRLEN typelen = strlen(typestr);
2851 UV addr = PTR2UV(referent);
2852 const char *stashname = NULL;
2853 STRLEN stashnamelen = 0; /* hush, gcc */
2854 const char *buffer_end;
2856 if (SvOBJECT(referent)) {
2857 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2860 stashname = HEK_KEY(name);
2861 stashnamelen = HEK_LEN(name);
2863 if (HEK_UTF8(name)) {
2869 stashname = "__ANON__";
2872 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2873 + 2 * sizeof(UV) + 2 /* )\0 */;
2875 len = typelen + 3 /* (0x */
2876 + 2 * sizeof(UV) + 2 /* )\0 */;
2879 Newx(buffer, len, char);
2880 buffer_end = retval = buffer + len;
2882 /* Working backwards */
2886 *--retval = PL_hexdigit[addr & 15];
2887 } while (addr >>= 4);
2893 memcpy(retval, typestr, typelen);
2897 retval -= stashnamelen;
2898 memcpy(retval, stashname, stashnamelen);
2900 /* retval may not neccesarily have reached the start of the
2902 assert (retval >= buffer);
2904 len = buffer_end - retval - 1; /* -1 for that \0 */
2912 if (SvREADONLY(sv) && !SvOK(sv)) {
2915 if (flags & SV_UNDEF_RETURNS_NULL)
2917 if (ckWARN(WARN_UNINITIALIZED))
2922 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2923 /* I'm assuming that if both IV and NV are equally valid then
2924 converting the IV is going to be more efficient */
2925 const U32 isUIOK = SvIsUV(sv);
2926 char buf[TYPE_CHARS(UV)];
2930 if (SvTYPE(sv) < SVt_PVIV)
2931 sv_upgrade(sv, SVt_PVIV);
2932 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2934 /* inlined from sv_setpvn */
2935 s = SvGROW_mutable(sv, len + 1);
2936 Move(ptr, s, len, char);
2940 else if (SvNOKp(sv)) {
2942 if (SvTYPE(sv) < SVt_PVNV)
2943 sv_upgrade(sv, SVt_PVNV);
2944 /* The +20 is pure guesswork. Configure test needed. --jhi */
2945 s = SvGROW_mutable(sv, NV_DIG + 20);
2946 /* some Xenix systems wipe out errno here */
2948 if (SvNVX(sv) == 0.0)
2949 my_strlcpy(s, "0", SvLEN(sv));
2953 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2956 #ifdef FIXNEGATIVEZERO
2957 if (*s == '-' && s[1] == '0' && !s[2]) {
2969 if (isGV_with_GP(sv)) {
2970 GV *const gv = MUTABLE_GV(sv);
2971 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
2972 SV *const buffer = sv_newmortal();
2974 /* FAKE globs can get coerced, so need to turn this off temporarily
2977 gv_efullname3(buffer, gv, "*");
2978 SvFLAGS(gv) |= wasfake;
2980 assert(SvPOK(buffer));
2982 *lp = SvCUR(buffer);
2984 return SvPVX(buffer);
2989 if (flags & SV_UNDEF_RETURNS_NULL)
2991 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2993 if (SvTYPE(sv) < SVt_PV)
2994 /* Typically the caller expects that sv_any is not NULL now. */
2995 sv_upgrade(sv, SVt_PV);
2999 const STRLEN len = s - SvPVX_const(sv);
3005 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3006 PTR2UV(sv),SvPVX_const(sv)));
3007 if (flags & SV_CONST_RETURN)
3008 return (char *)SvPVX_const(sv);
3009 if (flags & SV_MUTABLE_RETURN)
3010 return SvPVX_mutable(sv);
3015 =for apidoc sv_copypv
3017 Copies a stringified representation of the source SV into the
3018 destination SV. Automatically performs any necessary mg_get and
3019 coercion of numeric values into strings. Guaranteed to preserve
3020 UTF8 flag even from overloaded objects. Similar in nature to
3021 sv_2pv[_flags] but operates directly on an SV instead of just the
3022 string. Mostly uses sv_2pv_flags to do its work, except when that
3023 would lose the UTF-8'ness of the PV.
3029 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3032 const char * const s = SvPV_const(ssv,len);
3034 PERL_ARGS_ASSERT_SV_COPYPV;
3036 sv_setpvn(dsv,s,len);
3044 =for apidoc sv_2pvbyte
3046 Return a pointer to the byte-encoded representation of the SV, and set *lp
3047 to its length. May cause the SV to be downgraded from UTF-8 as a
3050 Usually accessed via the C<SvPVbyte> macro.
3056 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3058 PERL_ARGS_ASSERT_SV_2PVBYTE;
3060 sv_utf8_downgrade(sv,0);
3061 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3065 =for apidoc sv_2pvutf8
3067 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3068 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3070 Usually accessed via the C<SvPVutf8> macro.
3076 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3078 PERL_ARGS_ASSERT_SV_2PVUTF8;
3080 sv_utf8_upgrade(sv);
3081 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3086 =for apidoc sv_2bool
3088 This function is only called on magical items, and is only used by
3089 sv_true() or its macro equivalent.
3095 Perl_sv_2bool(pTHX_ register SV *const sv)
3099 PERL_ARGS_ASSERT_SV_2BOOL;
3107 SV * const tmpsv = AMG_CALLun(sv,bool_);
3108 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3109 return (bool)SvTRUE(tmpsv);
3111 return SvRV(sv) != 0;
3114 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3116 (*sv->sv_u.svu_pv > '0' ||
3117 Xpvtmp->xpv_cur > 1 ||
3118 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3125 return SvIVX(sv) != 0;
3128 return SvNVX(sv) != 0.0;
3130 if (isGV_with_GP(sv))
3140 =for apidoc sv_utf8_upgrade
3142 Converts the PV of an SV to its UTF-8-encoded form.
3143 Forces the SV to string form if it is not already.
3144 Will C<mg_get> on C<sv> if appropriate.
3145 Always sets the SvUTF8 flag to avoid future validity checks even
3146 if the whole string is the same in UTF-8 as not.
3147 Returns the number of bytes in the converted string
3149 This is not as a general purpose byte encoding to Unicode interface:
3150 use the Encode extension for that.
3152 =for apidoc sv_utf8_upgrade_nomg
3154 Like sv_utf8_upgrade, but doesn't do magic on C<sv>
3156 =for apidoc sv_utf8_upgrade_flags
3158 Converts the PV of an SV to its UTF-8-encoded form.
3159 Forces the SV to string form if it is not already.
3160 Always sets the SvUTF8 flag to avoid future validity checks even
3161 if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
3162 will C<mg_get> on C<sv> if appropriate, else not.
3163 Returns the number of bytes in the converted string
3164 C<sv_utf8_upgrade> and
3165 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3167 This is not as a general purpose byte encoding to Unicode interface:
3168 use the Encode extension for that.
3172 The grow version is currently not externally documented. It adds a parameter,
3173 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3174 have free after it upon return. This allows the caller to reserve extra space
3175 that it intends to fill, to avoid extra grows.
3177 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3178 which can be used to tell this function to not first check to see if there are
3179 any characters that are different in UTF-8 (variant characters) which would
3180 force it to allocate a new string to sv, but to assume there are. Typically
3181 this flag is used by a routine that has already parsed the string to find that
3182 there are such characters, and passes this information on so that the work
3183 doesn't have to be repeated.
3185 (One might think that the calling routine could pass in the position of the
3186 first such variant, so it wouldn't have to be found again. But that is not the
3187 case, because typically when the caller is likely to use this flag, it won't be
3188 calling this routine unless it finds something that won't fit into a byte.
3189 Otherwise it tries to not upgrade and just use bytes. But some things that
3190 do fit into a byte are variants in utf8, and the caller may not have been
3191 keeping track of these.)
3193 If the routine itself changes the string, it adds a trailing NUL. Such a NUL
3194 isn't guaranteed due to having other routines do the work in some input cases,
3195 or if the input is already flagged as being in utf8.
3197 The speed of this could perhaps be improved for many cases if someone wanted to
3198 write a fast function that counts the number of variant characters in a string,
3199 especially if it could return the position of the first one.
3204 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
3208 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3210 if (sv == &PL_sv_undef)
3214 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3215 (void) sv_2pv_flags(sv,&len, flags);
3217 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3221 (void) SvPV_force(sv,len);
3226 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3231 sv_force_normal_flags(sv, 0);
3234 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3235 sv_recode_to_utf8(sv, PL_encoding);
3236 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3240 if (SvCUR(sv) > 0) { /* Assume Latin-1/EBCDIC */
3241 /* This function could be much more efficient if we
3242 * had a FLAG in SVs to signal if there are any variant
3243 * chars in the PV. Given that there isn't such a flag
3244 * make the loop as fast as possible (although there are certainly ways
3245 * to speed this up, eg. through vectorization) */
3246 U8 * s = (U8 *) SvPVX_const(sv);
3247 U8 * e = (U8 *) SvEND(sv);
3249 STRLEN two_byte_count = 0;
3251 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3253 /* See if really will need to convert to utf8. We mustn't rely on our
3254 * incoming SV being well formed and having a trailing '\0', as certain
3255 * code in pp_formline can send us partially built SVs. */
3259 if (NATIVE_IS_INVARIANT(ch)) continue;
3261 t--; /* t already incremented; re-point to first variant */
3266 /* utf8 conversion not needed because all are invariants. Mark as
3267 * UTF-8 even if no variant - saves scanning loop */
3273 /* Here, the string should be converted to utf8, either because of an
3274 * input flag (two_byte_count = 0), or because a character that
3275 * requires 2 bytes was found (two_byte_count = 1). t points either to
3276 * the beginning of the string (if we didn't examine anything), or to
3277 * the first variant. In either case, everything from s to t - 1 will
3278 * occupy only 1 byte each on output.
3280 * There are two main ways to convert. One is to create a new string
3281 * and go through the input starting from the beginning, appending each
3282 * converted value onto the new string as we go along. It's probably
3283 * best to allocate enough space in the string for the worst possible
3284 * case rather than possibly running out of space and having to
3285 * reallocate and then copy what we've done so far. Since everything
3286 * from s to t - 1 is invariant, the destination can be initialized
3287 * with these using a fast memory copy
3289 * The other way is to figure out exactly how big the string should be
3290 * by parsing the entire input. Then you don't have to make it big
3291 * enough to handle the worst possible case, and more importantly, if
3292 * the string you already have is large enough, you don't have to
3293 * allocate a new string, you can copy the last character in the input
3294 * string to the final position(s) that will be occupied by the
3295 * converted string and go backwards, stopping at t, since everything
3296 * before that is invariant.
3298 * There are advantages and disadvantages to each method.
3300 * In the first method, we can allocate a new string, do the memory
3301 * copy from the s to t - 1, and then proceed through the rest of the
3302 * string byte-by-byte.
3304 * In the second method, we proceed through the rest of the input
3305 * string just calculating how big the converted string will be. Then
3306 * there are two cases:
3307 * 1) if the string has enough extra space to handle the converted
3308 * value. We go backwards through the string, converting until we
3309 * get to the position we are at now, and then stop. If this
3310 * position is far enough along in the string, this method is
3311 * faster than the other method. If the memory copy were the same
3312 * speed as the byte-by-byte loop, that position would be about
3313 * half-way, as at the half-way mark, parsing to the end and back
3314 * is one complete string's parse, the same amount as starting
3315 * over and going all the way through. Actually, it would be
3316 * somewhat less than half-way, as it's faster to just count bytes
3317 * than to also copy, and we don't have the overhead of allocating
3318 * a new string, changing the scalar to use it, and freeing the
3319 * existing one. But if the memory copy is fast, the break-even
3320 * point is somewhere after half way. The counting loop could be
3321 * sped up by vectorization, etc, to move the break-even point
3322 * further towards the beginning.
3323 * 2) if the string doesn't have enough space to handle the converted
3324 * value. A new string will have to be allocated, and one might
3325 * as well, given that, start from the beginning doing the first
3326 * method. We've spent extra time parsing the string and in
3327 * exchange all we've gotten is that we know precisely how big to
3328 * make the new one. Perl is more optimized for time than space,
3329 * so this case is a loser.
3330 * So what I've decided to do is not use the 2nd method unless it is
3331 * guaranteed that a new string won't have to be allocated, assuming
3332 * the worst case. I also decided not to put any more conditions on it
3333 * than this, for now. It seems likely that, since the worst case is
3334 * twice as big as the unknown portion of the string (plus 1), we won't
3335 * be guaranteed enough space, causing us to go to the first method,
3336 * unless the string is short, or the first variant character is near
3337 * the end of it. In either of these cases, it seems best to use the
3338 * 2nd method. The only circumstance I can think of where this would
3339 * be really slower is if the string had once had much more data in it
3340 * than it does now, but there is still a substantial amount in it */
3343 STRLEN invariant_head = t - s;
3344 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3345 if (SvLEN(sv) < size) {
3347 /* Here, have decided to allocate a new string */
3352 Newx(dst, size, U8);
3354 /* If no known invariants at the beginning of the input string,
3355 * set so starts from there. Otherwise, can use memory copy to
3356 * get up to where we are now, and then start from here */
3358 if (invariant_head <= 0) {
3361 Copy(s, dst, invariant_head, char);
3362 d = dst + invariant_head;
3366 const UV uv = NATIVE8_TO_UNI(*t++);
3367 if (UNI_IS_INVARIANT(uv))
3368 *d++ = (U8)UNI_TO_NATIVE(uv);
3370 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3371 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3375 SvPV_free(sv); /* No longer using pre-existing string */
3376 SvPV_set(sv, (char*)dst);
3377 SvCUR_set(sv, d - dst);
3378 SvLEN_set(sv, size);
3381 /* Here, have decided to get the exact size of the string.
3382 * Currently this happens only when we know that there is
3383 * guaranteed enough space to fit the converted string, so
3384 * don't have to worry about growing. If two_byte_count is 0,
3385 * then t points to the first byte of the string which hasn't
3386 * been examined yet. Otherwise two_byte_count is 1, and t
3387 * points to the first byte in the string that will expand to
3388 * two. Depending on this, start examining at t or 1 after t.
3391 U8 *d = t + two_byte_count;
3394 /* Count up the remaining bytes that expand to two */
3397 const U8 chr = *d++;
3398 if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3401 /* The string will expand by just the number of bytes that
3402 * occupy two positions. But we are one afterwards because of
3403 * the increment just above. This is the place to put the
3404 * trailing NUL, and to set the length before we decrement */
3406 d += two_byte_count;
3407 SvCUR_set(sv, d - s);
3411 /* Having decremented d, it points to the position to put the
3412 * very last byte of the expanded string. Go backwards through
3413 * the string, copying and expanding as we go, stopping when we
3414 * get to the part that is invariant the rest of the way down */
3418 const U8 ch = NATIVE8_TO_UNI(*e--);
3419 if (UNI_IS_INVARIANT(ch)) {
3420 *d-- = UNI_TO_NATIVE(ch);
3422 *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3423 *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3430 /* Mark as UTF-8 even if no variant - saves scanning loop */
3436 =for apidoc sv_utf8_downgrade
3438 Attempts to convert the PV of an SV from characters to bytes.
3439 If the PV contains a character that cannot fit
3440 in a byte, this conversion will fail;
3441 in this case, either returns false or, if C<fail_ok> is not
3444 This is not as a general purpose Unicode to byte encoding interface:
3445 use the Encode extension for that.
3451 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3455 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3457 if (SvPOKp(sv) && SvUTF8(sv)) {
3463 sv_force_normal_flags(sv, 0);
3465 s = (U8 *) SvPV(sv, len);
3466 if (!utf8_to_bytes(s, &len)) {
3471 Perl_croak(aTHX_ "Wide character in %s",
3474 Perl_croak(aTHX_ "Wide character");
3485 =for apidoc sv_utf8_encode
3487 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3488 flag off so that it looks like octets again.
3494 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3496 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3499 sv_force_normal_flags(sv, 0);
3501 if (SvREADONLY(sv)) {
3502 Perl_croak(aTHX_ "%s", PL_no_modify);
3504 (void) sv_utf8_upgrade(sv);
3509 =for apidoc sv_utf8_decode
3511 If the PV of the SV is an octet sequence in UTF-8
3512 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3513 so that it looks like a character. If the PV contains only single-byte
3514 characters, the C<SvUTF8> flag stays being off.
3515 Scans PV for validity and returns false if the PV is invalid UTF-8.
3521 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3523 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3529 /* The octets may have got themselves encoded - get them back as
3532 if (!sv_utf8_downgrade(sv, TRUE))
3535 /* it is actually just a matter of turning the utf8 flag on, but
3536 * we want to make sure everything inside is valid utf8 first.
3538 c = (const U8 *) SvPVX_const(sv);
3539 if (!is_utf8_string(c, SvCUR(sv)+1))
3541 e = (const U8 *) SvEND(sv);
3544 if (!UTF8_IS_INVARIANT(ch)) {
3554 =for apidoc sv_setsv
3556 Copies the contents of the source SV C<ssv> into the destination SV
3557 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3558 function if the source SV needs to be reused. Does not handle 'set' magic.
3559 Loosely speaking, it performs a copy-by-value, obliterating any previous
3560 content of the destination.
3562 You probably want to use one of the assortment of wrappers, such as
3563 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3564 C<SvSetMagicSV_nosteal>.
3566 =for apidoc sv_setsv_flags
3568 Copies the contents of the source SV C<ssv> into the destination SV
3569 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3570 function if the source SV needs to be reused. Does not handle 'set' magic.
3571 Loosely speaking, it performs a copy-by-value, obliterating any previous
3572 content of the destination.
3573 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3574 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3575 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3576 and C<sv_setsv_nomg> are implemented in terms of this function.
3578 You probably want to use one of the assortment of wrappers, such as
3579 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3580 C<SvSetMagicSV_nosteal>.
3582 This is the primary function for copying scalars, and most other
3583 copy-ish functions and macros use this underneath.
3589 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3591 I32 mro_changes = 0; /* 1 = method, 2 = isa */
3593 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3595 if (dtype != SVt_PVGV) {
3596 const char * const name = GvNAME(sstr);
3597 const STRLEN len = GvNAMELEN(sstr);
3599 if (dtype >= SVt_PV) {
3605 SvUPGRADE(dstr, SVt_PVGV);
3606 (void)SvOK_off(dstr);
3607 /* FIXME - why are we doing this, then turning it off and on again
3609 isGV_with_GP_on(dstr);
3611 GvSTASH(dstr) = GvSTASH(sstr);
3613 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3614 gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
3615 SvFAKE_on(dstr); /* can coerce to non-glob */
3618 if(GvGP(MUTABLE_GV(sstr))) {
3619 /* If source has method cache entry, clear it */
3621 SvREFCNT_dec(GvCV(sstr));
3625 /* If source has a real method, then a method is
3627 else if(GvCV((const GV *)sstr)) {
3632 /* If dest already had a real method, that's a change as well */
3633 if(!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)) {
3637 if(strEQ(GvNAME((const GV *)dstr),"ISA"))
3640 gp_free(MUTABLE_GV(dstr));
3641 isGV_with_GP_off(dstr);
3642 (void)SvOK_off(dstr);
3643 isGV_with_GP_on(dstr);
3644 GvINTRO_off(dstr); /* one-shot flag */
3645 GvGP(dstr) = gp_ref(GvGP(sstr));
3646 if (SvTAINTED(sstr))
3648 if (GvIMPORTED(dstr) != GVf_IMPORTED
3649 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3651 GvIMPORTED_on(dstr);
3654 if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
3655 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3660 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3662 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3664 const int intro = GvINTRO(dstr);
3667 const U32 stype = SvTYPE(sref);
3669 PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3672 GvINTRO_off(dstr); /* one-shot flag */
3673 GvLINE(dstr) = CopLINE(PL_curcop);
3674 GvEGV(dstr) = MUTABLE_GV(dstr);
3679 location = (SV **) &GvCV(dstr);
3680 import_flag = GVf_IMPORTED_CV;
3683 location = (SV **) &GvHV(dstr);
3684 import_flag = GVf_IMPORTED_HV;
3687 location = (SV **) &GvAV(dstr);
3688 import_flag = GVf_IMPORTED_AV;
3691 location = (SV **) &GvIOp(dstr);
3694 location = (SV **) &GvFORM(dstr);
3696 location = &GvSV(dstr);
3697 import_flag = GVf_IMPORTED_SV;
3700 if (stype == SVt_PVCV) {
3701 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3702 if (GvCVGEN(dstr)) {
3703 SvREFCNT_dec(GvCV(dstr));
3705 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3708 SAVEGENERICSV(*location);
3712 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3713 CV* const cv = MUTABLE_CV(*location);
3715 if (!GvCVGEN((const GV *)dstr) &&
3716 (CvROOT(cv) || CvXSUB(cv)))
3718 /* Redefining a sub - warning is mandatory if
3719 it was a const and its value changed. */
3720 if (CvCONST(cv) && CvCONST((const CV *)sref)
3722 == cv_const_sv((const CV *)sref)) {
3724 /* They are 2 constant subroutines generated from
3725 the same constant. This probably means that
3726 they are really the "same" proxy subroutine
3727 instantiated in 2 places. Most likely this is
3728 when a constant is exported twice. Don't warn.
3731 else if (ckWARN(WARN_REDEFINE)
3733 && (!CvCONST((const CV *)sref)
3734 || sv_cmp(cv_const_sv(cv),
3735 cv_const_sv((const CV *)
3737 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3740 ? "Constant subroutine %s::%s redefined"
3741 : "Subroutine %s::%s redefined"),
3742 HvNAME_get(GvSTASH((const GV *)dstr)),
3743 GvENAME(MUTABLE_GV(dstr)));
3747 cv_ckproto_len(cv, (const GV *)dstr,
3748 SvPOK(sref) ? SvPVX_const(sref) : NULL,
3749 SvPOK(sref) ? SvCUR(sref) : 0);
3751 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3752 GvASSUMECV_on(dstr);
3753 if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3756 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3757 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3758 GvFLAGS(dstr) |= import_flag;
3763 if (SvTAINTED(sstr))
3769 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3772 register U32 sflags;
3774 register svtype stype;
3776 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3781 if (SvIS_FREED(dstr)) {
3782 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3783 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3785 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3787 sstr = &PL_sv_undef;
3788 if (SvIS_FREED(sstr)) {
3789 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3790 (void*)sstr, (void*)dstr);
3792 stype = SvTYPE(sstr);
3793 dtype = SvTYPE(dstr);
3795 (void)SvAMAGIC_off(dstr);
3798 /* need to nuke the magic */
3802 /* There's a lot of redundancy below but we're going for speed here */
3807 if (dtype != SVt_PVGV) {
3808 (void)SvOK_off(dstr);
3816 sv_upgrade(dstr, SVt_IV);
3820 sv_upgrade(dstr, SVt_PVIV);
3823 goto end_of_first_switch;
3825 (void)SvIOK_only(dstr);
3826 SvIV_set(dstr, SvIVX(sstr));
3829 /* SvTAINTED can only be true if the SV has taint magic, which in
3830 turn means that the SV type is PVMG (or greater). This is the
3831 case statement for SVt_IV, so this cannot be true (whatever gcov
3833 assert(!SvTAINTED(sstr));
3838 if (dtype < SVt_PV && dtype != SVt_IV)
3839 sv_upgrade(dstr, SVt_IV);
3847 sv_upgrade(dstr, SVt_NV);
3851 sv_upgrade(dstr, SVt_PVNV);
3854 goto end_of_first_switch;
3856 SvNV_set(dstr, SvNVX(sstr));
3857 (void)SvNOK_only(dstr);
3858 /* SvTAINTED can only be true if the SV has taint magic, which in
3859 turn means that the SV type is PVMG (or greater). This is the
3860 case statement for SVt_NV, so this cannot be true (whatever gcov
3862 assert(!SvTAINTED(sstr));
3868 #ifdef PERL_OLD_COPY_ON_WRITE
3869 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3870 if (dtype < SVt_PVIV)
3871 sv_upgrade(dstr, SVt_PVIV);
3879 sv_upgrade(dstr, SVt_PV);
3882 if (dtype < SVt_PVIV)
3883 sv_upgrade(dstr, SVt_PVIV);
3886 if (dtype < SVt_PVNV)
3887 sv_upgrade(dstr, SVt_PVNV);
3891 const char * const type = sv_reftype(sstr,0);
3893 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3895 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3899 /* case SVt_BIND: */
3902 if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
3903 glob_assign_glob(dstr, sstr, dtype);
3906 /* SvVALID means that this PVGV is playing at being an FBM. */
3910 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3912 if (SvTYPE(sstr) != stype) {
3913 stype = SvTYPE(sstr);
3914 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
3915 glob_assign_glob(dstr, sstr, dtype);
3920 if (stype == SVt_PVLV)
3921 SvUPGRADE(dstr, SVt_PVNV);
3923 SvUPGRADE(dstr, (svtype)stype);
3925 end_of_first_switch:
3927 /* dstr may have been upgraded. */
3928 dtype = SvTYPE(dstr);
3929 sflags = SvFLAGS(sstr);
3931 if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
3932 /* Assigning to a subroutine sets the prototype. */
3935 const char *const ptr = SvPV_const(sstr, len);
3937 SvGROW(dstr, len + 1);
3938 Copy(ptr, SvPVX(dstr), len + 1, char);
3939 SvCUR_set(dstr, len);
3941 SvFLAGS(dstr) |= sflags & SVf_UTF8;
3945 } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3946 const char * const type = sv_reftype(dstr,0);
3948 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op));
3950 Perl_croak(aTHX_ "Cannot copy to %s", type);
3951 } else if (sflags & SVf_ROK) {
3952 if (isGV_with_GP(dstr) && dtype == SVt_PVGV
3953 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
3956 if (GvIMPORTED(dstr) != GVf_IMPORTED
3957 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3959 GvIMPORTED_on(dstr);
3964 glob_assign_glob(dstr, sstr, dtype);
3968 if (dtype >= SVt_PV) {
3969 if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3970 glob_assign_ref(dstr, sstr);
3973 if (SvPVX_const(dstr)) {
3979 (void)SvOK_off(dstr);
3980 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3981 SvFLAGS(dstr) |= sflags & SVf_ROK;
3982 assert(!(sflags & SVp_NOK));
3983 assert(!(sflags & SVp_IOK));
3984 assert(!(sflags & SVf_NOK));
3985 assert(!(sflags & SVf_IOK));
3987 else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3988 if (!(sflags & SVf_OK)) {
3989 if (ckWARN(WARN_MISC))
3990 Perl_warner(aTHX_ packWARN(WARN_MISC),
3991 "Undefined value assigned to typeglob");
3994 GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
3995 if (dstr != (const SV *)gv) {
3997 gp_free(MUTABLE_GV(dstr));
3998 GvGP(dstr) = gp_ref(GvGP(gv));
4002 else if (sflags & SVp_POK) {
4006 * Check to see if we can just swipe the string. If so, it's a
4007 * possible small lose on short strings, but a big win on long ones.
4008 * It might even be a win on short strings if SvPVX_const(dstr)
4009 * has to be allocated and SvPVX_const(sstr) has to be freed.
4010 * Likewise if we can set up COW rather than doing an actual copy, we
4011 * drop to the else clause, as the swipe code and the COW setup code
4012 * have much in common.
4015 /* Whichever path we take through the next code, we want this true,
4016 and doing it now facilitates the COW check. */
4017 (void)SvPOK_only(dstr);
4020 /* If we're already COW then this clause is not true, and if COW
4021 is allowed then we drop down to the else and make dest COW
4022 with us. If caller hasn't said that we're allowed to COW
4023 shared hash keys then we don't do the COW setup, even if the
4024 source scalar is a shared hash key scalar. */
4025 (((flags & SV_COW_SHARED_HASH_KEYS)
4026 ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4027 : 1 /* If making a COW copy is forbidden then the behaviour we
4028 desire is as if the source SV isn't actually already
4029 COW, even if it is. So we act as if the source flags
4030 are not COW, rather than actually testing them. */
4032 #ifndef PERL_OLD_COPY_ON_WRITE
4033 /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4034 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4035 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4036 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4037 but in turn, it's somewhat dead code, never expected to go
4038 live, but more kept as a placeholder on how to do it better
4039 in a newer implementation. */
4040 /* If we are COW and dstr is a suitable target then we drop down
4041 into the else and make dest a COW of us. */
4042 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4047 (sflags & SVs_TEMP) && /* slated for free anyway? */
4048 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4049 (!(flags & SV_NOSTEAL)) &&
4050 /* and we're allowed to steal temps */
4051 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4052 SvLEN(sstr) && /* and really is a string */
4053 /* and won't be needed again, potentially */
4054 !(PL_op && PL_op->op_type == OP_AASSIGN))
4055 #ifdef PERL_OLD_COPY_ON_WRITE
4056 && ((flags & SV_COW_SHARED_HASH_KEYS)
4057 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4058 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4059 && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4063 /* Failed the swipe test, and it's not a shared hash key either.
4064 Have to copy the string. */
4065 STRLEN len = SvCUR(sstr);
4066 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4067 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4068 SvCUR_set(dstr, len);
4069 *SvEND(dstr) = '\0';
4071 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4073 /* Either it's a shared hash key, or it's suitable for
4074 copy-on-write or we can swipe the string. */
4076 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4080 #ifdef PERL_OLD_COPY_ON_WRITE
4082 if ((sflags & (SVf_FAKE | SVf_READONLY))
4083 != (SVf_FAKE | SVf_READONLY)) {
4084 SvREADONLY_on(sstr);
4086 /* Make the source SV into a loop of 1.
4087 (about to become 2) */
4088 SV_COW_NEXT_SV_SET(sstr, sstr);
4092 /* Initial code is common. */
4093 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4098 /* making another shared SV. */
4099 STRLEN cur = SvCUR(sstr);
4100 STRLEN len = SvLEN(sstr);
4101 #ifdef PERL_OLD_COPY_ON_WRITE
4103 assert (SvTYPE(dstr) >= SVt_PVIV);
4104 /* SvIsCOW_normal */
4105 /* splice us in between source and next-after-source. */
4106 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4107 SV_COW_NEXT_SV_SET(sstr, dstr);
4108 SvPV_set(dstr, SvPVX_mutable(sstr));
4112 /* SvIsCOW_shared_hash */
4113 DEBUG_C(PerlIO_printf(Perl_debug_log,
4114 "Copy on write: Sharing hash\n"));
4116 assert (SvTYPE(dstr) >= SVt_PV);
4118 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4120 SvLEN_set(dstr, len);
4121 SvCUR_set(dstr, cur);
4122 SvREADONLY_on(dstr);
4126 { /* Passes the swipe test. */
4127 SvPV_set(dstr, SvPVX_mutable(sstr));
4128 SvLEN_set(dstr, SvLEN(sstr));
4129 SvCUR_set(dstr, SvCUR(sstr));
4132 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4133 SvPV_set(sstr, NULL);
4139 if (sflags & SVp_NOK) {
4140 SvNV_set(dstr, SvNVX(sstr));
4142 if (sflags & SVp_IOK) {
4143 SvIV_set(dstr, SvIVX(sstr));
4144 /* Must do this otherwise some other overloaded use of 0x80000000
4145 gets confused. I guess SVpbm_VALID */
4146 if (sflags & SVf_IVisUV)
4149 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4151 const MAGIC * const smg = SvVSTRING_mg(sstr);
4153 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4154 smg->mg_ptr, smg->mg_len);
4155 SvRMAGICAL_on(dstr);
4159 else if (sflags & (SVp_IOK|SVp_NOK)) {
4160 (void)SvOK_off(dstr);
4161 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4162 if (sflags & SVp_IOK) {
4163 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4164 SvIV_set(dstr, SvIVX(sstr));
4166 if (sflags & SVp_NOK) {
4167 SvNV_set(dstr, SvNVX(sstr));
4171 if (isGV_with_GP(sstr)) {
4172 /* This stringification rule for globs is spread in 3 places.
4173 This feels bad. FIXME. */
4174 const U32 wasfake = sflags & SVf_FAKE;
4176 /* FAKE globs can get coerced, so need to turn this off
4177 temporarily if it is on. */
4179 gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4180 SvFLAGS(sstr) |= wasfake;
4183 (void)SvOK_off(dstr);
4185 if (SvTAINTED(sstr))
4190 =for apidoc sv_setsv_mg
4192 Like C<sv_setsv>, but also handles 'set' magic.
4198 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4200 PERL_ARGS_ASSERT_SV_SETSV_MG;
4202 sv_setsv(dstr,sstr);
4206 #ifdef PERL_OLD_COPY_ON_WRITE
4208 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4210 STRLEN cur = SvCUR(sstr);
4211 STRLEN len = SvLEN(sstr);
4212 register char *new_pv;
4214 PERL_ARGS_ASSERT_SV_SETSV_COW;
4217 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4218 (void*)sstr, (void*)dstr);
4225 if (SvTHINKFIRST(dstr))
4226 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4227 else if (SvPVX_const(dstr))
4228 Safefree(SvPVX_const(dstr));
4232 SvUPGRADE(dstr, SVt_PVIV);
4234 assert (SvPOK(sstr));
4235 assert (SvPOKp(sstr));
4236 assert (!SvIOK(sstr));
4237 assert (!SvIOKp(sstr));
4238 assert (!SvNOK(sstr));
4239 assert (!SvNOKp(sstr));
4241 if (SvIsCOW(sstr)) {
4243 if (SvLEN(sstr) == 0) {
4244 /* source is a COW shared hash key. */
4245 DEBUG_C(PerlIO_printf(Perl_debug_log,
4246 "Fast copy on write: Sharing hash\n"));
4247 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4250 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4252 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4253 SvUPGRADE(sstr, SVt_PVIV);
4254 SvREADONLY_on(sstr);
4256 DEBUG_C(PerlIO_printf(Perl_debug_log,
4257 "Fast copy on write: Converting sstr to COW\n"));
4258 SV_COW_NEXT_SV_SET(dstr, sstr);
4260 SV_COW_NEXT_SV_SET(sstr, dstr);
4261 new_pv = SvPVX_mutable(sstr);
4264 SvPV_set(dstr, new_pv);
4265 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4268 SvLEN_set(dstr, len);
4269 SvCUR_set(dstr, cur);
4278 =for apidoc sv_setpvn
4280 Copies a string into an SV. The C<len> parameter indicates the number of
4281 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4282 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4288 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4291 register char *dptr;
4293 PERL_ARGS_ASSERT_SV_SETPVN;
4295 SV_CHECK_THINKFIRST_COW_DROP(sv);
4301 /* len is STRLEN which is unsigned, need to copy to signed */
4304 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4306 SvUPGRADE(sv, SVt_PV);
4308 dptr = SvGROW(sv, len + 1);
4309 Move(ptr,dptr,len,char);
4312 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4317 =for apidoc sv_setpvn_mg
4319 Like C<sv_setpvn>, but also handles 'set' magic.
4325 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4327 PERL_ARGS_ASSERT_SV_SETPVN_MG;
4329 sv_setpvn(sv,ptr,len);
4334 =for apidoc sv_setpv
4336 Copies a string into an SV. The string must be null-terminated. Does not
4337 handle 'set' magic. See C<sv_setpv_mg>.
4343 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4346 register STRLEN len;
4348 PERL_ARGS_ASSERT_SV_SETPV;
4350 SV_CHECK_THINKFIRST_COW_DROP(sv);
4356 SvUPGRADE(sv, SVt_PV);
4358 SvGROW(sv, len + 1);
4359 Move(ptr,SvPVX(sv),len+1,char);
4361 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4366 =for apidoc sv_setpv_mg
4368 Like C<sv_setpv>, but also handles 'set' magic.
4374 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4376 PERL_ARGS_ASSERT_SV_SETPV_MG;
4383 =for apidoc sv_usepvn_flags
4385 Tells an SV to use C<ptr> to find its string value. Normally the
4386 string is stored inside the SV but sv_usepvn allows the SV to use an
4387 outside string. The C<ptr> should point to memory that was allocated
4388 by C<malloc>. The string length, C<len>, must be supplied. By default
4389 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4390 so that pointer should not be freed or used by the programmer after
4391 giving it to sv_usepvn, and neither should any pointers from "behind"
4392 that pointer (e.g. ptr + 1) be used.
4394 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4395 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4396 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4397 C<len>, and already meets the requirements for storing in C<SvPVX>)
4403 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4408 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4410 SV_CHECK_THINKFIRST_COW_DROP(sv);
4411 SvUPGRADE(sv, SVt_PV);
4414 if (flags & SV_SMAGIC)
4418 if (SvPVX_const(sv))
4422 if (flags & SV_HAS_TRAILING_NUL)
4423 assert(ptr[len] == '\0');
4426 allocate = (flags & SV_HAS_TRAILING_NUL)
4428 #ifdef Perl_safesysmalloc_size
4431 PERL_STRLEN_ROUNDUP(len + 1);
4433 if (flags & SV_HAS_TRAILING_NUL) {
4434 /* It's long enough - do nothing.
4435 Specfically Perl_newCONSTSUB is relying on this. */
4438 /* Force a move to shake out bugs in callers. */
4439 char *new_ptr = (char*)safemalloc(allocate);
4440 Copy(ptr, new_ptr, len, char);
4441 PoisonFree(ptr,len,char);
4445 ptr = (char*) saferealloc (ptr, allocate);
4448 #ifdef Perl_safesysmalloc_size
4449 SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4451 SvLEN_set(sv, allocate);
4455 if (!(flags & SV_HAS_TRAILING_NUL)) {
4458 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4460 if (flags & SV_SMAGIC)
4464 #ifdef PERL_OLD_COPY_ON_WRITE
4465 /* Need to do this *after* making the SV normal, as we need the buffer
4466 pointer to remain valid until after we've copied it. If we let go too early,
4467 another thread could invalidate it by unsharing last of the same hash key
4468 (which it can do by means other than releasing copy-on-write Svs)
4469 or by changing the other copy-on-write SVs in the loop. */
4471 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4473 PERL_ARGS_ASSERT_SV_RELEASE_COW;
4475 { /* this SV was SvIsCOW_normal(sv) */
4476 /* we need to find the SV pointing to us. */
4477 SV *current = SV_COW_NEXT_SV(after);
4479 if (current == sv) {
4480 /* The SV we point to points back to us (there were only two of us
4482 Hence other SV is no longer copy on write either. */
4484 SvREADONLY_off(after);
4486 /* We need to follow the pointers around the loop. */
4488 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4491 /* don't loop forever if the structure is bust, and we have
4492 a pointer into a closed loop. */
4493 assert (current != after);
4494 assert (SvPVX_const(current) == pvx);
4496 /* Make the SV before us point to the SV after us. */
4497 SV_COW_NEXT_SV_SET(current, after);
4503 =for apidoc sv_force_normal_flags
4505 Undo various types of fakery on an SV: if the PV is a shared string, make
4506 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4507 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4508 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4509 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4510 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4511 set to some other value.) In addition, the C<flags> parameter gets passed to
4512 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4513 with flags set to 0.
4519 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4523 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4525 #ifdef PERL_OLD_COPY_ON_WRITE
4526 if (SvREADONLY(sv)) {
4528 const char * const pvx = SvPVX_const(sv);
4529 const STRLEN len = SvLEN(sv);
4530 const STRLEN cur = SvCUR(sv);
4531 /* next COW sv in the loop. If len is 0 then this is a shared-hash
4532 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4533 we'll fail an assertion. */
4534 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4537 PerlIO_printf(Perl_debug_log,
4538 "Copy on write: Force normal %ld\n",
4544 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4547 if (flags & SV_COW_DROP_PV) {
4548 /* OK, so we don't need to copy our buffer. */
4551 SvGROW(sv, cur + 1);
4552 Move(pvx,SvPVX(sv),cur,char);
4557 sv_release_COW(sv, pvx, next);
4559 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4565 else if (IN_PERL_RUNTIME)
4566 Perl_croak(aTHX_ "%s", PL_no_modify);
4569 if (SvREADONLY(sv)) {
4571 const char * const pvx = SvPVX_const(sv);
4572 const STRLEN len = SvCUR(sv);
4577 SvGROW(sv, len + 1);
4578 Move(pvx,SvPVX(sv),len,char);
4580 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4582 else if (IN_PERL_RUNTIME)
4583 Perl_croak(aTHX_ "%s", PL_no_modify);
4587 sv_unref_flags(sv, flags);
4588 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4595 Efficient removal of characters from the beginning of the string buffer.
4596 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4597 the string buffer. The C<ptr> becomes the first character of the adjusted
4598 string. Uses the "OOK hack".
4599 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4600 refer to the same chunk of data.
4606 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4612 const U8 *real_start;
4616 PERL_ARGS_ASSERT_SV_CHOP;
4618 if (!ptr || !SvPOKp(sv))
4620 delta = ptr - SvPVX_const(sv);
4622 /* Nothing to do. */
4625 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4626 nothing uses the value of ptr any more. */
4627 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4628 if (ptr <= SvPVX_const(sv))
4629 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4630 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4631 SV_CHECK_THINKFIRST(sv);
4632 if (delta > max_delta)
4633 Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4634 SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4635 SvPVX_const(sv) + max_delta);
4638 if (!SvLEN(sv)) { /* make copy of shared string */
4639 const char *pvx = SvPVX_const(sv);
4640 const STRLEN len = SvCUR(sv);
4641 SvGROW(sv, len + 1);
4642 Move(pvx,SvPVX(sv),len,char);
4645 SvFLAGS(sv) |= SVf_OOK;
4648 SvOOK_offset(sv, old_delta);
4650 SvLEN_set(sv, SvLEN(sv) - delta);
4651 SvCUR_set(sv, SvCUR(sv) - delta);
4652 SvPV_set(sv, SvPVX(sv) + delta);
4654 p = (U8 *)SvPVX_const(sv);
4659 real_start = p - delta;
4663 if (delta < 0x100) {
4667 p -= sizeof(STRLEN);
4668 Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4672 /* Fill the preceding buffer with sentinals to verify that no-one is
4674 while (p > real_start) {
4682 =for apidoc sv_catpvn
4684 Concatenates the string onto the end of the string which is in the SV. The
4685 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4686 status set, then the bytes appended should be valid UTF-8.
4687 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4689 =for apidoc sv_catpvn_flags
4691 Concatenates the string onto the end of the string which is in the SV. The
4692 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4693 status set, then the bytes appended should be valid UTF-8.
4694 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4695 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4696 in terms of this function.
4702 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4706 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4708 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4710 SvGROW(dsv, dlen + slen + 1);
4712 sstr = SvPVX_const(dsv);
4713 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4714 SvCUR_set(dsv, SvCUR(dsv) + slen);
4716 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4718 if (flags & SV_SMAGIC)
4723 =for apidoc sv_catsv
4725 Concatenates the string from SV C<ssv> onto the end of the string in
4726 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4727 not 'set' magic. See C<sv_catsv_mg>.
4729 =for apidoc sv_catsv_flags
4731 Concatenates the string from SV C<ssv> onto the end of the string in
4732 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4733 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4734 and C<sv_catsv_nomg> are implemented in terms of this function.
4739 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4743 PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4747 const char *spv = SvPV_const(ssv, slen);
4749 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4750 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4751 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4752 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4753 dsv->sv_flags doesn't have that bit set.
4754 Andy Dougherty 12 Oct 2001
4756 const I32 sutf8 = DO_UTF8(ssv);
4759 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4761 dutf8 = DO_UTF8(dsv);
4763 if (dutf8 != sutf8) {
4765 /* Not modifying source SV, so taking a temporary copy. */
4766 SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4768 sv_utf8_upgrade(csv);
4769 spv = SvPV_const(csv, slen);
4772 /* Leave enough space for the cat that's about to happen */
4773 sv_utf8_upgrade_flags_grow(dsv, 0, slen);
4775 sv_catpvn_nomg(dsv, spv, slen);
4778 if (flags & SV_SMAGIC)
4783 =for apidoc sv_catpv
4785 Concatenates the string onto the end of the string which is in the SV.
4786 If the SV has the UTF-8 status set, then the bytes appended should be
4787 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4792 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4795 register STRLEN len;
4799 PERL_ARGS_ASSERT_SV_CATPV;
4803 junk = SvPV_force(sv, tlen);
4805 SvGROW(sv, tlen + len + 1);
4807 ptr = SvPVX_const(sv);
4808 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4809 SvCUR_set(sv, SvCUR(sv) + len);
4810 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4815 =for apidoc sv_catpv_mg
4817 Like C<sv_catpv>, but also handles 'set' magic.
4823 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4825 PERL_ARGS_ASSERT_SV_CATPV_MG;
4834 Creates a new SV. A non-zero C<len> parameter indicates the number of
4835 bytes of preallocated string space the SV should have. An extra byte for a
4836 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
4837 space is allocated.) The reference count for the new SV is set to 1.
4839 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4840 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4841 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4842 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
4843 modules supporting older perls.
4849 Perl_newSV(pTHX_ const STRLEN len)
4856 sv_upgrade(sv, SVt_PV);
4857 SvGROW(sv, len + 1);
4862 =for apidoc sv_magicext
4864 Adds magic to an SV, upgrading it if necessary. Applies the
4865 supplied vtable and returns a pointer to the magic added.
4867 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4868 In particular, you can add magic to SvREADONLY SVs, and add more than
4869 one instance of the same 'how'.
4871 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4872 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4873 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4874 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4876 (This is now used as a subroutine by C<sv_magic>.)
4881 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
4882 const MGVTBL *const vtable, const char *const name, const I32 namlen)
4887 PERL_ARGS_ASSERT_SV_MAGICEXT;
4889 SvUPGRADE(sv, SVt_PVMG);
4890 Newxz(mg, 1, MAGIC);
4891 mg->mg_moremagic = SvMAGIC(sv);
4892 SvMAGIC_set(sv, mg);
4894 /* Sometimes a magic contains a reference loop, where the sv and
4895 object refer to each other. To prevent a reference loop that
4896 would prevent such objects being freed, we look for such loops
4897 and if we find one we avoid incrementing the object refcount.
4899 Note we cannot do this to avoid self-tie loops as intervening RV must
4900 have its REFCNT incremented to keep it in existence.
4903 if (!obj || obj == sv ||
4904 how == PERL_MAGIC_arylen ||
4905 how == PERL_MAGIC_symtab ||
4906 (SvTYPE(obj) == SVt_PVGV &&
4907 (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
4908 || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
4909 || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
4914 mg->mg_obj = SvREFCNT_inc_simple(obj);
4915 mg->mg_flags |= MGf_REFCOUNTED;
4918 /* Normal self-ties simply pass a null object, and instead of
4919 using mg_obj directly, use the SvTIED_obj macro to produce a
4920 new RV as needed. For glob "self-ties", we are tieing the PVIO
4921 with an RV obj pointing to the glob containing the PVIO. In
4922 this case, to avoid a reference loop, we need to weaken the
4926 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4927 obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
4933 mg->mg_len = namlen;
4936 mg->mg_ptr = savepvn(name, namlen);
4937 else if (namlen == HEf_SVKEY) {
4938 /* Yes, this is casting away const. This is only for the case of
4939 HEf_SVKEY. I think we need to document this abberation of the
4940 constness of the API, rather than making name non-const, as
4941 that change propagating outwards a long way. */
4942 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
4944 mg->mg_ptr = (char *) name;
4946 mg->mg_virtual = (MGVTBL *) vtable;
4950 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4955 =for apidoc sv_magic
4957 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4958 then adds a new magic item of type C<how> to the head of the magic list.
4960 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4961 handling of the C<name> and C<namlen> arguments.
4963 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4964 to add more than one instance of the same 'how'.
4970 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
4971 const char *const name, const I32 namlen)
4974 const MGVTBL *vtable;
4977 PERL_ARGS_ASSERT_SV_MAGIC;
4979 #ifdef PERL_OLD_COPY_ON_WRITE
4981 sv_force_normal_flags(sv, 0);
4983 if (SvREADONLY(sv)) {
4985 /* its okay to attach magic to shared strings; the subsequent
4986 * upgrade to PVMG will unshare the string */
4987 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4990 && how != PERL_MAGIC_regex_global
4991 && how != PERL_MAGIC_bm
4992 && how != PERL_MAGIC_fm
4993 && how != PERL_MAGIC_sv
4994 && how != PERL_MAGIC_backref
4997 Perl_croak(aTHX_ "%s", PL_no_modify);
5000 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5001 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5002 /* sv_magic() refuses to add a magic of the same 'how' as an
5005 if (how == PERL_MAGIC_taint) {
5007 /* Any scalar which already had taint magic on which someone
5008 (erroneously?) did SvIOK_on() or similar will now be
5009 incorrectly sporting public "OK" flags. */
5010 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5018 vtable = &PL_vtbl_sv;
5020 case PERL_MAGIC_overload:
5021 vtable = &PL_vtbl_amagic;
5023 case PERL_MAGIC_overload_elem:
5024 vtable = &PL_vtbl_amagicelem;
5026 case PERL_MAGIC_overload_table:
5027 vtable = &PL_vtbl_ovrld;
5030 vtable = &PL_vtbl_bm;
5032 case PERL_MAGIC_regdata:
5033 vtable = &PL_vtbl_regdata;
5035 case PERL_MAGIC_regdatum:
5036 vtable = &PL_vtbl_regdatum;
5038 case PERL_MAGIC_env:
5039 vtable = &PL_vtbl_env;
5042 vtable = &PL_vtbl_fm;
5044 case PERL_MAGIC_envelem:
5045 vtable = &PL_vtbl_envelem;
5047 case PERL_MAGIC_regex_global:
5048 vtable = &PL_vtbl_mglob;
5050 case PERL_MAGIC_isa:
5051 vtable = &PL_vtbl_isa;
5053 case PERL_MAGIC_isaelem:
5054 vtable = &PL_vtbl_isaelem;
5056 case PERL_MAGIC_nkeys:
5057 vtable = &PL_vtbl_nkeys;
5059 case PERL_MAGIC_dbfile:
5062 case PERL_MAGIC_dbline:
5063 vtable = &PL_vtbl_dbline;
5065 #ifdef USE_LOCALE_COLLATE
5066 case PERL_MAGIC_collxfrm:
5067 vtable = &PL_vtbl_collxfrm;
5069 #endif /* USE_LOCALE_COLLATE */
5070 case PERL_MAGIC_tied:
5071 vtable = &PL_vtbl_pack;
5073 case PERL_MAGIC_tiedelem:
5074 case PERL_MAGIC_tiedscalar:
5075 vtable = &PL_vtbl_packelem;
5078 vtable = &PL_vtbl_regexp;
5080 case PERL_MAGIC_hints:
5081 /* As this vtable is all NULL, we can reuse it. */
5082 case PERL_MAGIC_sig:
5083 vtable = &PL_vtbl_sig;
5085 case PERL_MAGIC_sigelem:
5086 vtable = &PL_vtbl_sigelem;
5088 case PERL_MAGIC_taint:
5089 vtable = &PL_vtbl_taint;
5091 case PERL_MAGIC_uvar:
5092 vtable = &PL_vtbl_uvar;
5094 case PERL_MAGIC_vec:
5095 vtable = &PL_vtbl_vec;
5097 case PERL_MAGIC_arylen_p:
5098 case PERL_MAGIC_rhash:
5099 case PERL_MAGIC_symtab:
5100 case PERL_MAGIC_vstring:
5103 case PERL_MAGIC_utf8:
5104 vtable = &PL_vtbl_utf8;
5106 case PERL_MAGIC_substr:
5107 vtable = &PL_vtbl_substr;
5109 case PERL_MAGIC_defelem:
5110 vtable = &PL_vtbl_defelem;
5112 case PERL_MAGIC_arylen:
5113 vtable = &PL_vtbl_arylen;
5115 case PERL_MAGIC_pos:
5116 vtable = &PL_vtbl_pos;
5118 case PERL_MAGIC_backref:
5119 vtable = &PL_vtbl_backref;
5121 case PERL_MAGIC_hintselem:
5122 vtable = &PL_vtbl_hintselem;
5124 case PERL_MAGIC_ext:
5125 /* Reserved for use by extensions not perl internals. */
5126 /* Useful for attaching extension internal data to perl vars. */
5127 /* Note that multiple extensions may clash if magical scalars */
5128 /* etc holding private data from one are passed to another. */
5132 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5135 /* Rest of work is done else where */
5136 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5139 case PERL_MAGIC_taint:
5142 case PERL_MAGIC_ext:
5143 case PERL_MAGIC_dbfile:
5150 =for apidoc sv_unmagic
5152 Removes all magic of type C<type> from an SV.
5158 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5163 PERL_ARGS_ASSERT_SV_UNMAGIC;
5165 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5167 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5168 for (mg = *mgp; mg; mg = *mgp) {
5169 if (mg->mg_type == type) {
5170 const MGVTBL* const vtbl = mg->mg_virtual;
5171 *mgp = mg->mg_moremagic;
5172 if (vtbl && vtbl->svt_free)
5173 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5174 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5176 Safefree(mg->mg_ptr);
5177 else if (mg->mg_len == HEf_SVKEY)
5178 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5179 else if (mg->mg_type == PERL_MAGIC_utf8)
5180 Safefree(mg->mg_ptr);
5182 if (mg->mg_flags & MGf_REFCOUNTED)
5183 SvREFCNT_dec(mg->mg_obj);
5187 mgp = &mg->mg_moremagic;
5191 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5192 SvMAGIC_set(sv, NULL);
5199 =for apidoc sv_rvweaken
5201 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5202 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5203 push a back-reference to this RV onto the array of backreferences
5204 associated with that magic. If the RV is magical, set magic will be
5205 called after the RV is cleared.
5211 Perl_sv_rvweaken(pTHX_ SV *const sv)
5215 PERL_ARGS_ASSERT_SV_RVWEAKEN;
5217 if (!SvOK(sv)) /* let undefs pass */
5220 Perl_croak(aTHX_ "Can't weaken a nonreference");
5221 else if (SvWEAKREF(sv)) {
5222 if (ckWARN(WARN_MISC))
5223 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5227 Perl_sv_add_backref(aTHX_ tsv, sv);
5233 /* Give tsv backref magic if it hasn't already got it, then push a
5234 * back-reference to sv onto the array associated with the backref magic.
5237 /* A discussion about the backreferences array and its refcount:
5239 * The AV holding the backreferences is pointed to either as the mg_obj of
5240 * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
5241 * structure, from the xhv_backreferences field. (A HV without hv_aux will
5242 * have the standard magic instead.) The array is created with a refcount
5243 * of 2. This means that if during global destruction the array gets
5244 * picked on first to have its refcount decremented by the random zapper,
5245 * it won't actually be freed, meaning it's still theere for when its
5246 * parent gets freed.
5247 * When the parent SV is freed, in the case of magic, the magic is freed,
5248 * Perl_magic_killbackrefs is called which decrements one refcount, then
5249 * mg_obj is freed which kills the second count.
5250 * In the vase of a HV being freed, one ref is removed by
5251 * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
5256 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5261 PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5263 if (SvTYPE(tsv) == SVt_PVHV) {
5264 AV **const avp = Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5268 /* There is no AV in the offical place - try a fixup. */
5269 MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
5272 /* Aha. They've got it stowed in magic. Bring it back. */
5273 av = MUTABLE_AV(mg->mg_obj);
5274 /* Stop mg_free decreasing the refernce count. */
5276 /* Stop mg_free even calling the destructor, given that
5277 there's no AV to free up. */
5279 sv_unmagic(tsv, PERL_MAGIC_backref);
5283 SvREFCNT_inc_simple_void(av); /* see discussion above */
5288 const MAGIC *const mg
5289 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5291 av = MUTABLE_AV(mg->mg_obj);
5295 sv_magic(tsv, MUTABLE_SV(av), PERL_MAGIC_backref, NULL, 0);
5296 /* av now has a refcnt of 2; see discussion above */
5299 if (AvFILLp(av) >= AvMAX(av)) {
5300 av_extend(av, AvFILLp(av)+1);
5302 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5305 /* delete a back-reference to ourselves from the backref magic associated
5306 * with the SV we point to.
5310 S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5317 PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5319 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5320 av = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5321 /* We mustn't attempt to "fix up" the hash here by moving the
5322 backreference array back to the hv_aux structure, as that is stored
5323 in the main HvARRAY(), and hfreentries assumes that no-one
5324 reallocates HvARRAY() while it is running. */
5327 const MAGIC *const mg
5328 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5330 av = MUTABLE_AV(mg->mg_obj);
5334 Perl_croak(aTHX_ "panic: del_backref");
5336 assert(!SvIS_FREED(av));
5339 /* We shouldn't be in here more than once, but for paranoia reasons lets
5341 for (i = AvFILLp(av); i >= 0; i--) {
5343 const SSize_t fill = AvFILLp(av);
5345 /* We weren't the last entry.
5346 An unordered list has this property that you can take the
5347 last element off the end to fill the hole, and it's still
5348 an unordered list :-)
5353 AvFILLp(av) = fill - 1;
5359 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5361 SV **svp = AvARRAY(av);
5363 PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5364 PERL_UNUSED_ARG(sv);
5366 assert(!svp || !SvIS_FREED(av));
5368 SV *const *const last = svp + AvFILLp(av);
5370 while (svp <= last) {
5372 SV *const referrer = *svp;
5373 if (SvWEAKREF(referrer)) {
5374 /* XXX Should we check that it hasn't changed? */
5375 SvRV_set(referrer, 0);
5377 SvWEAKREF_off(referrer);
5378 SvSETMAGIC(referrer);
5379 } else if (SvTYPE(referrer) == SVt_PVGV ||
5380 SvTYPE(referrer) == SVt_PVLV) {
5381 /* You lookin' at me? */
5382 assert(GvSTASH(referrer));
5383 assert(GvSTASH(referrer) == (const HV *)sv);
5384 GvSTASH(referrer) = 0;
5387 "panic: magic_killbackrefs (flags=%"UVxf")",
5388 (UV)SvFLAGS(referrer));
5396 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5401 =for apidoc sv_insert
5403 Inserts a string at the specified offset/length within the SV. Similar to
5404 the Perl substr() function. Handles get magic.
5406 =for apidoc sv_insert_flags
5408 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5414 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5419 register char *midend;
5420 register char *bigend;
5424 PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5427 Perl_croak(aTHX_ "Can't modify non-existent substring");
5428 SvPV_force_flags(bigstr, curlen, flags);
5429 (void)SvPOK_only_UTF8(bigstr);
5430 if (offset + len > curlen) {
5431 SvGROW(bigstr, offset+len+1);
5432 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5433 SvCUR_set(bigstr, offset+len);
5437 i = littlelen - len;
5438 if (i > 0) { /* string might grow */
5439 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5440 mid = big + offset + len;
5441 midend = bigend = big + SvCUR(bigstr);
5444 while (midend > mid) /* shove everything down */
5445 *--bigend = *--midend;
5446 Move(little,big+offset,littlelen,char);
5447 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5452 Move(little,SvPVX(bigstr)+offset,len,char);
5457 big = SvPVX(bigstr);
5460 bigend = big + SvCUR(bigstr);
5462 if (midend > bigend)
5463 Perl_croak(aTHX_ "panic: sv_insert");
5465 if (mid - big > bigend - midend) { /* faster to shorten from end */
5467 Move(little, mid, littlelen,char);
5470 i = bigend - midend;
5472 Move(midend, mid, i,char);
5476 SvCUR_set(bigstr, mid - big);
5478 else if ((i = mid - big)) { /* faster from front */
5479 midend -= littlelen;
5481 Move(big, midend - i, i, char);
5482 sv_chop(bigstr,midend-i);
5484 Move(little, mid, littlelen,char);
5486 else if (littlelen) {
5487 midend -= littlelen;
5488 sv_chop(bigstr,midend);
5489 Move(little,midend,littlelen,char);
5492 sv_chop(bigstr,midend);
5498 =for apidoc sv_replace
5500 Make the first argument a copy of the second, then delete the original.
5501 The target SV physically takes over ownership of the body of the source SV
5502 and inherits its flags; however, the target keeps any magic it owns,
5503 and any magic in the source is discarded.
5504 Note that this is a rather specialist SV copying operation; most of the
5505 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5511 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5514 const U32 refcnt = SvREFCNT(sv);
5516 PERL_ARGS_ASSERT_SV_REPLACE;
5518 SV_CHECK_THINKFIRST_COW_DROP(sv);
5519 if (SvREFCNT(nsv) != 1) {
5520 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
5521 UVuf " != 1)", (UV) SvREFCNT(nsv));
5523 if (SvMAGICAL(sv)) {
5527 sv_upgrade(nsv, SVt_PVMG);
5528 SvMAGIC_set(nsv, SvMAGIC(sv));
5529 SvFLAGS(nsv) |= SvMAGICAL(sv);
5531 SvMAGIC_set(sv, NULL);
5535 assert(!SvREFCNT(sv));
5536 #ifdef DEBUG_LEAKING_SCALARS
5537 sv->sv_flags = nsv->sv_flags;
5538 sv->sv_any = nsv->sv_any;
5539 sv->sv_refcnt = nsv->sv_refcnt;
5540 sv->sv_u = nsv->sv_u;
5542 StructCopy(nsv,sv,SV);
5544 if(SvTYPE(sv) == SVt_IV) {
5546 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5550 #ifdef PERL_OLD_COPY_ON_WRITE
5551 if (SvIsCOW_normal(nsv)) {
5552 /* We need to follow the pointers around the loop to make the
5553 previous SV point to sv, rather than nsv. */
5556 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5559 assert(SvPVX_const(current) == SvPVX_const(nsv));
5561 /* Make the SV before us point to the SV after us. */
5563 PerlIO_printf(Perl_debug_log, "previous is\n");
5565 PerlIO_printf(Perl_debug_log,
5566 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5567 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5569 SV_COW_NEXT_SV_SET(current, sv);
5572 SvREFCNT(sv) = refcnt;
5573 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5579 =for apidoc sv_clear
5581 Clear an SV: call any destructors, free up any memory used by the body,
5582 and free the body itself. The SV's head is I<not> freed, although
5583 its type is set to all 1's so that it won't inadvertently be assumed
5584 to be live during global destruction etc.
5585 This function should only be called when REFCNT is zero. Most of the time
5586 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5593 Perl_sv_clear(pTHX_ register SV *const sv)
5596 const U32 type = SvTYPE(sv);
5597 const struct body_details *const sv_type_details
5598 = bodies_by_type + type;
5601 PERL_ARGS_ASSERT_SV_CLEAR;
5602 assert(SvREFCNT(sv) == 0);
5603 assert(SvTYPE(sv) != SVTYPEMASK);
5605 if (type <= SVt_IV) {
5606 /* See the comment in sv.h about the collusion between this early
5607 return and the overloading of the NULL and IV slots in the size
5610 SV * const target = SvRV(sv);
5612 sv_del_backref(target, sv);
5614 SvREFCNT_dec(target);
5616 SvFLAGS(sv) &= SVf_BREAK;
5617 SvFLAGS(sv) |= SVTYPEMASK;
5622 if (PL_defstash && /* Still have a symbol table? */
5629 stash = SvSTASH(sv);
5630 destructor = StashHANDLER(stash,DESTROY);
5632 /* A constant subroutine can have no side effects, so
5633 don't bother calling it. */
5634 && !CvCONST(destructor)
5635 /* Don't bother calling an empty destructor */
5636 && (CvISXSUB(destructor)
5637 || CvSTART(destructor)->op_next->op_type != OP_LEAVESUB))
5639 SV* const tmpref = newRV(sv);
5640 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5642 PUSHSTACKi(PERLSI_DESTROY);
5647 call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5653 if(SvREFCNT(tmpref) < 2) {
5654 /* tmpref is not kept alive! */
5656 SvRV_set(tmpref, NULL);
5659 SvREFCNT_dec(tmpref);
5661 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5665 if (PL_in_clean_objs)
5666 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5668 /* DESTROY gave object new lease on life */
5674 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5675 SvOBJECT_off(sv); /* Curse the object. */
5676 if (type != SVt_PVIO)
5677 --PL_sv_objcount; /* XXX Might want something more general */
5680 if (type >= SVt_PVMG) {
5681 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
5682 SvREFCNT_dec(SvOURSTASH(sv));
5683 } else if (SvMAGIC(sv))
5685 if (type == SVt_PVMG && SvPAD_TYPED(sv))
5686 SvREFCNT_dec(SvSTASH(sv));
5689 /* case SVt_BIND: */
5692 IoIFP(sv) != PerlIO_stdin() &&
5693 IoIFP(sv) != PerlIO_stdout() &&
5694 IoIFP(sv) != PerlIO_stderr())
5696 io_close(MUTABLE_IO(sv), FALSE);
5698 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5699 PerlDir_close(IoDIRP(sv));
5700 IoDIRP(sv) = (DIR*)NULL;
5701 Safefree(IoTOP_NAME(sv));
5702 Safefree(IoFMT_NAME(sv));
5703 Safefree(IoBOTTOM_NAME(sv));
5706 /* FIXME for plugins */
5707 pregfree2((REGEXP*) sv);
5711 cv_undef(MUTABLE_CV(sv));
5714 if (PL_last_swash_hv == (const HV *)sv) {
5715 PL_last_swash_hv = NULL;
5717 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
5718 hv_undef(MUTABLE_HV(sv));
5721 if (PL_comppad == MUTABLE_AV(sv)) {
5725 av_undef(MUTABLE_AV(sv));
5728 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5729 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5730 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5731 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5733 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5734 SvREFCNT_dec(LvTARG(sv));
5736 if (isGV_with_GP(sv)) {
5737 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
5738 && HvNAME_get(stash))
5739 mro_method_changed_in(stash);
5740 gp_free(MUTABLE_GV(sv));
5742 unshare_hek(GvNAME_HEK(sv));
5743 /* If we're in a stash, we don't own a reference to it. However it does
5744 have a back reference to us, which needs to be cleared. */
5745 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
5746 sv_del_backref(MUTABLE_SV(stash), sv);
5748 /* FIXME. There are probably more unreferenced pointers to SVs in the
5749 interpreter struct that we should check and tidy in a similar
5751 if ((const GV *)sv == PL_last_in_gv)
5752 PL_last_in_gv = NULL;
5758 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5761 SvOOK_offset(sv, offset);
5762 SvPV_set(sv, SvPVX_mutable(sv) - offset);
5763 /* Don't even bother with turning off the OOK flag. */
5766 SV * const target = SvRV(sv);
5768 sv_del_backref(target, sv);
5770 SvREFCNT_dec(target);
5772 #ifdef PERL_OLD_COPY_ON_WRITE
5773 else if (SvPVX_const(sv)) {
5776 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5780 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
5782 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5786 } else if (SvLEN(sv)) {
5787 Safefree(SvPVX_const(sv));
5791 else if (SvPVX_const(sv) && SvLEN(sv))
5792 Safefree(SvPVX_mutable(sv));
5793 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5794 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5803 SvFLAGS(sv) &= SVf_BREAK;
5804 SvFLAGS(sv) |= SVTYPEMASK;
5806 if (sv_type_details->arena) {
5807 del_body(((char *)SvANY(sv) + sv_type_details->offset),
5808 &PL_body_roots[type]);
5810 else if (sv_type_details->body_size) {
5811 my_safefree(SvANY(sv));
5816 =for apidoc sv_newref
5818 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5825 Perl_sv_newref(pTHX_ SV *const sv)
5827 PERL_UNUSED_CONTEXT;
5836 Decrement an SV's reference count, and if it drops to zero, call
5837 C<sv_clear> to invoke destructors and free up any memory used by
5838 the body; finally, deallocate the SV's head itself.
5839 Normally called via a wrapper macro C<SvREFCNT_dec>.
5845 Perl_sv_free(pTHX_ SV *const sv)
5850 if (SvREFCNT(sv) == 0) {
5851 if (SvFLAGS(sv) & SVf_BREAK)
5852 /* this SV's refcnt has been artificially decremented to
5853 * trigger cleanup */
5855 if (PL_in_clean_all) /* All is fair */
5857 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5858 /* make sure SvREFCNT(sv)==0 happens very seldom */
5859 SvREFCNT(sv) = (~(U32)0)/2;
5862 if (ckWARN_d(WARN_INTERNAL)) {
5863 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5864 Perl_dump_sv_child(aTHX_ sv);
5866 #ifdef DEBUG_LEAKING_SCALARS
5869 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5870 if (PL_warnhook == PERL_WARNHOOK_FATAL
5871 || ckDEAD(packWARN(WARN_INTERNAL))) {
5872 /* Don't let Perl_warner cause us to escape our fate: */
5876 /* This may not return: */
5877 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5878 "Attempt to free unreferenced scalar: SV 0x%"UVxf
5879 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5882 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5887 if (--(SvREFCNT(sv)) > 0)
5889 Perl_sv_free2(aTHX_ sv);
5893 Perl_sv_free2(pTHX_ SV *const sv)
5897 PERL_ARGS_ASSERT_SV_FREE2;
5901 if (ckWARN_d(WARN_DEBUGGING))
5902 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5903 "Attempt to free temp prematurely: SV 0x%"UVxf
5904 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5908 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5909 /* make sure SvREFCNT(sv)==0 happens very seldom */
5910 SvREFCNT(sv) = (~(U32)0)/2;
5921 Returns the length of the string in the SV. Handles magic and type
5922 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5928 Perl_sv_len(pTHX_ register SV *const sv)
5936 len = mg_length(sv);
5938 (void)SvPV_const(sv, len);
5943 =for apidoc sv_len_utf8
5945 Returns the number of characters in the string in an SV, counting wide
5946 UTF-8 bytes as a single character. Handles magic and type coercion.
5952 * The length is cached in PERL_MAGIC_utf8, in the mg_len field. Also the
5953 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
5954 * (Note that the mg_len is not the length of the mg_ptr field.
5955 * This allows the cache to store the character length of the string without
5956 * needing to malloc() extra storage to attach to the mg_ptr.)
5961 Perl_sv_len_utf8(pTHX_ register SV *const sv)
5967 return mg_length(sv);
5971 const U8 *s = (U8*)SvPV_const(sv, len);
5975 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
5977 if (mg && mg->mg_len != -1) {
5979 if (PL_utf8cache < 0) {
5980 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
5982 /* Need to turn the assertions off otherwise we may
5983 recurse infinitely while printing error messages.
5985 SAVEI8(PL_utf8cache);
5987 Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
5988 " real %"UVuf" for %"SVf,
5989 (UV) ulen, (UV) real, SVfARG(sv));
5994 ulen = Perl_utf8_length(aTHX_ s, s + len);
5995 if (!SvREADONLY(sv)) {
5997 mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
5998 &PL_vtbl_utf8, 0, 0);
6006 return Perl_utf8_length(aTHX_ s, s + len);
6010 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6013 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6016 const U8 *s = start;
6018 PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6020 while (s < send && uoffset--)
6023 /* This is the existing behaviour. Possibly it should be a croak, as
6024 it's actually a bounds error */
6030 /* Given the length of the string in both bytes and UTF-8 characters, decide
6031 whether to walk forwards or backwards to find the byte corresponding to
6032 the passed in UTF-8 offset. */
6034 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6035 const STRLEN uoffset, const STRLEN uend)
6037 STRLEN backw = uend - uoffset;
6039 PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6041 if (uoffset < 2 * backw) {
6042 /* The assumption is that going forwards is twice the speed of going
6043 forward (that's where the 2 * backw comes from).
6044 (The real figure of course depends on the UTF-8 data.) */
6045 return sv_pos_u2b_forwards(start, send, uoffset);
6050 while (UTF8_IS_CONTINUATION(*send))
6053 return send - start;
6056 /* For the string representation of the given scalar, find the byte
6057 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
6058 give another position in the string, *before* the sought offset, which
6059 (which is always true, as 0, 0 is a valid pair of positions), which should
6060 help reduce the amount of linear searching.
6061 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6062 will be used to reduce the amount of linear searching. The cache will be
6063 created if necessary, and the found value offered to it for update. */
6065 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6066 const U8 *const send, const STRLEN uoffset,
6067 STRLEN uoffset0, STRLEN boffset0)
6069 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
6072 PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6074 assert (uoffset >= uoffset0);
6076 if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
6077 && (*mgp || (*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6078 if ((*mgp)->mg_ptr) {
6079 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6080 if (cache[0] == uoffset) {
6081 /* An exact match. */
6084 if (cache[2] == uoffset) {
6085 /* An exact match. */
6089 if (cache[0] < uoffset) {
6090 /* The cache already knows part of the way. */
6091 if (cache[0] > uoffset0) {
6092 /* The cache knows more than the passed in pair */
6093 uoffset0 = cache[0];
6094 boffset0 = cache[1];
6096 if ((*mgp)->mg_len != -1) {
6097 /* And we know the end too. */
6099 + sv_pos_u2b_midway(start + boffset0, send,
6101 (*mgp)->mg_len - uoffset0);
6104 + sv_pos_u2b_forwards(start + boffset0,
6105 send, uoffset - uoffset0);
6108 else if (cache[2] < uoffset) {
6109 /* We're between the two cache entries. */
6110 if (cache[2] > uoffset0) {
6111 /* and the cache knows more than the passed in pair */
6112 uoffset0 = cache[2];
6113 boffset0 = cache[3];
6117 + sv_pos_u2b_midway(start + boffset0,
6120 cache[0] - uoffset0);
6123 + sv_pos_u2b_midway(start + boffset0,
6126 cache[2] - uoffset0);
6130 else if ((*mgp)->mg_len != -1) {
6131 /* If we can take advantage of a passed in offset, do so. */
6132 /* In fact, offset0 is either 0, or less than offset, so don't
6133 need to worry about the other possibility. */
6135 + sv_pos_u2b_midway(start + boffset0, send,
6137 (*mgp)->mg_len - uoffset0);
6142 if (!found || PL_utf8cache < 0) {
6143 const STRLEN real_boffset
6144 = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6145 send, uoffset - uoffset0);
6147 if (found && PL_utf8cache < 0) {
6148 if (real_boffset != boffset) {
6149 /* Need to turn the assertions off otherwise we may recurse
6150 infinitely while printing error messages. */
6151 SAVEI8(PL_utf8cache);
6153 Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
6154 " real %"UVuf" for %"SVf,
6155 (UV) boffset, (UV) real_boffset, SVfARG(sv));
6158 boffset = real_boffset;
6162 utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6168 =for apidoc sv_pos_u2b
6170 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6171 the start of the string, to a count of the equivalent number of bytes; if
6172 lenp is non-zero, it does the same to lenp, but this time starting from
6173 the offset, rather than from the start of the string. Handles magic and
6180 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6181 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6182 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6187 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6192 PERL_ARGS_ASSERT_SV_POS_U2B;
6197 start = (U8*)SvPV_const(sv, len);
6199 STRLEN uoffset = (STRLEN) *offsetp;
6200 const U8 * const send = start + len;
6202 const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send,
6205 *offsetp = (I32) boffset;
6208 /* Convert the relative offset to absolute. */
6209 const STRLEN uoffset2 = uoffset + (STRLEN) *lenp;
6210 const STRLEN boffset2
6211 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6212 uoffset, boffset) - boffset;
6226 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6227 byte length pairing. The (byte) length of the total SV is passed in too,
6228 as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6229 may not have updated SvCUR, so we can't rely on reading it directly.
6231 The proffered utf8/byte length pairing isn't used if the cache already has
6232 two pairs, and swapping either for the proffered pair would increase the
6233 RMS of the intervals between known byte offsets.
6235 The cache itself consists of 4 STRLEN values
6236 0: larger UTF-8 offset
6237 1: corresponding byte offset
6238 2: smaller UTF-8 offset
6239 3: corresponding byte offset
6241 Unused cache pairs have the value 0, 0.
6242 Keeping the cache "backwards" means that the invariant of
6243 cache[0] >= cache[2] is maintained even with empty slots, which means that
6244 the code that uses it doesn't need to worry if only 1 entry has actually
6245 been set to non-zero. It also makes the "position beyond the end of the
6246 cache" logic much simpler, as the first slot is always the one to start
6250 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6251 const STRLEN utf8, const STRLEN blen)
6255 PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6261 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6263 (*mgp)->mg_len = -1;
6267 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6268 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6269 (*mgp)->mg_ptr = (char *) cache;
6273 if (PL_utf8cache < 0) {
6274 const U8 *start = (const U8 *) SvPVX_const(sv);
6275 const STRLEN realutf8 = utf8_length(start, start + byte);
6277 if (realutf8 != utf8) {
6278 /* Need to turn the assertions off otherwise we may recurse
6279 infinitely while printing error messages. */
6280 SAVEI8(PL_utf8cache);
6282 Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
6283 " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
6287 /* Cache is held with the later position first, to simplify the code
6288 that deals with unbounded ends. */
6290 ASSERT_UTF8_CACHE(cache);
6291 if (cache[1] == 0) {
6292 /* Cache is totally empty */
6295 } else if (cache[3] == 0) {
6296 if (byte > cache[1]) {
6297 /* New one is larger, so goes first. */
6298 cache[2] = cache[0];
6299 cache[3] = cache[1];
6307 #define THREEWAY_SQUARE(a,b,c,d) \
6308 ((float)((d) - (c))) * ((float)((d) - (c))) \
6309 + ((float)((c) - (b))) * ((float)((c) - (b))) \
6310 + ((float)((b) - (a))) * ((float)((b) - (a)))
6312 /* Cache has 2 slots in use, and we know three potential pairs.
6313 Keep the two that give the lowest RMS distance. Do the
6314 calcualation in bytes simply because we always know the byte
6315 length. squareroot has the same ordering as the positive value,
6316 so don't bother with the actual square root. */
6317 const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6318 if (byte > cache[1]) {
6319 /* New position is after the existing pair of pairs. */
6320 const float keep_earlier
6321 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6322 const float keep_later
6323 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6325 if (keep_later < keep_earlier) {
6326 if (keep_later < existing) {
6327 cache[2] = cache[0];
6328 cache[3] = cache[1];
6334 if (keep_earlier < existing) {
6340 else if (byte > cache[3]) {
6341 /* New position is between the existing pair of pairs. */
6342 const float keep_earlier
6343 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6344 const float keep_later
6345 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6347 if (keep_later < keep_earlier) {
6348 if (keep_later < existing) {
6354 if (keep_earlier < existing) {
6361 /* New position is before the existing pair of pairs. */
6362 const float keep_earlier
6363 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6364 const float keep_later
6365 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6367 if (keep_later < keep_earlier) {
6368 if (keep_later < existing) {
6374 if (keep_earlier < existing) {
6375 cache[0] = cache[2];
6376 cache[1] = cache[3];
6383 ASSERT_UTF8_CACHE(cache);
6386 /* We already know all of the way, now we may be able to walk back. The same
6387 assumption is made as in S_sv_pos_u2b_midway(), namely that walking
6388 backward is half the speed of walking forward. */
6390 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
6391 const U8 *end, STRLEN endu)
6393 const STRLEN forw = target - s;
6394 STRLEN backw = end - target;
6396 PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
6398 if (forw < 2 * backw) {
6399 return utf8_length(s, target);
6402 while (end > target) {
6404 while (UTF8_IS_CONTINUATION(*end)) {
6413 =for apidoc sv_pos_b2u
6415 Converts the value pointed to by offsetp from a count of bytes from the
6416 start of the string, to a count of the equivalent number of UTF-8 chars.
6417 Handles magic and type coercion.
6423 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6424 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6429 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
6432 const STRLEN byte = *offsetp;
6433 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
6439 PERL_ARGS_ASSERT_SV_POS_B2U;
6444 s = (const U8*)SvPV_const(sv, blen);
6447 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6451 if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
6452 && (mg = mg_find(sv, PERL_MAGIC_utf8))) {
6454 STRLEN * const cache = (STRLEN *) mg->mg_ptr;
6455 if (cache[1] == byte) {
6456 /* An exact match. */
6457 *offsetp = cache[0];
6460 if (cache[3] == byte) {
6461 /* An exact match. */
6462 *offsetp = cache[2];
6466 if (cache[1] < byte) {
6467 /* We already know part of the way. */
6468 if (mg->mg_len != -1) {
6469 /* Actually, we know the end too. */
6471 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
6472 s + blen, mg->mg_len - cache[0]);
6474 len = cache[0] + utf8_length(s + cache[1], send);
6477 else if (cache[3] < byte) {
6478 /* We're between the two cached pairs, so we do the calculation
6479 offset by the byte/utf-8 positions for the earlier pair,
6480 then add the utf-8 characters from the string start to
6482 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
6483 s + cache[1], cache[0] - cache[2])
6487 else { /* cache[3] > byte */
6488 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
6492 ASSERT_UTF8_CACHE(cache);
6494 } else if (mg->mg_len != -1) {
6495 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
6499 if (!found || PL_utf8cache < 0) {
6500 const STRLEN real_len = utf8_length(s, send);
6502 if (found && PL_utf8cache < 0) {
6503 if (len != real_len) {
6504 /* Need to turn the assertions off otherwise we may recurse
6505 infinitely while printing error messages. */
6506 SAVEI8(PL_utf8cache);
6508 Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
6509 " real %"UVuf" for %"SVf,
6510 (UV) len, (UV) real_len, SVfARG(sv));
6518 utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
6524 Returns a boolean indicating whether the strings in the two SVs are
6525 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6526 coerce its args to strings if necessary.
6532 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6541 SV* svrecode = NULL;
6548 /* if pv1 and pv2 are the same, second SvPV_const call may
6549 * invalidate pv1, so we may need to make a copy */
6550 if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
6551 pv1 = SvPV_const(sv1, cur1);
6552 sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
6554 pv1 = SvPV_const(sv1, cur1);
6562 pv2 = SvPV_const(sv2, cur2);
6564 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6565 /* Differing utf8ness.
6566 * Do not UTF8size the comparands as a side-effect. */
6569 svrecode = newSVpvn(pv2, cur2);
6570 sv_recode_to_utf8(svrecode, PL_encoding);
6571 pv2 = SvPV_const(svrecode, cur2);
6574 svrecode = newSVpvn(pv1, cur1);
6575 sv_recode_to_utf8(svrecode, PL_encoding);
6576 pv1 = SvPV_const(svrecode, cur1);
6578 /* Now both are in UTF-8. */
6580 SvREFCNT_dec(svrecode);
6585 bool is_utf8 = TRUE;
6588 /* sv1 is the UTF-8 one,
6589 * if is equal it must be downgrade-able */
6590 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6596 /* sv2 is the UTF-8 one,
6597 * if is equal it must be downgrade-able */
6598 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6604 /* Downgrade not possible - cannot be eq */
6612 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6614 SvREFCNT_dec(svrecode);
6624 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6625 string in C<sv1> is less than, equal to, or greater than the string in
6626 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6627 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6633 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
6637 const char *pv1, *pv2;
6640 SV *svrecode = NULL;
6647 pv1 = SvPV_const(sv1, cur1);
6654 pv2 = SvPV_const(sv2, cur2);
6656 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6657 /* Differing utf8ness.
6658 * Do not UTF8size the comparands as a side-effect. */
6661 svrecode = newSVpvn(pv2, cur2);
6662 sv_recode_to_utf8(svrecode, PL_encoding);
6663 pv2 = SvPV_const(svrecode, cur2);
6666 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6671 svrecode = newSVpvn(pv1, cur1);
6672 sv_recode_to_utf8(svrecode, PL_encoding);
6673 pv1 = SvPV_const(svrecode, cur1);
6676 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6682 cmp = cur2 ? -1 : 0;
6686 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6689 cmp = retval < 0 ? -1 : 1;
6690 } else if (cur1 == cur2) {
6693 cmp = cur1 < cur2 ? -1 : 1;
6697 SvREFCNT_dec(svrecode);
6705 =for apidoc sv_cmp_locale
6707 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6708 'use bytes' aware, handles get magic, and will coerce its args to strings
6709 if necessary. See also C<sv_cmp>.
6715 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
6718 #ifdef USE_LOCALE_COLLATE
6724 if (PL_collation_standard)
6728 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6730 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6732 if (!pv1 || !len1) {
6743 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6746 return retval < 0 ? -1 : 1;
6749 * When the result of collation is equality, that doesn't mean
6750 * that there are no differences -- some locales exclude some
6751 * characters from consideration. So to avoid false equalities,
6752 * we use the raw string as a tiebreaker.
6758 #endif /* USE_LOCALE_COLLATE */
6760 return sv_cmp(sv1, sv2);
6764 #ifdef USE_LOCALE_COLLATE
6767 =for apidoc sv_collxfrm
6769 Add Collate Transform magic to an SV if it doesn't already have it.
6771 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6772 scalar data of the variable, but transformed to such a format that a normal
6773 memory comparison can be used to compare the data according to the locale
6780 Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
6785 PERL_ARGS_ASSERT_SV_COLLXFRM;
6787 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6788 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6794 Safefree(mg->mg_ptr);
6795 s = SvPV_const(sv, len);
6796 if ((xf = mem_collxfrm(s, len, &xlen))) {
6798 #ifdef PERL_OLD_COPY_ON_WRITE
6800 sv_force_normal_flags(sv, 0);
6802 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
6816 if (mg && mg->mg_ptr) {
6818 return mg->mg_ptr + sizeof(PL_collation_ix);
6826 #endif /* USE_LOCALE_COLLATE */
6831 Get a line from the filehandle and store it into the SV, optionally
6832 appending to the currently-stored string.
6838 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
6843 register STDCHAR rslast;
6844 register STDCHAR *bp;
6849 PERL_ARGS_ASSERT_SV_GETS;
6851 if (SvTHINKFIRST(sv))
6852 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6853 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6855 However, perlbench says it's slower, because the existing swipe code
6856 is faster than copy on write.
6857 Swings and roundabouts. */
6858 SvUPGRADE(sv, SVt_PV);
6863 if (PerlIO_isutf8(fp)) {
6865 sv_utf8_upgrade_nomg(sv);
6866 sv_pos_u2b(sv,&append,0);
6868 } else if (SvUTF8(sv)) {
6869 SV * const tsv = newSV(0);
6870 sv_gets(tsv, fp, 0);
6871 sv_utf8_upgrade_nomg(tsv);
6872 SvCUR_set(sv,append);
6875 goto return_string_or_null;
6880 if (PerlIO_isutf8(fp))
6883 if (IN_PERL_COMPILETIME) {
6884 /* we always read code in line mode */
6888 else if (RsSNARF(PL_rs)) {
6889 /* If it is a regular disk file use size from stat() as estimate
6890 of amount we are going to read -- may result in mallocing
6891 more memory than we really need if the layers below reduce
6892 the size we read (e.g. CRLF or a gzip layer).
6895 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6896 const Off_t offset = PerlIO_tell(fp);
6897 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6898 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6904 else if (RsRECORD(PL_rs)) {
6912 /* Grab the size of the record we're getting */
6913 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
6914 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6917 /* VMS wants read instead of fread, because fread doesn't respect */
6918 /* RMS record boundaries. This is not necessarily a good thing to be */
6919 /* doing, but we've got no other real choice - except avoid stdio
6920 as implementation - perhaps write a :vms layer ?
6922 fd = PerlIO_fileno(fp);
6923 if (fd == -1) { /* in-memory file from PerlIO::Scalar */
6924 bytesread = PerlIO_read(fp, buffer, recsize);
6927 bytesread = PerlLIO_read(fd, buffer, recsize);
6930 bytesread = PerlIO_read(fp, buffer, recsize);
6934 SvCUR_set(sv, bytesread + append);
6935 buffer[bytesread] = '\0';
6936 goto return_string_or_null;
6938 else if (RsPARA(PL_rs)) {
6944 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6945 if (PerlIO_isutf8(fp)) {
6946 rsptr = SvPVutf8(PL_rs, rslen);
6949 if (SvUTF8(PL_rs)) {
6950 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6951 Perl_croak(aTHX_ "Wide character in $/");
6954 rsptr = SvPV_const(PL_rs, rslen);
6958 rslast = rslen ? rsptr[rslen - 1] : '\0';
6960 if (rspara) { /* have to do this both before and after */
6961 do { /* to make sure file boundaries work right */
6964 i = PerlIO_getc(fp);
6968 PerlIO_ungetc(fp,i);
6974 /* See if we know enough about I/O mechanism to cheat it ! */
6976 /* This used to be #ifdef test - it is made run-time test for ease
6977 of abstracting out stdio interface. One call should be cheap
6978 enough here - and may even be a macro allowing compile
6982 if (PerlIO_fast_gets(fp)) {
6985 * We're going to steal some values from the stdio struct
6986 * and put EVERYTHING in the innermost loop into registers.
6988 register STDCHAR *ptr;
6992 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6993 /* An ungetc()d char is handled separately from the regular
6994 * buffer, so we getc() it back out and stuff it in the buffer.
6996 i = PerlIO_getc(fp);
6997 if (i == EOF) return 0;
6998 *(--((*fp)->_ptr)) = (unsigned char) i;
7002 /* Here is some breathtakingly efficient cheating */
7004 cnt = PerlIO_get_cnt(fp); /* get count into register */
7005 /* make sure we have the room */
7006 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7007 /* Not room for all of it
7008 if we are looking for a separator and room for some
7010 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7011 /* just process what we have room for */
7012 shortbuffered = cnt - SvLEN(sv) + append + 1;
7013 cnt -= shortbuffered;
7017 /* remember that cnt can be negative */
7018 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7023 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
7024 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7025 DEBUG_P(PerlIO_printf(Perl_debug_log,
7026 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7027 DEBUG_P(PerlIO_printf(Perl_debug_log,
7028 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7029 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7030 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7035 while (cnt > 0) { /* this | eat */
7037 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7038 goto thats_all_folks; /* screams | sed :-) */
7042 Copy(ptr, bp, cnt, char); /* this | eat */
7043 bp += cnt; /* screams | dust */
7044 ptr += cnt; /* louder | sed :-) */
7049 if (shortbuffered) { /* oh well, must extend */
7050 cnt = shortbuffered;
7052 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7054 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7055 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7059 DEBUG_P(PerlIO_printf(Perl_debug_log,
7060 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7061 PTR2UV(ptr),(long)cnt));
7062 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7064 DEBUG_P(PerlIO_printf(Perl_debug_log,
7065 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7066 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7067 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7069 /* This used to call 'filbuf' in stdio form, but as that behaves like
7070 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7071 another abstraction. */
7072 i = PerlIO_getc(fp); /* get more characters */
7074 DEBUG_P(PerlIO_printf(Perl_debug_log,
7075 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7076 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7077 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7079 cnt = PerlIO_get_cnt(fp);
7080 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7081 DEBUG_P(PerlIO_printf(Perl_debug_log,
7082 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7084 if (i == EOF) /* all done for ever? */
7085 goto thats_really_all_folks;
7087 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7089 SvGROW(sv, bpx + cnt + 2);
7090 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7092 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7094 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7095 goto thats_all_folks;
7099 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7100 memNE((char*)bp - rslen, rsptr, rslen))
7101 goto screamer; /* go back to the fray */
7102 thats_really_all_folks:
7104 cnt += shortbuffered;
7105 DEBUG_P(PerlIO_printf(Perl_debug_log,
7106 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7107 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7108 DEBUG_P(PerlIO_printf(Perl_debug_log,
7109 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7110 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7111 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7113 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
7114 DEBUG_P(PerlIO_printf(Perl_debug_log,
7115 "Screamer: done, len=%ld, string=|%.*s|\n",
7116 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7120 /*The big, slow, and stupid way. */
7121 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
7122 STDCHAR *buf = NULL;
7123 Newx(buf, 8192, STDCHAR);
7131 register const STDCHAR * const bpe = buf + sizeof(buf);
7133 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7134 ; /* keep reading */
7138 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7139 /* Accomodate broken VAXC compiler, which applies U8 cast to
7140 * both args of ?: operator, causing EOF to change into 255
7143 i = (U8)buf[cnt - 1];
7149 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7151 sv_catpvn(sv, (char *) buf, cnt);
7153 sv_setpvn(sv, (char *) buf, cnt);
7155 if (i != EOF && /* joy */
7157 SvCUR(sv) < rslen ||
7158 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7162 * If we're reading from a TTY and we get a short read,
7163 * indicating that the user hit his EOF character, we need
7164 * to notice it now, because if we try to read from the TTY
7165 * again, the EOF condition will disappear.
7167 * The comparison of cnt to sizeof(buf) is an optimization
7168 * that prevents unnecessary calls to feof().
7172 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7176 #ifdef USE_HEAP_INSTEAD_OF_STACK
7181 if (rspara) { /* have to do this both before and after */
7182 while (i != EOF) { /* to make sure file boundaries work right */
7183 i = PerlIO_getc(fp);
7185 PerlIO_ungetc(fp,i);
7191 return_string_or_null:
7192 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7198 Auto-increment of the value in the SV, doing string to numeric conversion
7199 if necessary. Handles 'get' magic.
7205 Perl_sv_inc(pTHX_ register SV *const sv)
7214 if (SvTHINKFIRST(sv)) {
7216 sv_force_normal_flags(sv, 0);
7217 if (SvREADONLY(sv)) {
7218 if (IN_PERL_RUNTIME)
7219 Perl_croak(aTHX_ "%s", PL_no_modify);
7223 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7225 i = PTR2IV(SvRV(sv));
7230 flags = SvFLAGS(sv);
7231 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7232 /* It's (privately or publicly) a float, but not tested as an
7233 integer, so test it to see. */
7235 flags = SvFLAGS(sv);
7237 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7238 /* It's publicly an integer, or privately an integer-not-float */
7239 #ifdef PERL_PRESERVE_IVUV
7243 if (SvUVX(sv) == UV_MAX)
7244 sv_setnv(sv, UV_MAX_P1);
7246 (void)SvIOK_only_UV(sv);
7247 SvUV_set(sv, SvUVX(sv) + 1);
7249 if (SvIVX(sv) == IV_MAX)
7250 sv_setuv(sv, (UV)IV_MAX + 1);
7252 (void)SvIOK_only(sv);
7253 SvIV_set(sv, SvIVX(sv) + 1);
7258 if (flags & SVp_NOK) {
7259 const NV was = SvNVX(sv);
7260 if (NV_OVERFLOWS_INTEGERS_AT &&
7261 was >= NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
7262 Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
7263 "Lost precision when incrementing %" NVff " by 1",
7266 (void)SvNOK_only(sv);
7267 SvNV_set(sv, was + 1.0);
7271 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7272 if ((flags & SVTYPEMASK) < SVt_PVIV)
7273 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
7274 (void)SvIOK_only(sv);
7279 while (isALPHA(*d)) d++;
7280 while (isDIGIT(*d)) d++;
7282 #ifdef PERL_PRESERVE_IVUV
7283 /* Got to punt this as an integer if needs be, but we don't issue
7284 warnings. Probably ought to make the sv_iv_please() that does
7285 the conversion if possible, and silently. */
7286 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7287 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7288 /* Need to try really hard to see if it's an integer.
7289 9.22337203685478e+18 is an integer.
7290 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7291 so $a="9.22337203685478e+18"; $a+0; $a++
7292 needs to be the same as $a="9.22337203685478e+18"; $a++
7299 /* sv_2iv *should* have made this an NV */
7300 if (flags & SVp_NOK) {
7301 (void)SvNOK_only(sv);
7302 SvNV_set(sv, SvNVX(sv) + 1.0);
7305 /* I don't think we can get here. Maybe I should assert this
7306 And if we do get here I suspect that sv_setnv will croak. NWC
7308 #if defined(USE_LONG_DOUBLE)
7309 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",
7310 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7312 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7313 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7316 #endif /* PERL_PRESERVE_IVUV */
7317 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7321 while (d >= SvPVX_const(sv)) {
7329 /* MKS: The original code here died if letters weren't consecutive.
7330 * at least it didn't have to worry about non-C locales. The
7331 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7332 * arranged in order (although not consecutively) and that only
7333 * [A-Za-z] are accepted by isALPHA in the C locale.
7335 if (*d != 'z' && *d != 'Z') {
7336 do { ++*d; } while (!isALPHA(*d));
7339 *(d--) -= 'z' - 'a';
7344 *(d--) -= 'z' - 'a' + 1;
7348 /* oh,oh, the number grew */
7349 SvGROW(sv, SvCUR(sv) + 2);
7350 SvCUR_set(sv, SvCUR(sv) + 1);
7351 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7362 Auto-decrement of the value in the SV, doing string to numeric conversion
7363 if necessary. Handles 'get' magic.
7369 Perl_sv_dec(pTHX_ register SV *const sv)
7377 if (SvTHINKFIRST(sv)) {
7379 sv_force_normal_flags(sv, 0);
7380 if (SvREADONLY(sv)) {
7381 if (IN_PERL_RUNTIME)
7382 Perl_croak(aTHX_ "%s", PL_no_modify);
7386 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7388 i = PTR2IV(SvRV(sv));
7393 /* Unlike sv_inc we don't have to worry about string-never-numbers
7394 and keeping them magic. But we mustn't warn on punting */
7395 flags = SvFLAGS(sv);
7396 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7397 /* It's publicly an integer, or privately an integer-not-float */
7398 #ifdef PERL_PRESERVE_IVUV
7402 if (SvUVX(sv) == 0) {
7403 (void)SvIOK_only(sv);
7407 (void)SvIOK_only_UV(sv);
7408 SvUV_set(sv, SvUVX(sv) - 1);
7411 if (SvIVX(sv) == IV_MIN) {
7412 sv_setnv(sv, (NV)IV_MIN);
7416 (void)SvIOK_only(sv);
7417 SvIV_set(sv, SvIVX(sv) - 1);
7422 if (flags & SVp_NOK) {
7425 const NV was = SvNVX(sv);
7426 if (NV_OVERFLOWS_INTEGERS_AT &&
7427 was <= -NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
7428 Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
7429 "Lost precision when decrementing %" NVff " by 1",
7432 (void)SvNOK_only(sv);
7433 SvNV_set(sv, was - 1.0);
7437 if (!(flags & SVp_POK)) {
7438 if ((flags & SVTYPEMASK) < SVt_PVIV)
7439 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
7441 (void)SvIOK_only(sv);
7444 #ifdef PERL_PRESERVE_IVUV
7446 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7447 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7448 /* Need to try really hard to see if it's an integer.
7449 9.22337203685478e+18 is an integer.
7450 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7451 so $a="9.22337203685478e+18"; $a+0; $a--
7452 needs to be the same as $a="9.22337203685478e+18"; $a--
7459 /* sv_2iv *should* have made this an NV */
7460 if (flags & SVp_NOK) {
7461 (void)SvNOK_only(sv);
7462 SvNV_set(sv, SvNVX(sv) - 1.0);
7465 /* I don't think we can get here. Maybe I should assert this
7466 And if we do get here I suspect that sv_setnv will croak. NWC
7468 #if defined(USE_LONG_DOUBLE)
7469 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",
7470 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7472 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7473 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7477 #endif /* PERL_PRESERVE_IVUV */
7478 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
7482 =for apidoc sv_mortalcopy
7484 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7485 The new SV is marked as mortal. It will be destroyed "soon", either by an
7486 explicit call to FREETMPS, or by an implicit call at places such as
7487 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7492 /* Make a string that will exist for the duration of the expression
7493 * evaluation. Actually, it may have to last longer than that, but
7494 * hopefully we won't free it until it has been assigned to a
7495 * permanent location. */
7498 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
7504 sv_setsv(sv,oldstr);
7506 PL_tmps_stack[++PL_tmps_ix] = sv;
7512 =for apidoc sv_newmortal
7514 Creates a new null SV which is mortal. The reference count of the SV is
7515 set to 1. It will be destroyed "soon", either by an explicit call to
7516 FREETMPS, or by an implicit call at places such as statement boundaries.
7517 See also C<sv_mortalcopy> and C<sv_2mortal>.
7523 Perl_sv_newmortal(pTHX)
7529 SvFLAGS(sv) = SVs_TEMP;
7531 PL_tmps_stack[++PL_tmps_ix] = sv;
7537 =for apidoc newSVpvn_flags
7539 Creates a new SV and copies a string into it. The reference count for the
7540 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7541 string. You are responsible for ensuring that the source string is at least
7542 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7543 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
7544 If C<SVs_TEMP> is set, then C<sv2mortal()> is called on the result before
7545 returning. If C<SVf_UTF8> is set, then it will be set on the new SV.
7546 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
7548 #define newSVpvn_utf8(s, len, u) \
7549 newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
7555 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
7560 /* All the flags we don't support must be zero.
7561 And we're new code so I'm going to assert this from the start. */
7562 assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
7564 sv_setpvn(sv,s,len);
7565 SvFLAGS(sv) |= (flags & SVf_UTF8);
7566 return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv;
7570 =for apidoc sv_2mortal
7572 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7573 by an explicit call to FREETMPS, or by an implicit call at places such as
7574 statement boundaries. SvTEMP() is turned on which means that the SV's
7575 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7576 and C<sv_mortalcopy>.
7582 Perl_sv_2mortal(pTHX_ register SV *const sv)
7587 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7590 PL_tmps_stack[++PL_tmps_ix] = sv;
7598 Creates a new SV and copies a string into it. The reference count for the
7599 SV is set to 1. If C<len> is zero, Perl will compute the length using
7600 strlen(). For efficiency, consider using C<newSVpvn> instead.
7606 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
7612 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
7617 =for apidoc newSVpvn
7619 Creates a new SV and copies a string into it. The reference count for the
7620 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7621 string. You are responsible for ensuring that the source string is at least
7622 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7628 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
7634 sv_setpvn(sv,s,len);
7639 =for apidoc newSVhek
7641 Creates a new SV from the hash key structure. It will generate scalars that
7642 point to the shared string table where possible. Returns a new (undefined)
7643 SV if the hek is NULL.
7649 Perl_newSVhek(pTHX_ const HEK *const hek)
7659 if (HEK_LEN(hek) == HEf_SVKEY) {
7660 return newSVsv(*(SV**)HEK_KEY(hek));
7662 const int flags = HEK_FLAGS(hek);
7663 if (flags & HVhek_WASUTF8) {
7665 Andreas would like keys he put in as utf8 to come back as utf8
7667 STRLEN utf8_len = HEK_LEN(hek);
7668 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7669 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7672 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7674 } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
7675 /* We don't have a pointer to the hv, so we have to replicate the
7676 flag into every HEK. This hv is using custom a hasing
7677 algorithm. Hence we can't return a shared string scalar, as
7678 that would contain the (wrong) hash value, and might get passed
7679 into an hv routine with a regular hash.
7680 Similarly, a hash that isn't using shared hash keys has to have
7681 the flag in every key so that we know not to try to call
7682 share_hek_kek on it. */
7684 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7689 /* This will be overwhelminly the most common case. */
7691 /* Inline most of newSVpvn_share(), because share_hek_hek() is far
7692 more efficient than sharepvn(). */
7696 sv_upgrade(sv, SVt_PV);
7697 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
7698 SvCUR_set(sv, HEK_LEN(hek));
7711 =for apidoc newSVpvn_share
7713 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7714 table. If the string does not already exist in the table, it is created
7715 first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
7716 value is used; otherwise the hash is computed. The string's hash can be later
7717 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
7718 that as the string table is used for shared hash keys these strings will have
7719 SvPVX_const == HeKEY and hash lookup will avoid string compare.
7725 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7729 bool is_utf8 = FALSE;
7730 const char *const orig_src = src;
7733 STRLEN tmplen = -len;
7735 /* See the note in hv.c:hv_fetch() --jhi */
7736 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7740 PERL_HASH(hash, src, len);
7742 /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
7743 changes here, update it there too. */
7744 sv_upgrade(sv, SVt_PV);
7745 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7753 if (src != orig_src)
7759 #if defined(PERL_IMPLICIT_CONTEXT)
7761 /* pTHX_ magic can't cope with varargs, so this is a no-context
7762 * version of the main function, (which may itself be aliased to us).
7763 * Don't access this version directly.
7767 Perl_newSVpvf_nocontext(const char *const pat, ...)
7773 PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
7775 va_start(args, pat);
7776 sv = vnewSVpvf(pat, &args);
7783 =for apidoc newSVpvf
7785 Creates a new SV and initializes it with the string formatted like
7792 Perl_newSVpvf(pTHX_ const char *const pat, ...)
7797 PERL_ARGS_ASSERT_NEWSVPVF;
7799 va_start(args, pat);
7800 sv = vnewSVpvf(pat, &args);
7805 /* backend for newSVpvf() and newSVpvf_nocontext() */
7808 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
7813 PERL_ARGS_ASSERT_VNEWSVPVF;
7816 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7823 Creates a new SV and copies a floating point value into it.
7824 The reference count for the SV is set to 1.
7830 Perl_newSVnv(pTHX_ const NV n)
7843 Creates a new SV and copies an integer into it. The reference count for the
7850 Perl_newSViv(pTHX_ const IV i)
7863 Creates a new SV and copies an unsigned integer into it.
7864 The reference count for the SV is set to 1.
7870 Perl_newSVuv(pTHX_ const UV u)
7881 =for apidoc newSV_type
7883 Creates a new SV, of the type specified. The reference count for the new SV
7890 Perl_newSV_type(pTHX_ const svtype type)
7895 sv_upgrade(sv, type);
7900 =for apidoc newRV_noinc
7902 Creates an RV wrapper for an SV. The reference count for the original
7903 SV is B<not> incremented.
7909 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
7912 register SV *sv = newSV_type(SVt_IV);
7914 PERL_ARGS_ASSERT_NEWRV_NOINC;
7917 SvRV_set(sv, tmpRef);
7922 /* newRV_inc is the official function name to use now.
7923 * newRV_inc is in fact #defined to newRV in sv.h
7927 Perl_newRV(pTHX_ SV *const sv)
7931 PERL_ARGS_ASSERT_NEWRV;
7933 return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
7939 Creates a new SV which is an exact duplicate of the original SV.
7946 Perl_newSVsv(pTHX_ register SV *const old)
7953 if (SvTYPE(old) == SVTYPEMASK) {
7954 if (ckWARN_d(WARN_INTERNAL))
7955 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7959 /* SV_GMAGIC is the default for sv_setv()
7960 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7961 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7962 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7967 =for apidoc sv_reset
7969 Underlying implementation for the C<reset> Perl function.
7970 Note that the perl-level function is vaguely deprecated.
7976 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
7979 char todo[PERL_UCHAR_MAX+1];
7981 PERL_ARGS_ASSERT_SV_RESET;
7986 if (!*s) { /* reset ?? searches */
7987 MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
7989 const U32 count = mg->mg_len / sizeof(PMOP**);
7990 PMOP **pmp = (PMOP**) mg->mg_ptr;
7991 PMOP *const *const end = pmp + count;
7995 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
7997 (*pmp)->op_pmflags &= ~PMf_USED;
8005 /* reset variables */
8007 if (!HvARRAY(stash))
8010 Zero(todo, 256, char);
8013 I32 i = (unsigned char)*s;
8017 max = (unsigned char)*s++;
8018 for ( ; i <= max; i++) {
8021 for (i = 0; i <= (I32) HvMAX(stash); i++) {
8023 for (entry = HvARRAY(stash)[i];
8025 entry = HeNEXT(entry))
8030 if (!todo[(U8)*HeKEY(entry)])
8032 gv = MUTABLE_GV(HeVAL(entry));
8035 if (SvTHINKFIRST(sv)) {
8036 if (!SvREADONLY(sv) && SvROK(sv))
8038 /* XXX Is this continue a bug? Why should THINKFIRST
8039 exempt us from resetting arrays and hashes? */
8043 if (SvTYPE(sv) >= SVt_PV) {
8045 if (SvPVX_const(sv) != NULL)
8053 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8055 Perl_die(aTHX_ "Can't reset %%ENV on this system");
8058 # if defined(USE_ENVIRON_ARRAY)
8061 # endif /* USE_ENVIRON_ARRAY */
8072 Using various gambits, try to get an IO from an SV: the IO slot if its a
8073 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8074 named after the PV if we're a string.
8080 Perl_sv_2io(pTHX_ SV *const sv)
8085 PERL_ARGS_ASSERT_SV_2IO;
8087 switch (SvTYPE(sv)) {
8089 io = MUTABLE_IO(sv);
8092 if (isGV_with_GP(sv)) {
8093 gv = MUTABLE_GV(sv);
8096 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8102 Perl_croak(aTHX_ PL_no_usym, "filehandle");
8104 return sv_2io(SvRV(sv));
8105 gv = gv_fetchsv(sv, 0, SVt_PVIO);
8111 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
8120 Using various gambits, try to get a CV from an SV; in addition, try if
8121 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8122 The flags in C<lref> are passed to sv_fetchsv.
8128 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8134 PERL_ARGS_ASSERT_SV_2CV;
8141 switch (SvTYPE(sv)) {
8145 return MUTABLE_CV(sv);
8152 if (isGV_with_GP(sv)) {
8153 gv = MUTABLE_GV(sv);
8162 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
8164 tryAMAGICunDEREF(to_cv);
8167 if (SvTYPE(sv) == SVt_PVCV) {
8168 cv = MUTABLE_CV(sv);
8173 else if(isGV_with_GP(sv))
8174 gv = MUTABLE_GV(sv);
8176 Perl_croak(aTHX_ "Not a subroutine reference");
8178 else if (isGV_with_GP(sv)) {
8180 gv = MUTABLE_GV(sv);
8183 gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
8189 /* Some flags to gv_fetchsv mean don't really create the GV */
8190 if (!isGV_with_GP(gv)) {
8196 if (lref && !GvCVu(gv)) {
8200 gv_efullname3(tmpsv, gv, NULL);
8201 /* XXX this is probably not what they think they're getting.
8202 * It has the same effect as "sub name;", i.e. just a forward
8204 newSUB(start_subparse(FALSE, 0),
8205 newSVOP(OP_CONST, 0, tmpsv),
8209 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8210 SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8219 Returns true if the SV has a true value by Perl's rules.
8220 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8221 instead use an in-line version.
8227 Perl_sv_true(pTHX_ register SV *const sv)
8232 register const XPV* const tXpv = (XPV*)SvANY(sv);
8234 (tXpv->xpv_cur > 1 ||
8235 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
8242 return SvIVX(sv) != 0;
8245 return SvNVX(sv) != 0.0;
8247 return sv_2bool(sv);
8253 =for apidoc sv_pvn_force
8255 Get a sensible string out of the SV somehow.
8256 A private implementation of the C<SvPV_force> macro for compilers which
8257 can't cope with complex macro expressions. Always use the macro instead.
8259 =for apidoc sv_pvn_force_flags
8261 Get a sensible string out of the SV somehow.
8262 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8263 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8264 implemented in terms of this function.
8265 You normally want to use the various wrapper macros instead: see
8266 C<SvPV_force> and C<SvPV_force_nomg>
8272 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
8276 PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
8278 if (SvTHINKFIRST(sv) && !SvROK(sv))
8279 sv_force_normal_flags(sv, 0);
8289 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8290 const char * const ref = sv_reftype(sv,0);
8292 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8293 ref, OP_NAME(PL_op));
8295 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
8297 if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
8298 || isGV_with_GP(sv))
8299 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8301 s = sv_2pv_flags(sv, &len, flags);
8305 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
8308 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8309 SvGROW(sv, len + 1);
8310 Move(s,SvPVX(sv),len,char);
8312 SvPVX(sv)[len] = '\0';
8315 SvPOK_on(sv); /* validate pointer */
8317 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8318 PTR2UV(sv),SvPVX_const(sv)));
8321 return SvPVX_mutable(sv);
8325 =for apidoc sv_pvbyten_force
8327 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
8333 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
8335 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
8337 sv_pvn_force(sv,lp);
8338 sv_utf8_downgrade(sv,0);
8344 =for apidoc sv_pvutf8n_force
8346 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
8352 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
8354 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
8356 sv_pvn_force(sv,lp);
8357 sv_utf8_upgrade(sv);
8363 =for apidoc sv_reftype
8365 Returns a string describing what the SV is a reference to.
8371 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
8373 PERL_ARGS_ASSERT_SV_REFTYPE;
8375 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8376 inside return suggests a const propagation bug in g++. */
8377 if (ob && SvOBJECT(sv)) {
8378 char * const name = HvNAME_get(SvSTASH(sv));
8379 return name ? name : (char *) "__ANON__";
8382 switch (SvTYPE(sv)) {
8397 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
8398 /* tied lvalues should appear to be
8399 * scalars for backwards compatitbility */
8400 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8401 ? "SCALAR" : "LVALUE");
8402 case SVt_PVAV: return "ARRAY";
8403 case SVt_PVHV: return "HASH";
8404 case SVt_PVCV: return "CODE";
8405 case SVt_PVGV: return (char *) (isGV_with_GP(sv)
8406 ? "GLOB" : "SCALAR");
8407 case SVt_PVFM: return "FORMAT";
8408 case SVt_PVIO: return "IO";
8409 case SVt_BIND: return "BIND";
8410 case SVt_REGEXP: return "REGEXP";
8411 default: return "UNKNOWN";
8417 =for apidoc sv_isobject
8419 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8420 object. If the SV is not an RV, or if the object is not blessed, then this
8427 Perl_sv_isobject(pTHX_ SV *sv)
8443 Returns a boolean indicating whether the SV is blessed into the specified
8444 class. This does not check for subtypes; use C<sv_derived_from> to verify
8445 an inheritance relationship.
8451 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
8455 PERL_ARGS_ASSERT_SV_ISA;
8465 hvname = HvNAME_get(SvSTASH(sv));
8469 return strEQ(hvname, name);
8475 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8476 it will be upgraded to one. If C<classname> is non-null then the new SV will
8477 be blessed in the specified package. The new SV is returned and its
8478 reference count is 1.
8484 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
8489 PERL_ARGS_ASSERT_NEWSVRV;
8493 SV_CHECK_THINKFIRST_COW_DROP(rv);
8494 (void)SvAMAGIC_off(rv);
8496 if (SvTYPE(rv) >= SVt_PVMG) {
8497 const U32 refcnt = SvREFCNT(rv);
8501 SvREFCNT(rv) = refcnt;
8503 sv_upgrade(rv, SVt_IV);
8504 } else if (SvROK(rv)) {
8505 SvREFCNT_dec(SvRV(rv));
8507 prepare_SV_for_RV(rv);
8515 HV* const stash = gv_stashpv(classname, GV_ADD);
8516 (void)sv_bless(rv, stash);
8522 =for apidoc sv_setref_pv
8524 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8525 argument will be upgraded to an RV. That RV will be modified to point to
8526 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8527 into the SV. The C<classname> argument indicates the package for the
8528 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8529 will have a reference count of 1, and the RV will be returned.
8531 Do not use with other Perl types such as HV, AV, SV, CV, because those
8532 objects will become corrupted by the pointer copy process.
8534 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8540 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
8544 PERL_ARGS_ASSERT_SV_SETREF_PV;
8547 sv_setsv(rv, &PL_sv_undef);
8551 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8556 =for apidoc sv_setref_iv
8558 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8559 argument will be upgraded to an RV. That RV will be modified to point to
8560 the new SV. The C<classname> argument indicates the package for the
8561 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8562 will have a reference count of 1, and the RV will be returned.
8568 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
8570 PERL_ARGS_ASSERT_SV_SETREF_IV;
8572 sv_setiv(newSVrv(rv,classname), iv);
8577 =for apidoc sv_setref_uv
8579 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8580 argument will be upgraded to an RV. That RV will be modified to point to
8581 the new SV. The C<classname> argument indicates the package for the
8582 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8583 will have a reference count of 1, and the RV will be returned.
8589 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
8591 PERL_ARGS_ASSERT_SV_SETREF_UV;
8593 sv_setuv(newSVrv(rv,classname), uv);
8598 =for apidoc sv_setref_nv
8600 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8601 argument will be upgraded to an RV. That RV will be modified to point to
8602 the new SV. The C<classname> argument indicates the package for the
8603 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8604 will have a reference count of 1, and the RV will be returned.
8610 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
8612 PERL_ARGS_ASSERT_SV_SETREF_NV;
8614 sv_setnv(newSVrv(rv,classname), nv);
8619 =for apidoc sv_setref_pvn
8621 Copies a string into a new SV, optionally blessing the SV. The length of the
8622 string must be specified with C<n>. The C<rv> argument will be upgraded to
8623 an RV. That RV will be modified to point to the new SV. The C<classname>
8624 argument indicates the package for the blessing. Set C<classname> to
8625 C<NULL> to avoid the blessing. The new SV will have a reference count
8626 of 1, and the RV will be returned.
8628 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8634 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
8635 const char *const pv, const STRLEN n)
8637 PERL_ARGS_ASSERT_SV_SETREF_PVN;
8639 sv_setpvn(newSVrv(rv,classname), pv, n);
8644 =for apidoc sv_bless
8646 Blesses an SV into a specified package. The SV must be an RV. The package
8647 must be designated by its stash (see C<gv_stashpv()>). The reference count
8648 of the SV is unaffected.
8654 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
8659 PERL_ARGS_ASSERT_SV_BLESS;
8662 Perl_croak(aTHX_ "Can't bless non-reference value");
8664 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8665 if (SvIsCOW(tmpRef))
8666 sv_force_normal_flags(tmpRef, 0);
8667 if (SvREADONLY(tmpRef))
8668 Perl_croak(aTHX_ "%s", PL_no_modify);
8669 if (SvOBJECT(tmpRef)) {
8670 if (SvTYPE(tmpRef) != SVt_PVIO)
8672 SvREFCNT_dec(SvSTASH(tmpRef));
8675 SvOBJECT_on(tmpRef);
8676 if (SvTYPE(tmpRef) != SVt_PVIO)
8678 SvUPGRADE(tmpRef, SVt_PVMG);
8679 SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
8684 (void)SvAMAGIC_off(sv);
8686 if(SvSMAGICAL(tmpRef))
8687 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8695 /* Downgrades a PVGV to a PVMG.
8699 S_sv_unglob(pTHX_ SV *const sv)
8704 SV * const temp = sv_newmortal();
8706 PERL_ARGS_ASSERT_SV_UNGLOB;
8708 assert(SvTYPE(sv) == SVt_PVGV);
8710 gv_efullname3(temp, MUTABLE_GV(sv), "*");
8713 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
8714 && HvNAME_get(stash))
8715 mro_method_changed_in(stash);
8716 gp_free(MUTABLE_GV(sv));
8719 sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
8723 if (GvNAME_HEK(sv)) {
8724 unshare_hek(GvNAME_HEK(sv));
8726 isGV_with_GP_off(sv);
8728 /* need to keep SvANY(sv) in the right arena */
8729 xpvmg = new_XPVMG();
8730 StructCopy(SvANY(sv), xpvmg, XPVMG);
8731 del_XPVGV(SvANY(sv));
8734 SvFLAGS(sv) &= ~SVTYPEMASK;
8735 SvFLAGS(sv) |= SVt_PVMG;
8737 /* Intentionally not calling any local SET magic, as this isn't so much a
8738 set operation as merely an internal storage change. */
8739 sv_setsv_flags(sv, temp, 0);
8743 =for apidoc sv_unref_flags
8745 Unsets the RV status of the SV, and decrements the reference count of
8746 whatever was being referenced by the RV. This can almost be thought of
8747 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8748 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8749 (otherwise the decrementing is conditional on the reference count being
8750 different from one or the reference being a readonly SV).
8757 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
8759 SV* const target = SvRV(ref);
8761 PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
8763 if (SvWEAKREF(ref)) {
8764 sv_del_backref(target, ref);
8766 SvRV_set(ref, NULL);
8769 SvRV_set(ref, NULL);
8771 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8772 assigned to as BEGIN {$a = \"Foo"} will fail. */
8773 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8774 SvREFCNT_dec(target);
8775 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8776 sv_2mortal(target); /* Schedule for freeing later */
8780 =for apidoc sv_untaint
8782 Untaint an SV. Use C<SvTAINTED_off> instead.
8787 Perl_sv_untaint(pTHX_ SV *const sv)
8789 PERL_ARGS_ASSERT_SV_UNTAINT;
8791 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8792 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8799 =for apidoc sv_tainted
8801 Test an SV for taintedness. Use C<SvTAINTED> instead.
8806 Perl_sv_tainted(pTHX_ SV *const sv)
8808 PERL_ARGS_ASSERT_SV_TAINTED;
8810 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8811 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8812 if (mg && (mg->mg_len & 1) )
8819 =for apidoc sv_setpviv
8821 Copies an integer into the given SV, also updating its string value.
8822 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8828 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
8830 char buf[TYPE_CHARS(UV)];
8832 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8834 PERL_ARGS_ASSERT_SV_SETPVIV;
8836 sv_setpvn(sv, ptr, ebuf - ptr);
8840 =for apidoc sv_setpviv_mg
8842 Like C<sv_setpviv>, but also handles 'set' magic.
8848 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
8850 PERL_ARGS_ASSERT_SV_SETPVIV_MG;
8856 #if defined(PERL_IMPLICIT_CONTEXT)
8858 /* pTHX_ magic can't cope with varargs, so this is a no-context
8859 * version of the main function, (which may itself be aliased to us).
8860 * Don't access this version directly.
8864 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
8869 PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
8871 va_start(args, pat);
8872 sv_vsetpvf(sv, pat, &args);
8876 /* pTHX_ magic can't cope with varargs, so this is a no-context
8877 * version of the main function, (which may itself be aliased to us).
8878 * Don't access this version directly.
8882 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
8887 PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
8889 va_start(args, pat);
8890 sv_vsetpvf_mg(sv, pat, &args);
8896 =for apidoc sv_setpvf
8898 Works like C<sv_catpvf> but copies the text into the SV instead of
8899 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8905 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
8909 PERL_ARGS_ASSERT_SV_SETPVF;
8911 va_start(args, pat);
8912 sv_vsetpvf(sv, pat, &args);
8917 =for apidoc sv_vsetpvf
8919 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8920 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8922 Usually used via its frontend C<sv_setpvf>.
8928 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8930 PERL_ARGS_ASSERT_SV_VSETPVF;
8932 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8936 =for apidoc sv_setpvf_mg
8938 Like C<sv_setpvf>, but also handles 'set' magic.
8944 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
8948 PERL_ARGS_ASSERT_SV_SETPVF_MG;
8950 va_start(args, pat);
8951 sv_vsetpvf_mg(sv, pat, &args);
8956 =for apidoc sv_vsetpvf_mg
8958 Like C<sv_vsetpvf>, but also handles 'set' magic.
8960 Usually used via its frontend C<sv_setpvf_mg>.
8966 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8968 PERL_ARGS_ASSERT_SV_VSETPVF_MG;
8970 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8974 #if defined(PERL_IMPLICIT_CONTEXT)
8976 /* pTHX_ magic can't cope with varargs, so this is a no-context
8977 * version of the main function, (which may itself be aliased to us).
8978 * Don't access this version directly.
8982 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
8987 PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
8989 va_start(args, pat);
8990 sv_vcatpvf(sv, pat, &args);
8994 /* pTHX_ magic can't cope with varargs, so this is a no-context
8995 * version of the main function, (which may itself be aliased to us).
8996 * Don't access this version directly.
9000 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9005 PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9007 va_start(args, pat);
9008 sv_vcatpvf_mg(sv, pat, &args);
9014 =for apidoc sv_catpvf
9016 Processes its arguments like C<sprintf> and appends the formatted
9017 output to an SV. If the appended data contains "wide" characters
9018 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9019 and characters >255 formatted with %c), the original SV might get
9020 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
9021 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9022 valid UTF-8; if the original SV was bytes, the pattern should be too.
9027 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9031 PERL_ARGS_ASSERT_SV_CATPVF;
9033 va_start(args, pat);
9034 sv_vcatpvf(sv, pat, &args);
9039 =for apidoc sv_vcatpvf
9041 Processes its arguments like C<vsprintf> and appends the formatted output
9042 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
9044 Usually used via its frontend C<sv_catpvf>.
9050 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9052 PERL_ARGS_ASSERT_SV_VCATPVF;
9054 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9058 =for apidoc sv_catpvf_mg
9060 Like C<sv_catpvf>, but also handles 'set' magic.
9066 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9070 PERL_ARGS_ASSERT_SV_CATPVF_MG;
9072 va_start(args, pat);
9073 sv_vcatpvf_mg(sv, pat, &args);
9078 =for apidoc sv_vcatpvf_mg
9080 Like C<sv_vcatpvf>, but also handles 'set' magic.
9082 Usually used via its frontend C<sv_catpvf_mg>.
9088 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9090 PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9092 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9097 =for apidoc sv_vsetpvfn
9099 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9102 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9108 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9109 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9111 PERL_ARGS_ASSERT_SV_VSETPVFN;
9114 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9118 S_expect_number(pTHX_ char **const pattern)
9123 PERL_ARGS_ASSERT_EXPECT_NUMBER;
9125 switch (**pattern) {
9126 case '1': case '2': case '3':
9127 case '4': case '5': case '6':
9128 case '7': case '8': case '9':
9129 var = *(*pattern)++ - '0';
9130 while (isDIGIT(**pattern)) {
9131 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
9133 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn"));
9141 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
9143 const int neg = nv < 0;
9146 PERL_ARGS_ASSERT_F0CONVERT;
9154 if (uv & 1 && uv == nv)
9155 uv--; /* Round to even */
9157 const unsigned dig = uv % 10;
9170 =for apidoc sv_vcatpvfn
9172 Processes its arguments like C<vsprintf> and appends the formatted output
9173 to an SV. Uses an array of SVs if the C style variable argument list is
9174 missing (NULL). When running with taint checks enabled, indicates via
9175 C<maybe_tainted> if results are untrustworthy (often due to the use of
9178 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9184 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
9185 vecstr = (U8*)SvPV_const(vecsv,veclen);\
9186 vec_utf8 = DO_UTF8(vecsv);
9188 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9191 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9192 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9200 static const char nullstr[] = "(null)";
9202 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
9203 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9205 /* Times 4: a decimal digit takes more than 3 binary digits.
9206 * NV_DIG: mantissa takes than many decimal digits.
9207 * Plus 32: Playing safe. */
9208 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9209 /* large enough for "%#.#f" --chip */
9210 /* what about long double NVs? --jhi */
9212 PERL_ARGS_ASSERT_SV_VCATPVFN;
9213 PERL_UNUSED_ARG(maybe_tainted);
9215 /* no matter what, this is a string now */
9216 (void)SvPV_force(sv, origlen);
9218 /* special-case "", "%s", and "%-p" (SVf - see below) */
9221 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9223 const char * const s = va_arg(*args, char*);
9224 sv_catpv(sv, s ? s : nullstr);
9226 else if (svix < svmax) {
9227 sv_catsv(sv, *svargs);
9231 if (args && patlen == 3 && pat[0] == '%' &&
9232 pat[1] == '-' && pat[2] == 'p') {
9233 argsv = MUTABLE_SV(va_arg(*args, void*));
9234 sv_catsv(sv, argsv);
9238 #ifndef USE_LONG_DOUBLE
9239 /* special-case "%.<number>[gf]" */
9240 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9241 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9242 unsigned digits = 0;
9246 while (*pp >= '0' && *pp <= '9')
9247 digits = 10 * digits + (*pp++ - '0');
9248 if (pp - pat == (int)patlen - 1) {
9256 /* Add check for digits != 0 because it seems that some
9257 gconverts are buggy in this case, and we don't yet have
9258 a Configure test for this. */
9259 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9260 /* 0, point, slack */
9261 Gconvert(nv, (int)digits, 0, ebuf);
9263 if (*ebuf) /* May return an empty string for digits==0 */
9266 } else if (!digits) {
9269 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9270 sv_catpvn(sv, p, l);
9276 #endif /* !USE_LONG_DOUBLE */
9278 if (!args && svix < svmax && DO_UTF8(*svargs))
9281 patend = (char*)pat + patlen;
9282 for (p = (char*)pat; p < patend; p = q) {
9285 bool vectorize = FALSE;
9286 bool vectorarg = FALSE;
9287 bool vec_utf8 = FALSE;
9293 bool has_precis = FALSE;
9295 const I32 osvix = svix;
9296 bool is_utf8 = FALSE; /* is this item utf8? */
9297 #ifdef HAS_LDBL_SPRINTF_BUG
9298 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9299 with sfio - Allen <allens@cpan.org> */
9300 bool fix_ldbl_sprintf_bug = FALSE;
9304 U8 utf8buf[UTF8_MAXBYTES+1];
9305 STRLEN esignlen = 0;
9307 const char *eptr = NULL;
9308 const char *fmtstart;
9311 const U8 *vecstr = NULL;
9318 /* we need a long double target in case HAS_LONG_DOUBLE but
9321 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9329 const char *dotstr = ".";
9330 STRLEN dotstrlen = 1;
9331 I32 efix = 0; /* explicit format parameter index */
9332 I32 ewix = 0; /* explicit width index */
9333 I32 epix = 0; /* explicit precision index */
9334 I32 evix = 0; /* explicit vector index */
9335 bool asterisk = FALSE;
9337 /* echo everything up to the next format specification */
9338 for (q = p; q < patend && *q != '%'; ++q) ;
9340 if (has_utf8 && !pat_utf8)
9341 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9343 sv_catpvn(sv, p, q - p);
9352 We allow format specification elements in this order:
9353 \d+\$ explicit format parameter index
9355 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9356 0 flag (as above): repeated to allow "v02"
9357 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9358 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9360 [%bcdefginopsuxDFOUX] format (mandatory)
9365 As of perl5.9.3, printf format checking is on by default.
9366 Internally, perl uses %p formats to provide an escape to
9367 some extended formatting. This block deals with those
9368 extensions: if it does not match, (char*)q is reset and
9369 the normal format processing code is used.
9371 Currently defined extensions are:
9372 %p include pointer address (standard)
9373 %-p (SVf) include an SV (previously %_)
9374 %-<num>p include an SV with precision <num>
9375 %<num>p reserved for future extensions
9377 Robin Barker 2005-07-14
9379 %1p (VDf) removed. RMB 2007-10-19
9386 n = expect_number(&q);
9393 argsv = MUTABLE_SV(va_arg(*args, void*));
9394 eptr = SvPV_const(argsv, elen);
9400 if (ckWARN_d(WARN_INTERNAL))
9401 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9402 "internal %%<num>p might conflict with future printf extensions");
9408 if ( (width = expect_number(&q)) ) {
9423 if (plus == '+' && *q == ' ') /* '+' over ' ' */
9452 if ( (ewix = expect_number(&q)) )
9461 if ((vectorarg = asterisk)) {
9474 width = expect_number(&q);
9480 vecsv = va_arg(*args, SV*);
9482 vecsv = (evix > 0 && evix <= svmax)
9483 ? svargs[evix-1] : &PL_sv_undef;
9485 vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
9487 dotstr = SvPV_const(vecsv, dotstrlen);
9488 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
9489 bad with tied or overloaded values that return UTF8. */
9492 else if (has_utf8) {
9493 vecsv = sv_mortalcopy(vecsv);
9494 sv_utf8_upgrade(vecsv);
9495 dotstr = SvPV_const(vecsv, dotstrlen);
9502 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
9503 vecsv = svargs[efix ? efix-1 : svix++];
9504 vecstr = (U8*)SvPV_const(vecsv,veclen);
9505 vec_utf8 = DO_UTF8(vecsv);
9507 /* if this is a version object, we need to convert
9508 * back into v-string notation and then let the
9509 * vectorize happen normally
9511 if (sv_derived_from(vecsv, "version")) {
9512 char *version = savesvpv(vecsv);
9513 if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
9514 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9515 "vector argument not supported with alpha versions");
9518 vecsv = sv_newmortal();
9519 scan_vstring(version, version + veclen, vecsv);
9520 vecstr = (U8*)SvPV_const(vecsv, veclen);
9521 vec_utf8 = DO_UTF8(vecsv);
9533 i = va_arg(*args, int);
9535 i = (ewix ? ewix <= svmax : svix < svmax) ?
9536 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9538 width = (i < 0) ? -i : i;
9548 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
9550 /* XXX: todo, support specified precision parameter */
9554 i = va_arg(*args, int);
9556 i = (ewix ? ewix <= svmax : svix < svmax)
9557 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9559 has_precis = !(i < 0);
9564 precis = precis * 10 + (*q++ - '0');
9573 case 'I': /* Ix, I32x, and I64x */
9575 if (q[1] == '6' && q[2] == '4') {
9581 if (q[1] == '3' && q[2] == '2') {
9591 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9602 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9603 if (*(q + 1) == 'l') { /* lld, llf */
9629 if (!vectorize && !args) {
9631 const I32 i = efix-1;
9632 argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
9634 argsv = (svix >= 0 && svix < svmax)
9635 ? svargs[svix++] : &PL_sv_undef;
9646 uv = (args) ? va_arg(*args, int) : SvIV(argsv);
9648 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9650 eptr = (char*)utf8buf;
9651 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9665 eptr = va_arg(*args, char*);
9667 elen = strlen(eptr);
9669 eptr = (char *)nullstr;
9670 elen = sizeof nullstr - 1;
9674 eptr = SvPV_const(argsv, elen);
9675 if (DO_UTF8(argsv)) {
9676 I32 old_precis = precis;
9677 if (has_precis && precis < elen) {
9679 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9682 if (width) { /* fudge width (can't fudge elen) */
9683 if (has_precis && precis < elen)
9684 width += precis - old_precis;
9686 width += elen - sv_len_utf8(argsv);
9693 if (has_precis && elen > precis)
9700 if (alt || vectorize)
9702 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9723 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9732 esignbuf[esignlen++] = plus;
9736 case 'h': iv = (short)va_arg(*args, int); break;
9737 case 'l': iv = va_arg(*args, long); break;
9738 case 'V': iv = va_arg(*args, IV); break;
9739 default: iv = va_arg(*args, int); break;
9742 iv = va_arg(*args, Quad_t); break;
9749 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
9751 case 'h': iv = (short)tiv; break;
9752 case 'l': iv = (long)tiv; break;
9754 default: iv = tiv; break;
9757 iv = (Quad_t)tiv; break;
9763 if ( !vectorize ) /* we already set uv above */
9768 esignbuf[esignlen++] = plus;
9772 esignbuf[esignlen++] = '-';
9816 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9827 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9828 case 'l': uv = va_arg(*args, unsigned long); break;
9829 case 'V': uv = va_arg(*args, UV); break;
9830 default: uv = va_arg(*args, unsigned); break;
9833 uv = va_arg(*args, Uquad_t); break;
9840 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
9842 case 'h': uv = (unsigned short)tuv; break;
9843 case 'l': uv = (unsigned long)tuv; break;
9845 default: uv = tuv; break;
9848 uv = (Uquad_t)tuv; break;
9857 char *ptr = ebuf + sizeof ebuf;
9858 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
9864 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
9870 esignbuf[esignlen++] = '0';
9871 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9879 if (alt && *ptr != '0')
9888 esignbuf[esignlen++] = '0';
9889 esignbuf[esignlen++] = c;
9892 default: /* it had better be ten or less */
9896 } while (uv /= base);
9899 elen = (ebuf + sizeof ebuf) - ptr;
9903 zeros = precis - elen;
9904 else if (precis == 0 && elen == 1 && *eptr == '0'
9905 && !(base == 8 && alt)) /* "%#.0o" prints "0" */
9908 /* a precision nullifies the 0 flag. */
9915 /* FLOATING POINT */
9918 c = 'f'; /* maybe %F isn't supported here */
9926 /* This is evil, but floating point is even more evil */
9928 /* for SV-style calling, we can only get NV
9929 for C-style calling, we assume %f is double;
9930 for simplicity we allow any of %Lf, %llf, %qf for long double
9934 #if defined(USE_LONG_DOUBLE)
9938 /* [perl #20339] - we should accept and ignore %lf rather than die */
9942 #if defined(USE_LONG_DOUBLE)
9943 intsize = args ? 0 : 'q';
9947 #if defined(HAS_LONG_DOUBLE)
9956 /* now we need (long double) if intsize == 'q', else (double) */
9958 #if LONG_DOUBLESIZE > DOUBLESIZE
9960 va_arg(*args, long double) :
9961 va_arg(*args, double)
9963 va_arg(*args, double)
9968 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
9969 else. frexp() has some unspecified behaviour for those three */
9970 if (c != 'e' && c != 'E' && (nv * 0) == 0) {
9972 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9973 will cast our (long double) to (double) */
9974 (void)Perl_frexp(nv, &i);
9975 if (i == PERL_INT_MIN)
9976 Perl_die(aTHX_ "panic: frexp");
9978 need = BIT_DIGITS(i);
9980 need += has_precis ? precis : 6; /* known default */
9985 #ifdef HAS_LDBL_SPRINTF_BUG
9986 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9987 with sfio - Allen <allens@cpan.org> */
9990 # define MY_DBL_MAX DBL_MAX
9991 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9992 # if DOUBLESIZE >= 8
9993 # define MY_DBL_MAX 1.7976931348623157E+308L
9995 # define MY_DBL_MAX 3.40282347E+38L
9999 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10000 # define MY_DBL_MAX_BUG 1L
10002 # define MY_DBL_MAX_BUG MY_DBL_MAX
10006 # define MY_DBL_MIN DBL_MIN
10007 # else /* XXX guessing! -Allen */
10008 # if DOUBLESIZE >= 8
10009 # define MY_DBL_MIN 2.2250738585072014E-308L
10011 # define MY_DBL_MIN 1.17549435E-38L
10015 if ((intsize == 'q') && (c == 'f') &&
10016 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10017 (need < DBL_DIG)) {
10018 /* it's going to be short enough that
10019 * long double precision is not needed */
10021 if ((nv <= 0L) && (nv >= -0L))
10022 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10024 /* would use Perl_fp_class as a double-check but not
10025 * functional on IRIX - see perl.h comments */
10027 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10028 /* It's within the range that a double can represent */
10029 #if defined(DBL_MAX) && !defined(DBL_MIN)
10030 if ((nv >= ((long double)1/DBL_MAX)) ||
10031 (nv <= (-(long double)1/DBL_MAX)))
10033 fix_ldbl_sprintf_bug = TRUE;
10036 if (fix_ldbl_sprintf_bug == TRUE) {
10046 # undef MY_DBL_MAX_BUG
10049 #endif /* HAS_LDBL_SPRINTF_BUG */
10051 need += 20; /* fudge factor */
10052 if (PL_efloatsize < need) {
10053 Safefree(PL_efloatbuf);
10054 PL_efloatsize = need + 20; /* more fudge */
10055 Newx(PL_efloatbuf, PL_efloatsize, char);
10056 PL_efloatbuf[0] = '\0';
10059 if ( !(width || left || plus || alt) && fill != '0'
10060 && has_precis && intsize != 'q' ) { /* Shortcuts */
10061 /* See earlier comment about buggy Gconvert when digits,
10063 if ( c == 'g' && precis) {
10064 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10065 /* May return an empty string for digits==0 */
10066 if (*PL_efloatbuf) {
10067 elen = strlen(PL_efloatbuf);
10068 goto float_converted;
10070 } else if ( c == 'f' && !precis) {
10071 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10076 char *ptr = ebuf + sizeof ebuf;
10079 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10080 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10081 if (intsize == 'q') {
10082 /* Copy the one or more characters in a long double
10083 * format before the 'base' ([efgEFG]) character to
10084 * the format string. */
10085 static char const prifldbl[] = PERL_PRIfldbl;
10086 char const *p = prifldbl + sizeof(prifldbl) - 3;
10087 while (p >= prifldbl) { *--ptr = *p--; }
10092 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10097 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10109 /* No taint. Otherwise we are in the strange situation
10110 * where printf() taints but print($float) doesn't.
10112 #if defined(HAS_LONG_DOUBLE)
10113 elen = ((intsize == 'q')
10114 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
10115 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
10117 elen = my_sprintf(PL_efloatbuf, ptr, nv);
10121 eptr = PL_efloatbuf;
10129 i = SvCUR(sv) - origlen;
10132 case 'h': *(va_arg(*args, short*)) = i; break;
10133 default: *(va_arg(*args, int*)) = i; break;
10134 case 'l': *(va_arg(*args, long*)) = i; break;
10135 case 'V': *(va_arg(*args, IV*)) = i; break;
10138 *(va_arg(*args, Quad_t*)) = i; break;
10145 sv_setuv_mg(argsv, (UV)i);
10146 continue; /* not "break" */
10153 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
10154 && ckWARN(WARN_PRINTF))
10156 SV * const msg = sv_newmortal();
10157 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10158 (PL_op->op_type == OP_PRTF) ? "" : "s");
10159 if (fmtstart < patend) {
10160 const char * const fmtend = q < patend ? q : patend;
10162 sv_catpvs(msg, "\"%");
10163 for (f = fmtstart; f < fmtend; f++) {
10165 sv_catpvn(msg, f, 1);
10167 Perl_sv_catpvf(aTHX_ msg,
10168 "\\%03"UVof, (UV)*f & 0xFF);
10171 sv_catpvs(msg, "\"");
10173 sv_catpvs(msg, "end of string");
10175 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
10178 /* output mangled stuff ... */
10184 /* ... right here, because formatting flags should not apply */
10185 SvGROW(sv, SvCUR(sv) + elen + 1);
10187 Copy(eptr, p, elen, char);
10190 SvCUR_set(sv, p - SvPVX_const(sv));
10192 continue; /* not "break" */
10195 if (is_utf8 != has_utf8) {
10198 sv_utf8_upgrade(sv);
10201 const STRLEN old_elen = elen;
10202 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
10203 sv_utf8_upgrade(nsv);
10204 eptr = SvPVX_const(nsv);
10207 if (width) { /* fudge width (can't fudge elen) */
10208 width += elen - old_elen;
10214 have = esignlen + zeros + elen;
10216 Perl_croak_nocontext("%s", PL_memory_wrap);
10218 need = (have > width ? have : width);
10221 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
10222 Perl_croak_nocontext("%s", PL_memory_wrap);
10223 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10225 if (esignlen && fill == '0') {
10227 for (i = 0; i < (int)esignlen; i++)
10228 *p++ = esignbuf[i];
10230 if (gap && !left) {
10231 memset(p, fill, gap);
10234 if (esignlen && fill != '0') {
10236 for (i = 0; i < (int)esignlen; i++)
10237 *p++ = esignbuf[i];
10241 for (i = zeros; i; i--)
10245 Copy(eptr, p, elen, char);
10249 memset(p, ' ', gap);
10254 Copy(dotstr, p, dotstrlen, char);
10258 vectorize = FALSE; /* done iterating over vecstr */
10265 SvCUR_set(sv, p - SvPVX_const(sv));
10273 /* =========================================================================
10275 =head1 Cloning an interpreter
10277 All the macros and functions in this section are for the private use of
10278 the main function, perl_clone().
10280 The foo_dup() functions make an exact copy of an existing foo thingy.
10281 During the course of a cloning, a hash table is used to map old addresses
10282 to new addresses. The table is created and manipulated with the
10283 ptr_table_* functions.
10287 * =========================================================================*/
10290 #if defined(USE_ITHREADS)
10292 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
10293 #ifndef GpREFCNT_inc
10294 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10298 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
10299 that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
10300 If this changes, please unmerge ss_dup.
10301 Likewise, sv_dup_inc_multiple() relies on this fact. */
10302 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10303 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t))
10304 #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
10305 #define av_dup_inc(s,t) MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10306 #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
10307 #define hv_dup_inc(s,t) MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10308 #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
10309 #define cv_dup_inc(s,t) MUTABLE_CV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10310 #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
10311 #define io_dup_inc(s,t) MUTABLE_IO(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10312 #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
10313 #define gv_dup_inc(s,t) MUTABLE_GV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10314 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
10315 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
10317 /* clone a parser */
10320 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
10324 PERL_ARGS_ASSERT_PARSER_DUP;
10329 /* look for it in the table first */
10330 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
10334 /* create anew and remember what it is */
10335 Newxz(parser, 1, yy_parser);
10336 ptr_table_store(PL_ptr_table, proto, parser);
10338 parser->yyerrstatus = 0;
10339 parser->yychar = YYEMPTY; /* Cause a token to be read. */
10341 /* XXX these not yet duped */
10342 parser->old_parser = NULL;
10343 parser->stack = NULL;
10345 parser->stack_size = 0;
10346 /* XXX parser->stack->state = 0; */
10348 /* XXX eventually, just Copy() most of the parser struct ? */
10350 parser->lex_brackets = proto->lex_brackets;
10351 parser->lex_casemods = proto->lex_casemods;
10352 parser->lex_brackstack = savepvn(proto->lex_brackstack,
10353 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
10354 parser->lex_casestack = savepvn(proto->lex_casestack,
10355 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
10356 parser->lex_defer = proto->lex_defer;
10357 parser->lex_dojoin = proto->lex_dojoin;
10358 parser->lex_expect = proto->lex_expect;
10359 parser->lex_formbrack = proto->lex_formbrack;
10360 parser->lex_inpat = proto->lex_inpat;
10361 parser->lex_inwhat = proto->lex_inwhat;
10362 parser->lex_op = proto->lex_op;
10363 parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
10364 parser->lex_starts = proto->lex_starts;
10365 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
10366 parser->multi_close = proto->multi_close;
10367 parser->multi_open = proto->multi_open;
10368 parser->multi_start = proto->multi_start;
10369 parser->multi_end = proto->multi_end;
10370 parser->pending_ident = proto->pending_ident;
10371 parser->preambled = proto->preambled;
10372 parser->sublex_info = proto->sublex_info; /* XXX not quite right */
10373 parser->linestr = sv_dup_inc(proto->linestr, param);
10374 parser->expect = proto->expect;
10375 parser->copline = proto->copline;
10376 parser->last_lop_op = proto->last_lop_op;
10377 parser->lex_state = proto->lex_state;
10378 parser->rsfp = fp_dup(proto->rsfp, '<', param);
10379 /* rsfp_filters entries have fake IoDIRP() */
10380 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
10381 parser->in_my = proto->in_my;
10382 parser->in_my_stash = hv_dup(proto->in_my_stash, param);
10383 parser->error_count = proto->error_count;
10386 parser->linestr = sv_dup_inc(proto->linestr, param);
10389 char * const ols = SvPVX(proto->linestr);
10390 char * const ls = SvPVX(parser->linestr);
10392 parser->bufptr = ls + (proto->bufptr >= ols ?
10393 proto->bufptr - ols : 0);
10394 parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
10395 proto->oldbufptr - ols : 0);
10396 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
10397 proto->oldoldbufptr - ols : 0);
10398 parser->linestart = ls + (proto->linestart >= ols ?
10399 proto->linestart - ols : 0);
10400 parser->last_uni = ls + (proto->last_uni >= ols ?
10401 proto->last_uni - ols : 0);
10402 parser->last_lop = ls + (proto->last_lop >= ols ?
10403 proto->last_lop - ols : 0);
10405 parser->bufend = ls + SvCUR(parser->linestr);
10408 Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
10412 parser->endwhite = proto->endwhite;
10413 parser->faketokens = proto->faketokens;
10414 parser->lasttoke = proto->lasttoke;
10415 parser->nextwhite = proto->nextwhite;
10416 parser->realtokenstart = proto->realtokenstart;
10417 parser->skipwhite = proto->skipwhite;
10418 parser->thisclose = proto->thisclose;
10419 parser->thismad = proto->thismad;
10420 parser->thisopen = proto->thisopen;
10421 parser->thisstuff = proto->thisstuff;
10422 parser->thistoken = proto->thistoken;
10423 parser->thiswhite = proto->thiswhite;
10425 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
10426 parser->curforce = proto->curforce;
10428 Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
10429 Copy(proto->nexttype, parser->nexttype, 5, I32);
10430 parser->nexttoke = proto->nexttoke;
10436 /* duplicate a file handle */
10439 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
10443 PERL_ARGS_ASSERT_FP_DUP;
10444 PERL_UNUSED_ARG(type);
10447 return (PerlIO*)NULL;
10449 /* look for it in the table first */
10450 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10454 /* create anew and remember what it is */
10455 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10456 ptr_table_store(PL_ptr_table, fp, ret);
10460 /* duplicate a directory handle */
10463 Perl_dirp_dup(pTHX_ DIR *const dp)
10465 PERL_UNUSED_CONTEXT;
10472 /* duplicate a typeglob */
10475 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
10479 PERL_ARGS_ASSERT_GP_DUP;
10483 /* look for it in the table first */
10484 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10488 /* create anew and remember what it is */
10490 ptr_table_store(PL_ptr_table, gp, ret);
10493 /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
10494 on Newxz() to do this for us. */
10495 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10496 ret->gp_io = io_dup_inc(gp->gp_io, param);
10497 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10498 ret->gp_av = av_dup_inc(gp->gp_av, param);
10499 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10500 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10501 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10502 ret->gp_cvgen = gp->gp_cvgen;
10503 ret->gp_line = gp->gp_line;
10504 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
10508 /* duplicate a chain of magic */
10511 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
10513 MAGIC *mgret = NULL;
10514 MAGIC **mgprev_p = &mgret;
10516 PERL_ARGS_ASSERT_MG_DUP;
10518 for (; mg; mg = mg->mg_moremagic) {
10520 Newx(nmg, 1, MAGIC);
10522 mgprev_p = &(nmg->mg_moremagic);
10524 /* There was a comment "XXX copy dynamic vtable?" but as we don't have
10525 dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
10526 from the original commit adding Perl_mg_dup() - revision 4538.
10527 Similarly there is the annotation "XXX random ptr?" next to the
10528 assignment to nmg->mg_ptr. */
10531 /* FIXME for plugins
10532 if (nmg->mg_type == PERL_MAGIC_qr) {
10533 nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
10537 if(nmg->mg_type == PERL_MAGIC_backref) {
10538 /* The backref AV has its reference count deliberately bumped by
10541 = SvREFCNT_inc(av_dup_inc((const AV *) nmg->mg_obj, param));
10544 nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
10545 ? sv_dup_inc(nmg->mg_obj, param)
10546 : sv_dup(nmg->mg_obj, param);
10549 if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
10550 if (nmg->mg_len > 0) {
10551 nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
10552 if (nmg->mg_type == PERL_MAGIC_overload_table &&
10553 AMT_AMAGIC((AMT*)nmg->mg_ptr))
10555 AMT * const namtp = (AMT*)nmg->mg_ptr;
10556 sv_dup_inc_multiple((SV**)(namtp->table),
10557 (SV**)(namtp->table), NofAMmeth, param);
10560 else if (nmg->mg_len == HEf_SVKEY)
10561 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
10563 if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
10564 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10570 #endif /* USE_ITHREADS */
10572 /* create a new pointer-mapping table */
10575 Perl_ptr_table_new(pTHX)
10578 PERL_UNUSED_CONTEXT;
10580 Newx(tbl, 1, PTR_TBL_t);
10581 tbl->tbl_max = 511;
10582 tbl->tbl_items = 0;
10583 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10587 #define PTR_TABLE_HASH(ptr) \
10588 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
10591 we use the PTE_SVSLOT 'reservation' made above, both here (in the
10592 following define) and at call to new_body_inline made below in
10593 Perl_ptr_table_store()
10596 #define del_pte(p) del_body_type(p, PTE_SVSLOT)
10598 /* map an existing pointer using a table */
10600 STATIC PTR_TBL_ENT_t *
10601 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
10603 PTR_TBL_ENT_t *tblent;
10604 const UV hash = PTR_TABLE_HASH(sv);
10606 PERL_ARGS_ASSERT_PTR_TABLE_FIND;
10608 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10609 for (; tblent; tblent = tblent->next) {
10610 if (tblent->oldval == sv)
10617 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
10619 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
10621 PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
10622 PERL_UNUSED_CONTEXT;
10624 return tblent ? tblent->newval : NULL;
10627 /* add a new entry to a pointer-mapping table */
10630 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
10632 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
10634 PERL_ARGS_ASSERT_PTR_TABLE_STORE;
10635 PERL_UNUSED_CONTEXT;
10638 tblent->newval = newsv;
10640 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
10642 new_body_inline(tblent, PTE_SVSLOT);
10644 tblent->oldval = oldsv;
10645 tblent->newval = newsv;
10646 tblent->next = tbl->tbl_ary[entry];
10647 tbl->tbl_ary[entry] = tblent;
10649 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
10650 ptr_table_split(tbl);
10654 /* double the hash bucket size of an existing ptr table */
10657 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
10659 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10660 const UV oldsize = tbl->tbl_max + 1;
10661 UV newsize = oldsize * 2;
10664 PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
10665 PERL_UNUSED_CONTEXT;
10667 Renew(ary, newsize, PTR_TBL_ENT_t*);
10668 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10669 tbl->tbl_max = --newsize;
10670 tbl->tbl_ary = ary;
10671 for (i=0; i < oldsize; i++, ary++) {
10672 PTR_TBL_ENT_t **curentp, **entp, *ent;
10675 curentp = ary + oldsize;
10676 for (entp = ary, ent = *ary; ent; ent = *entp) {
10677 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10679 ent->next = *curentp;
10689 /* remove all the entries from a ptr table */
10692 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
10694 if (tbl && tbl->tbl_items) {
10695 register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary;
10696 UV riter = tbl->tbl_max;
10699 PTR_TBL_ENT_t *entry = array[riter];
10702 PTR_TBL_ENT_t * const oentry = entry;
10703 entry = entry->next;
10708 tbl->tbl_items = 0;
10712 /* clear and free a ptr table */
10715 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
10720 ptr_table_clear(tbl);
10721 Safefree(tbl->tbl_ary);
10725 #if defined(USE_ITHREADS)
10728 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
10730 PERL_ARGS_ASSERT_RVPV_DUP;
10733 SvRV_set(dstr, SvWEAKREF(sstr)
10734 ? sv_dup(SvRV_const(sstr), param)
10735 : sv_dup_inc(SvRV_const(sstr), param));
10738 else if (SvPVX_const(sstr)) {
10739 /* Has something there */
10741 /* Normal PV - clone whole allocated space */
10742 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10743 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10744 /* Not that normal - actually sstr is copy on write.
10745 But we are a true, independant SV, so: */
10746 SvREADONLY_off(dstr);
10751 /* Special case - not normally malloced for some reason */
10752 if (isGV_with_GP(sstr)) {
10753 /* Don't need to do anything here. */
10755 else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10756 /* A "shared" PV - clone it as "shared" PV */
10758 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10762 /* Some other special case - random pointer */
10763 SvPV_set(dstr, (char *) SvPVX_const(sstr));
10768 /* Copy the NULL */
10769 SvPV_set(dstr, NULL);
10773 /* duplicate a list of SVs. source and dest may point to the same memory. */
10775 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
10776 SSize_t items, CLONE_PARAMS *const param)
10778 PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
10780 while (items-- > 0) {
10781 *dest++ = sv_dup_inc(*source++, param);
10787 /* duplicate an SV of any type (including AV, HV etc) */
10790 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
10795 PERL_ARGS_ASSERT_SV_DUP;
10799 if (SvTYPE(sstr) == SVTYPEMASK) {
10800 #ifdef DEBUG_LEAKING_SCALARS_ABORT
10805 /* look for it in the table first */
10806 dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
10810 if(param->flags & CLONEf_JOIN_IN) {
10811 /** We are joining here so we don't want do clone
10812 something that is bad **/
10813 if (SvTYPE(sstr) == SVt_PVHV) {
10814 const HEK * const hvname = HvNAME_HEK(sstr);
10816 /** don't clone stashes if they already exist **/
10817 return MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
10821 /* create anew and remember what it is */
10824 #ifdef DEBUG_LEAKING_SCALARS
10825 dstr->sv_debug_optype = sstr->sv_debug_optype;
10826 dstr->sv_debug_line = sstr->sv_debug_line;
10827 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10828 dstr->sv_debug_cloned = 1;
10829 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10832 ptr_table_store(PL_ptr_table, sstr, dstr);
10835 SvFLAGS(dstr) = SvFLAGS(sstr);
10836 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10837 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10840 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10841 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10842 (void*)PL_watch_pvx, SvPVX_const(sstr));
10845 /* don't clone objects whose class has asked us not to */
10846 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10851 switch (SvTYPE(sstr)) {
10853 SvANY(dstr) = NULL;
10856 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10858 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10860 SvIV_set(dstr, SvIVX(sstr));
10864 SvANY(dstr) = new_XNV();
10865 SvNV_set(dstr, SvNVX(sstr));
10867 /* case SVt_BIND: */
10870 /* These are all the types that need complex bodies allocating. */
10872 const svtype sv_type = SvTYPE(sstr);
10873 const struct body_details *const sv_type_details
10874 = bodies_by_type + sv_type;
10878 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
10893 assert(sv_type_details->body_size);
10894 if (sv_type_details->arena) {
10895 new_body_inline(new_body, sv_type);
10897 = (void*)((char*)new_body - sv_type_details->offset);
10899 new_body = new_NOARENA(sv_type_details);
10903 SvANY(dstr) = new_body;
10906 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
10907 ((char*)SvANY(dstr)) + sv_type_details->offset,
10908 sv_type_details->copy, char);
10910 Copy(((char*)SvANY(sstr)),
10911 ((char*)SvANY(dstr)),
10912 sv_type_details->body_size + sv_type_details->offset, char);
10915 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
10916 && !isGV_with_GP(dstr))
10917 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10919 /* The Copy above means that all the source (unduplicated) pointers
10920 are now in the destination. We can check the flags and the
10921 pointers in either, but it's possible that there's less cache
10922 missing by always going for the destination.
10923 FIXME - instrument and check that assumption */
10924 if (sv_type >= SVt_PVMG) {
10925 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
10926 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
10927 } else if (SvMAGIC(dstr))
10928 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
10930 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
10933 /* The cast silences a GCC warning about unhandled types. */
10934 switch ((int)sv_type) {
10944 /* FIXME for plugins */
10945 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
10948 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
10949 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
10950 LvTARG(dstr) = dstr;
10951 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
10952 LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
10954 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
10956 if(isGV_with_GP(sstr)) {
10957 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
10958 /* Don't call sv_add_backref here as it's going to be
10959 created as part of the magic cloning of the symbol
10961 /* Danger Will Robinson - GvGP(dstr) isn't initialised
10962 at the point of this comment. */
10963 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
10964 GvGP(dstr) = gp_dup(GvGP(sstr), param);
10965 (void)GpREFCNT_inc(GvGP(dstr));
10967 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10970 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
10971 if (IoOFP(dstr) == IoIFP(sstr))
10972 IoOFP(dstr) = IoIFP(dstr);
10974 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
10975 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
10976 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
10977 /* I have no idea why fake dirp (rsfps)
10978 should be treated differently but otherwise
10979 we end up with leaks -- sky*/
10980 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
10981 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
10982 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
10984 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
10985 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
10986 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
10987 if (IoDIRP(dstr)) {
10988 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
10991 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
10994 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
10995 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
10996 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
10999 /* avoid cloning an empty array */
11000 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
11001 SV **dst_ary, **src_ary;
11002 SSize_t items = AvFILLp((const AV *)sstr) + 1;
11004 src_ary = AvARRAY((const AV *)sstr);
11005 Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
11006 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
11007 AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
11008 AvALLOC((const AV *)dstr) = dst_ary;
11009 if (AvREAL((const AV *)sstr)) {
11010 dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
11014 while (items-- > 0)
11015 *dst_ary++ = sv_dup(*src_ary++, param);
11017 items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
11018 while (items-- > 0) {
11019 *dst_ary++ = &PL_sv_undef;
11023 AvARRAY(MUTABLE_AV(dstr)) = NULL;
11024 AvALLOC((const AV *)dstr) = (SV**)NULL;
11025 AvMAX( (const AV *)dstr) = -1;
11026 AvFILLp((const AV *)dstr) = -1;
11030 if (HvARRAY((const HV *)sstr)) {
11032 const bool sharekeys = !!HvSHAREKEYS(sstr);
11033 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
11034 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
11036 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
11037 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
11039 HvARRAY(dstr) = (HE**)darray;
11040 while (i <= sxhv->xhv_max) {
11041 const HE * const source = HvARRAY(sstr)[i];
11042 HvARRAY(dstr)[i] = source
11043 ? he_dup(source, sharekeys, param) : 0;
11048 const struct xpvhv_aux * const saux = HvAUX(sstr);
11049 struct xpvhv_aux * const daux = HvAUX(dstr);
11050 /* This flag isn't copied. */
11051 /* SvOOK_on(hv) attacks the IV flags. */
11052 SvFLAGS(dstr) |= SVf_OOK;
11054 hvname = saux->xhv_name;
11055 daux->xhv_name = hek_dup(hvname, param);
11057 daux->xhv_riter = saux->xhv_riter;
11058 daux->xhv_eiter = saux->xhv_eiter
11059 ? he_dup(saux->xhv_eiter,
11060 (bool)!!HvSHAREKEYS(sstr), param) : 0;
11061 /* backref array needs refcnt=2; see sv_add_backref */
11062 daux->xhv_backreferences =
11063 saux->xhv_backreferences
11064 ? MUTABLE_AV(SvREFCNT_inc(
11065 sv_dup_inc((const SV *)saux->xhv_backreferences, param)))
11068 daux->xhv_mro_meta = saux->xhv_mro_meta
11069 ? mro_meta_dup(saux->xhv_mro_meta, param)
11072 /* Record stashes for possible cloning in Perl_clone(). */
11074 av_push(param->stashes, dstr);
11078 HvARRAY(MUTABLE_HV(dstr)) = NULL;
11081 if (!(param->flags & CLONEf_COPY_STACKS)) {
11085 /* NOTE: not refcounted */
11086 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
11088 if (!CvISXSUB(dstr))
11089 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
11091 if (CvCONST(dstr) && CvISXSUB(dstr)) {
11092 CvXSUBANY(dstr).any_ptr =
11093 sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
11095 /* don't dup if copying back - CvGV isn't refcounted, so the
11096 * duped GV may never be freed. A bit of a hack! DAPM */
11097 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
11098 NULL : gv_dup(CvGV(dstr), param) ;
11099 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
11101 CvWEAKOUTSIDE(sstr)
11102 ? cv_dup( CvOUTSIDE(dstr), param)
11103 : cv_dup_inc(CvOUTSIDE(dstr), param);
11104 if (!CvISXSUB(dstr))
11105 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
11111 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11117 /* duplicate a context */
11120 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11122 PERL_CONTEXT *ncxs;
11124 PERL_ARGS_ASSERT_CX_DUP;
11127 return (PERL_CONTEXT*)NULL;
11129 /* look for it in the table first */
11130 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11134 /* create anew and remember what it is */
11135 Newx(ncxs, max + 1, PERL_CONTEXT);
11136 ptr_table_store(PL_ptr_table, cxs, ncxs);
11137 Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
11140 PERL_CONTEXT * const ncx = &ncxs[ix];
11141 if (CxTYPE(ncx) == CXt_SUBST) {
11142 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11145 switch (CxTYPE(ncx)) {
11147 ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
11148 ? cv_dup_inc(ncx->blk_sub.cv, param)
11149 : cv_dup(ncx->blk_sub.cv,param));
11150 ncx->blk_sub.argarray = (CxHASARGS(ncx)
11151 ? av_dup_inc(ncx->blk_sub.argarray,
11154 ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
11156 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
11157 ncx->blk_sub.oldcomppad);
11160 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
11162 ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
11164 case CXt_LOOP_LAZYSV:
11165 ncx->blk_loop.state_u.lazysv.end
11166 = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
11167 /* We are taking advantage of av_dup_inc and sv_dup_inc
11168 actually being the same function, and order equivalance of
11170 We can assert the later [but only at run time :-(] */
11171 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
11172 (void *) &ncx->blk_loop.state_u.lazysv.cur);
11174 ncx->blk_loop.state_u.ary.ary
11175 = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
11176 case CXt_LOOP_LAZYIV:
11177 case CXt_LOOP_PLAIN:
11178 if (CxPADLOOP(ncx)) {
11179 ncx->blk_loop.oldcomppad
11180 = (PAD*)ptr_table_fetch(PL_ptr_table,
11181 ncx->blk_loop.oldcomppad);
11183 ncx->blk_loop.oldcomppad
11184 = (PAD*)gv_dup((const GV *)ncx->blk_loop.oldcomppad,
11189 ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
11190 ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
11191 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
11204 /* duplicate a stack info structure */
11207 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11211 PERL_ARGS_ASSERT_SI_DUP;
11214 return (PERL_SI*)NULL;
11216 /* look for it in the table first */
11217 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11221 /* create anew and remember what it is */
11222 Newxz(nsi, 1, PERL_SI);
11223 ptr_table_store(PL_ptr_table, si, nsi);
11225 nsi->si_stack = av_dup_inc(si->si_stack, param);
11226 nsi->si_cxix = si->si_cxix;
11227 nsi->si_cxmax = si->si_cxmax;
11228 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11229 nsi->si_type = si->si_type;
11230 nsi->si_prev = si_dup(si->si_prev, param);
11231 nsi->si_next = si_dup(si->si_next, param);
11232 nsi->si_markoff = si->si_markoff;
11237 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
11238 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
11239 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
11240 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
11241 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
11242 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
11243 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
11244 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
11245 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
11246 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
11247 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
11248 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
11249 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11250 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11253 #define pv_dup_inc(p) SAVEPV(p)
11254 #define pv_dup(p) SAVEPV(p)
11255 #define svp_dup_inc(p,pp) any_dup(p,pp)
11257 /* map any object to the new equivent - either something in the
11258 * ptr table, or something in the interpreter structure
11262 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
11266 PERL_ARGS_ASSERT_ANY_DUP;
11269 return (void*)NULL;
11271 /* look for it in the table first */
11272 ret = ptr_table_fetch(PL_ptr_table, v);
11276 /* see if it is part of the interpreter structure */
11277 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11278 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11286 /* duplicate the save stack */
11289 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11292 ANY * const ss = proto_perl->Isavestack;
11293 const I32 max = proto_perl->Isavestack_max;
11294 I32 ix = proto_perl->Isavestack_ix;
11307 void (*dptr) (void*);
11308 void (*dxptr) (pTHX_ void*);
11310 PERL_ARGS_ASSERT_SS_DUP;
11312 Newxz(nss, max, ANY);
11315 const I32 type = POPINT(ss,ix);
11316 TOPINT(nss,ix) = type;
11318 case SAVEt_HELEM: /* hash element */
11319 sv = (const SV *)POPPTR(ss,ix);
11320 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11322 case SAVEt_ITEM: /* normal string */
11323 case SAVEt_SV: /* scalar reference */
11324 sv = (const SV *)POPPTR(ss,ix);
11325 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11328 case SAVEt_MORTALIZESV:
11329 sv = (const SV *)POPPTR(ss,ix);
11330 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11332 case SAVEt_SHARED_PVREF: /* char* in shared space */
11333 c = (char*)POPPTR(ss,ix);
11334 TOPPTR(nss,ix) = savesharedpv(c);
11335 ptr = POPPTR(ss,ix);
11336 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11338 case SAVEt_GENERIC_SVREF: /* generic sv */
11339 case SAVEt_SVREF: /* scalar reference */
11340 sv = (const SV *)POPPTR(ss,ix);
11341 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11342 ptr = POPPTR(ss,ix);
11343 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11345 case SAVEt_HV: /* hash reference */
11346 case SAVEt_AV: /* array reference */
11347 sv = (const SV *) POPPTR(ss,ix);
11348 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11350 case SAVEt_COMPPAD:
11352 sv = (const SV *) POPPTR(ss,ix);
11353 TOPPTR(nss,ix) = sv_dup(sv, param);
11355 case SAVEt_INT: /* int reference */
11356 ptr = POPPTR(ss,ix);
11357 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11358 intval = (int)POPINT(ss,ix);
11359 TOPINT(nss,ix) = intval;
11361 case SAVEt_LONG: /* long reference */
11362 ptr = POPPTR(ss,ix);
11363 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11365 case SAVEt_CLEARSV:
11366 longval = (long)POPLONG(ss,ix);
11367 TOPLONG(nss,ix) = longval;
11369 case SAVEt_I32: /* I32 reference */
11370 case SAVEt_I16: /* I16 reference */
11371 case SAVEt_I8: /* I8 reference */
11372 case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
11373 ptr = POPPTR(ss,ix);
11374 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11376 TOPINT(nss,ix) = i;
11378 case SAVEt_IV: /* IV reference */
11379 ptr = POPPTR(ss,ix);
11380 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11382 TOPIV(nss,ix) = iv;
11384 case SAVEt_HPTR: /* HV* reference */
11385 case SAVEt_APTR: /* AV* reference */
11386 case SAVEt_SPTR: /* SV* reference */
11387 ptr = POPPTR(ss,ix);
11388 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11389 sv = (const SV *)POPPTR(ss,ix);
11390 TOPPTR(nss,ix) = sv_dup(sv, param);
11392 case SAVEt_VPTR: /* random* reference */
11393 ptr = POPPTR(ss,ix);
11394 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11395 ptr = POPPTR(ss,ix);
11396 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11398 case SAVEt_GENERIC_PVREF: /* generic char* */
11399 case SAVEt_PPTR: /* char* reference */
11400 ptr = POPPTR(ss,ix);
11401 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11402 c = (char*)POPPTR(ss,ix);
11403 TOPPTR(nss,ix) = pv_dup(c);
11405 case SAVEt_GP: /* scalar reference */
11406 gp = (GP*)POPPTR(ss,ix);
11407 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11408 (void)GpREFCNT_inc(gp);
11409 gv = (const GV *)POPPTR(ss,ix);
11410 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11413 ptr = POPPTR(ss,ix);
11414 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11415 /* these are assumed to be refcounted properly */
11417 switch (((OP*)ptr)->op_type) {
11419 case OP_LEAVESUBLV:
11423 case OP_LEAVEWRITE:
11424 TOPPTR(nss,ix) = ptr;
11427 (void) OpREFCNT_inc(o);
11431 TOPPTR(nss,ix) = NULL;
11436 TOPPTR(nss,ix) = NULL;
11439 hv = (const HV *)POPPTR(ss,ix);
11440 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11442 TOPINT(nss,ix) = i;
11445 c = (char*)POPPTR(ss,ix);
11446 TOPPTR(nss,ix) = pv_dup_inc(c);
11448 case SAVEt_STACK_POS: /* Position on Perl stack */
11450 TOPINT(nss,ix) = i;
11452 case SAVEt_DESTRUCTOR:
11453 ptr = POPPTR(ss,ix);
11454 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11455 dptr = POPDPTR(ss,ix);
11456 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
11457 any_dup(FPTR2DPTR(void *, dptr),
11460 case SAVEt_DESTRUCTOR_X:
11461 ptr = POPPTR(ss,ix);
11462 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11463 dxptr = POPDXPTR(ss,ix);
11464 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
11465 any_dup(FPTR2DPTR(void *, dxptr),
11468 case SAVEt_REGCONTEXT:
11471 TOPINT(nss,ix) = i;
11474 case SAVEt_AELEM: /* array element */
11475 sv = (const SV *)POPPTR(ss,ix);
11476 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11478 TOPINT(nss,ix) = i;
11479 av = (const AV *)POPPTR(ss,ix);
11480 TOPPTR(nss,ix) = av_dup_inc(av, param);
11483 ptr = POPPTR(ss,ix);
11484 TOPPTR(nss,ix) = ptr;
11487 ptr = POPPTR(ss,ix);
11490 ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
11491 HINTS_REFCNT_UNLOCK;
11493 TOPPTR(nss,ix) = ptr;
11495 TOPINT(nss,ix) = i;
11496 if (i & HINT_LOCALIZE_HH) {
11497 hv = (const HV *)POPPTR(ss,ix);
11498 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11501 case SAVEt_PADSV_AND_MORTALIZE:
11502 longval = (long)POPLONG(ss,ix);
11503 TOPLONG(nss,ix) = longval;
11504 ptr = POPPTR(ss,ix);
11505 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11506 sv = (const SV *)POPPTR(ss,ix);
11507 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11510 ptr = POPPTR(ss,ix);
11511 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11512 longval = (long)POPBOOL(ss,ix);
11513 TOPBOOL(nss,ix) = (bool)longval;
11515 case SAVEt_SET_SVFLAGS:
11517 TOPINT(nss,ix) = i;
11519 TOPINT(nss,ix) = i;
11520 sv = (const SV *)POPPTR(ss,ix);
11521 TOPPTR(nss,ix) = sv_dup(sv, param);
11523 case SAVEt_RE_STATE:
11525 const struct re_save_state *const old_state
11526 = (struct re_save_state *)
11527 (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11528 struct re_save_state *const new_state
11529 = (struct re_save_state *)
11530 (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11532 Copy(old_state, new_state, 1, struct re_save_state);
11533 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11535 new_state->re_state_bostr
11536 = pv_dup(old_state->re_state_bostr);
11537 new_state->re_state_reginput
11538 = pv_dup(old_state->re_state_reginput);
11539 new_state->re_state_regeol
11540 = pv_dup(old_state->re_state_regeol);
11541 new_state->re_state_regoffs
11542 = (regexp_paren_pair*)
11543 any_dup(old_state->re_state_regoffs, proto_perl);
11544 new_state->re_state_reglastparen
11545 = (U32*) any_dup(old_state->re_state_reglastparen,
11547 new_state->re_state_reglastcloseparen
11548 = (U32*)any_dup(old_state->re_state_reglastcloseparen,
11550 /* XXX This just has to be broken. The old save_re_context
11551 code did SAVEGENERICPV(PL_reg_start_tmp);
11552 PL_reg_start_tmp is char **.
11553 Look above to what the dup code does for
11554 SAVEt_GENERIC_PVREF
11555 It can never have worked.
11556 So this is merely a faithful copy of the exiting bug: */
11557 new_state->re_state_reg_start_tmp
11558 = (char **) pv_dup((char *)
11559 old_state->re_state_reg_start_tmp);
11560 /* I assume that it only ever "worked" because no-one called
11561 (pseudo)fork while the regexp engine had re-entered itself.
11563 #ifdef PERL_OLD_COPY_ON_WRITE
11564 new_state->re_state_nrs
11565 = sv_dup(old_state->re_state_nrs, param);
11567 new_state->re_state_reg_magic
11568 = (MAGIC*) any_dup(old_state->re_state_reg_magic,
11570 new_state->re_state_reg_oldcurpm
11571 = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
11573 new_state->re_state_reg_curpm
11574 = (PMOP*) any_dup(old_state->re_state_reg_curpm,
11576 new_state->re_state_reg_oldsaved
11577 = pv_dup(old_state->re_state_reg_oldsaved);
11578 new_state->re_state_reg_poscache
11579 = pv_dup(old_state->re_state_reg_poscache);
11580 new_state->re_state_reg_starttry
11581 = pv_dup(old_state->re_state_reg_starttry);
11584 case SAVEt_COMPILE_WARNINGS:
11585 ptr = POPPTR(ss,ix);
11586 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
11589 ptr = POPPTR(ss,ix);
11590 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
11594 "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
11602 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11603 * flag to the result. This is done for each stash before cloning starts,
11604 * so we know which stashes want their objects cloned */
11607 do_mark_cloneable_stash(pTHX_ SV *const sv)
11609 const HEK * const hvname = HvNAME_HEK((const HV *)sv);
11611 GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
11612 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11613 if (cloner && GvCV(cloner)) {
11620 mXPUSHs(newSVhek(hvname));
11622 call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
11629 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11637 =for apidoc perl_clone
11639 Create and return a new interpreter by cloning the current one.
11641 perl_clone takes these flags as parameters:
11643 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11644 without it we only clone the data and zero the stacks,
11645 with it we copy the stacks and the new perl interpreter is
11646 ready to run at the exact same point as the previous one.
11647 The pseudo-fork code uses COPY_STACKS while the
11648 threads->create doesn't.
11650 CLONEf_KEEP_PTR_TABLE
11651 perl_clone keeps a ptr_table with the pointer of the old
11652 variable as a key and the new variable as a value,
11653 this allows it to check if something has been cloned and not
11654 clone it again but rather just use the value and increase the
11655 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11656 the ptr_table using the function
11657 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11658 reason to keep it around is if you want to dup some of your own
11659 variable who are outside the graph perl scans, example of this
11660 code is in threads.xs create
11663 This is a win32 thing, it is ignored on unix, it tells perls
11664 win32host code (which is c++) to clone itself, this is needed on
11665 win32 if you want to run two threads at the same time,
11666 if you just want to do some stuff in a separate perl interpreter
11667 and then throw it away and return to the original one,
11668 you don't need to do anything.
11673 /* XXX the above needs expanding by someone who actually understands it ! */
11674 EXTERN_C PerlInterpreter *
11675 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11678 perl_clone(PerlInterpreter *proto_perl, UV flags)
11681 #ifdef PERL_IMPLICIT_SYS
11683 PERL_ARGS_ASSERT_PERL_CLONE;
11685 /* perlhost.h so we need to call into it
11686 to clone the host, CPerlHost should have a c interface, sky */
11688 if (flags & CLONEf_CLONE_HOST) {
11689 return perl_clone_host(proto_perl,flags);
11691 return perl_clone_using(proto_perl, flags,
11693 proto_perl->IMemShared,
11694 proto_perl->IMemParse,
11696 proto_perl->IStdIO,
11700 proto_perl->IProc);
11704 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11705 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11706 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11707 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11708 struct IPerlDir* ipD, struct IPerlSock* ipS,
11709 struct IPerlProc* ipP)
11711 /* XXX many of the string copies here can be optimized if they're
11712 * constants; they need to be allocated as common memory and just
11713 * their pointers copied. */
11716 CLONE_PARAMS clone_params;
11717 CLONE_PARAMS* const param = &clone_params;
11719 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11721 PERL_ARGS_ASSERT_PERL_CLONE_USING;
11723 /* for each stash, determine whether its objects should be cloned */
11724 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11725 PERL_SET_THX(my_perl);
11728 PoisonNew(my_perl, 1, PerlInterpreter);
11734 PL_savestack_ix = 0;
11735 PL_savestack_max = -1;
11736 PL_sig_pending = 0;
11738 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11739 # else /* !DEBUGGING */
11740 Zero(my_perl, 1, PerlInterpreter);
11741 # endif /* DEBUGGING */
11743 /* host pointers */
11745 PL_MemShared = ipMS;
11746 PL_MemParse = ipMP;
11753 #else /* !PERL_IMPLICIT_SYS */
11755 CLONE_PARAMS clone_params;
11756 CLONE_PARAMS* param = &clone_params;
11757 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11759 PERL_ARGS_ASSERT_PERL_CLONE;
11761 /* for each stash, determine whether its objects should be cloned */
11762 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11763 PERL_SET_THX(my_perl);
11766 PoisonNew(my_perl, 1, PerlInterpreter);
11772 PL_savestack_ix = 0;
11773 PL_savestack_max = -1;
11774 PL_sig_pending = 0;
11776 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11777 # else /* !DEBUGGING */
11778 Zero(my_perl, 1, PerlInterpreter);
11779 # endif /* DEBUGGING */
11780 #endif /* PERL_IMPLICIT_SYS */
11781 param->flags = flags;
11782 param->proto_perl = proto_perl;
11784 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
11786 PL_body_arenas = NULL;
11787 Zero(&PL_body_roots, 1, PL_body_roots);
11789 PL_nice_chunk = NULL;
11790 PL_nice_chunk_size = 0;
11792 PL_sv_objcount = 0;
11794 PL_sv_arenaroot = NULL;
11796 PL_debug = proto_perl->Idebug;
11798 PL_hash_seed = proto_perl->Ihash_seed;
11799 PL_rehash_seed = proto_perl->Irehash_seed;
11801 #ifdef USE_REENTRANT_API
11802 /* XXX: things like -Dm will segfault here in perlio, but doing
11803 * PERL_SET_CONTEXT(proto_perl);
11804 * breaks too many other things
11806 Perl_reentrant_init(aTHX);
11809 /* create SV map for pointer relocation */
11810 PL_ptr_table = ptr_table_new();
11812 /* initialize these special pointers as early as possible */
11813 SvANY(&PL_sv_undef) = NULL;
11814 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11815 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11816 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11818 SvANY(&PL_sv_no) = new_XPVNV();
11819 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11820 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11821 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11822 SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
11823 SvCUR_set(&PL_sv_no, 0);
11824 SvLEN_set(&PL_sv_no, 1);
11825 SvIV_set(&PL_sv_no, 0);
11826 SvNV_set(&PL_sv_no, 0);
11827 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11829 SvANY(&PL_sv_yes) = new_XPVNV();
11830 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11831 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11832 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11833 SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
11834 SvCUR_set(&PL_sv_yes, 1);
11835 SvLEN_set(&PL_sv_yes, 2);
11836 SvIV_set(&PL_sv_yes, 1);
11837 SvNV_set(&PL_sv_yes, 1);
11838 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11840 /* create (a non-shared!) shared string table */
11841 PL_strtab = newHV();
11842 HvSHAREKEYS_off(PL_strtab);
11843 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
11844 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11846 PL_compiling = proto_perl->Icompiling;
11848 /* These two PVs will be free'd special way so must set them same way op.c does */
11849 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11850 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11852 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11853 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11855 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11856 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
11857 if (PL_compiling.cop_hints_hash) {
11859 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
11860 HINTS_REFCNT_UNLOCK;
11862 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
11863 #ifdef PERL_DEBUG_READONLY_OPS
11868 /* pseudo environmental stuff */
11869 PL_origargc = proto_perl->Iorigargc;
11870 PL_origargv = proto_perl->Iorigargv;
11872 param->stashes = newAV(); /* Setup array of objects to call clone on */
11874 /* Set tainting stuff before PerlIO_debug can possibly get called */
11875 PL_tainting = proto_perl->Itainting;
11876 PL_taint_warn = proto_perl->Itaint_warn;
11878 #ifdef PERLIO_LAYERS
11879 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11880 PerlIO_clone(aTHX_ proto_perl, param);
11883 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11884 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11885 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11886 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11887 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11888 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11891 PL_minus_c = proto_perl->Iminus_c;
11892 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11893 PL_localpatches = proto_perl->Ilocalpatches;
11894 PL_splitstr = proto_perl->Isplitstr;
11895 PL_minus_n = proto_perl->Iminus_n;
11896 PL_minus_p = proto_perl->Iminus_p;
11897 PL_minus_l = proto_perl->Iminus_l;
11898 PL_minus_a = proto_perl->Iminus_a;
11899 PL_minus_E = proto_perl->Iminus_E;
11900 PL_minus_F = proto_perl->Iminus_F;
11901 PL_doswitches = proto_perl->Idoswitches;
11902 PL_dowarn = proto_perl->Idowarn;
11903 PL_doextract = proto_perl->Idoextract;
11904 PL_sawampersand = proto_perl->Isawampersand;
11905 PL_unsafe = proto_perl->Iunsafe;
11906 PL_inplace = SAVEPV(proto_perl->Iinplace);
11907 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11908 PL_perldb = proto_perl->Iperldb;
11909 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11910 PL_exit_flags = proto_perl->Iexit_flags;
11912 /* magical thingies */
11913 /* XXX time(&PL_basetime) when asked for? */
11914 PL_basetime = proto_perl->Ibasetime;
11915 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11917 PL_maxsysfd = proto_perl->Imaxsysfd;
11918 PL_statusvalue = proto_perl->Istatusvalue;
11920 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11922 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
11924 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11926 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
11927 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
11928 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
11931 /* RE engine related */
11932 Zero(&PL_reg_state, 1, struct re_save_state);
11933 PL_reginterp_cnt = 0;
11934 PL_regmatch_slab = NULL;
11936 /* Clone the regex array */
11937 /* ORANGE FIXME for plugins, probably in the SV dup code.
11938 newSViv(PTR2IV(CALLREGDUPE(
11939 INT2PTR(REGEXP *, SvIVX(regex)), param))))
11941 PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
11942 PL_regex_pad = AvARRAY(PL_regex_padav);
11944 /* shortcuts to various I/O objects */
11945 PL_ofsgv = gv_dup(proto_perl->Iofsgv, param);
11946 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11947 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11948 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11949 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11950 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11951 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11953 /* shortcuts to regexp stuff */
11954 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11956 /* shortcuts to misc objects */
11957 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11959 /* shortcuts to debugging objects */
11960 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11961 PL_DBline = gv_dup(proto_perl->IDBline, param);
11962 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11963 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11964 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11965 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11966 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11968 /* symbol tables */
11969 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
11970 PL_curstash = hv_dup(proto_perl->Icurstash, param);
11971 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11972 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11973 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11975 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11976 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11977 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11978 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
11979 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
11980 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11981 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11982 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11984 PL_sub_generation = proto_perl->Isub_generation;
11985 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
11987 /* funky return mechanisms */
11988 PL_forkprocess = proto_perl->Iforkprocess;
11990 /* subprocess state */
11991 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11993 /* internal state */
11994 PL_maxo = proto_perl->Imaxo;
11995 if (proto_perl->Iop_mask)
11996 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11999 /* PL_asserting = proto_perl->Iasserting; */
12001 /* current interpreter roots */
12002 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
12004 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
12006 PL_main_start = proto_perl->Imain_start;
12007 PL_eval_root = proto_perl->Ieval_root;
12008 PL_eval_start = proto_perl->Ieval_start;
12010 /* runtime control stuff */
12011 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
12013 PL_filemode = proto_perl->Ifilemode;
12014 PL_lastfd = proto_perl->Ilastfd;
12015 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
12018 PL_gensym = proto_perl->Igensym;
12019 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
12020 PL_laststatval = proto_perl->Ilaststatval;
12021 PL_laststype = proto_perl->Ilaststype;
12024 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
12026 /* interpreter atexit processing */
12027 PL_exitlistlen = proto_perl->Iexitlistlen;
12028 if (PL_exitlistlen) {
12029 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12030 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12033 PL_exitlist = (PerlExitListEntry*)NULL;
12035 PL_my_cxt_size = proto_perl->Imy_cxt_size;
12036 if (PL_my_cxt_size) {
12037 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
12038 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
12039 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12040 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
12041 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
12045 PL_my_cxt_list = (void**)NULL;
12046 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12047 PL_my_cxt_keys = (const char**)NULL;
12050 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
12051 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
12052 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
12054 PL_profiledata = NULL;
12056 PL_compcv = cv_dup(proto_perl->Icompcv, param);
12058 PAD_CLONE_VARS(proto_perl, param);
12060 #ifdef HAVE_INTERP_INTERN
12061 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
12064 /* more statics moved here */
12065 PL_generation = proto_perl->Igeneration;
12066 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
12068 PL_in_clean_objs = proto_perl->Iin_clean_objs;
12069 PL_in_clean_all = proto_perl->Iin_clean_all;
12071 PL_uid = proto_perl->Iuid;
12072 PL_euid = proto_perl->Ieuid;
12073 PL_gid = proto_perl->Igid;
12074 PL_egid = proto_perl->Iegid;
12075 PL_nomemok = proto_perl->Inomemok;
12076 PL_an = proto_perl->Ian;
12077 PL_evalseq = proto_perl->Ievalseq;
12078 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
12079 PL_origalen = proto_perl->Iorigalen;
12080 #ifdef PERL_USES_PL_PIDSTATUS
12081 PL_pidstatus = newHV(); /* XXX flag for cloning? */
12083 PL_osname = SAVEPV(proto_perl->Iosname);
12084 PL_sighandlerp = proto_perl->Isighandlerp;
12086 PL_runops = proto_perl->Irunops;
12088 PL_parser = parser_dup(proto_perl->Iparser, param);
12090 PL_subline = proto_perl->Isubline;
12091 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
12094 PL_cryptseen = proto_perl->Icryptseen;
12097 PL_hints = proto_perl->Ihints;
12099 PL_amagic_generation = proto_perl->Iamagic_generation;
12101 #ifdef USE_LOCALE_COLLATE
12102 PL_collation_ix = proto_perl->Icollation_ix;
12103 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
12104 PL_collation_standard = proto_perl->Icollation_standard;
12105 PL_collxfrm_base = proto_perl->Icollxfrm_base;
12106 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
12107 #endif /* USE_LOCALE_COLLATE */
12109 #ifdef USE_LOCALE_NUMERIC
12110 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
12111 PL_numeric_standard = proto_perl->Inumeric_standard;
12112 PL_numeric_local = proto_perl->Inumeric_local;
12113 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12114 #endif /* !USE_LOCALE_NUMERIC */
12116 /* utf8 character classes */
12117 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12118 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
12119 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12120 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12121 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
12122 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12123 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
12124 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
12125 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
12126 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
12127 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
12128 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
12129 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12130 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
12131 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12132 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12133 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12134 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12135 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12136 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12138 /* Did the locale setup indicate UTF-8? */
12139 PL_utf8locale = proto_perl->Iutf8locale;
12140 /* Unicode features (see perlrun/-C) */
12141 PL_unicode = proto_perl->Iunicode;
12143 /* Pre-5.8 signals control */
12144 PL_signals = proto_perl->Isignals;
12146 /* times() ticks per second */
12147 PL_clocktick = proto_perl->Iclocktick;
12149 /* Recursion stopper for PerlIO_find_layer */
12150 PL_in_load_module = proto_perl->Iin_load_module;
12152 /* sort() routine */
12153 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
12155 /* Not really needed/useful since the reenrant_retint is "volatile",
12156 * but do it for consistency's sake. */
12157 PL_reentrant_retint = proto_perl->Ireentrant_retint;
12159 /* Hooks to shared SVs and locks. */
12160 PL_sharehook = proto_perl->Isharehook;
12161 PL_lockhook = proto_perl->Ilockhook;
12162 PL_unlockhook = proto_perl->Iunlockhook;
12163 PL_threadhook = proto_perl->Ithreadhook;
12164 PL_destroyhook = proto_perl->Idestroyhook;
12166 #ifdef THREADS_HAVE_PIDS
12167 PL_ppid = proto_perl->Ippid;
12171 PL_last_swash_hv = NULL; /* reinits on demand */
12172 PL_last_swash_klen = 0;
12173 PL_last_swash_key[0]= '\0';
12174 PL_last_swash_tmps = (U8*)NULL;
12175 PL_last_swash_slen = 0;
12177 PL_glob_index = proto_perl->Iglob_index;
12178 PL_srand_called = proto_perl->Isrand_called;
12179 PL_bitcount = NULL; /* reinits on demand */
12181 if (proto_perl->Ipsig_pend) {
12182 Newxz(PL_psig_pend, SIG_SIZE, int);
12185 PL_psig_pend = (int*)NULL;
12188 if (proto_perl->Ipsig_ptr) {
12189 Newx(PL_psig_ptr, SIG_SIZE, SV*);
12190 Newx(PL_psig_name, SIG_SIZE, SV*);
12191 sv_dup_inc_multiple(proto_perl->Ipsig_ptr, PL_psig_ptr, SIG_SIZE,
12193 sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, SIG_SIZE,
12197 PL_psig_ptr = (SV**)NULL;
12198 PL_psig_name = (SV**)NULL;
12201 /* intrpvar.h stuff */
12203 if (flags & CLONEf_COPY_STACKS) {
12204 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12205 PL_tmps_ix = proto_perl->Itmps_ix;
12206 PL_tmps_max = proto_perl->Itmps_max;
12207 PL_tmps_floor = proto_perl->Itmps_floor;
12208 Newx(PL_tmps_stack, PL_tmps_max, SV*);
12209 sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack, PL_tmps_ix,
12212 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12213 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
12214 Newxz(PL_markstack, i, I32);
12215 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
12216 - proto_perl->Imarkstack);
12217 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
12218 - proto_perl->Imarkstack);
12219 Copy(proto_perl->Imarkstack, PL_markstack,
12220 PL_markstack_ptr - PL_markstack + 1, I32);
12222 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12223 * NOTE: unlike the others! */
12224 PL_scopestack_ix = proto_perl->Iscopestack_ix;
12225 PL_scopestack_max = proto_perl->Iscopestack_max;
12226 Newxz(PL_scopestack, PL_scopestack_max, I32);
12227 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
12229 /* NOTE: si_dup() looks at PL_markstack */
12230 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
12232 /* PL_curstack = PL_curstackinfo->si_stack; */
12233 PL_curstack = av_dup(proto_perl->Icurstack, param);
12234 PL_mainstack = av_dup(proto_perl->Imainstack, param);
12236 /* next PUSHs() etc. set *(PL_stack_sp+1) */
12237 PL_stack_base = AvARRAY(PL_curstack);
12238 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
12239 - proto_perl->Istack_base);
12240 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
12242 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12243 * NOTE: unlike the others! */
12244 PL_savestack_ix = proto_perl->Isavestack_ix;
12245 PL_savestack_max = proto_perl->Isavestack_max;
12246 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
12247 PL_savestack = ss_dup(proto_perl, param);
12251 ENTER; /* perl_destruct() wants to LEAVE; */
12253 /* although we're not duplicating the tmps stack, we should still
12254 * add entries for any SVs on the tmps stack that got cloned by a
12255 * non-refcount means (eg a temp in @_); otherwise they will be
12258 for (i = 0; i<= proto_perl->Itmps_ix; i++) {
12259 SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table,
12260 proto_perl->Itmps_stack[i]));
12261 if (nsv && !SvREFCNT(nsv)) {
12263 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv);
12268 PL_start_env = proto_perl->Istart_env; /* XXXXXX */
12269 PL_top_env = &PL_start_env;
12271 PL_op = proto_perl->Iop;
12274 PL_Xpv = (XPV*)NULL;
12275 my_perl->Ina = proto_perl->Ina;
12277 PL_statbuf = proto_perl->Istatbuf;
12278 PL_statcache = proto_perl->Istatcache;
12279 PL_statgv = gv_dup(proto_perl->Istatgv, param);
12280 PL_statname = sv_dup_inc(proto_perl->Istatname, param);
12282 PL_timesbuf = proto_perl->Itimesbuf;
12285 PL_tainted = proto_perl->Itainted;
12286 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
12287 PL_rs = sv_dup_inc(proto_perl->Irs, param);
12288 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
12289 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
12290 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
12291 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
12292 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
12293 PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
12295 PL_restartop = proto_perl->Irestartop;
12296 PL_in_eval = proto_perl->Iin_eval;
12297 PL_delaymagic = proto_perl->Idelaymagic;
12298 PL_dirty = proto_perl->Idirty;
12299 PL_localizing = proto_perl->Ilocalizing;
12301 PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
12302 PL_hv_fetch_ent_mh = NULL;
12303 PL_modcount = proto_perl->Imodcount;
12304 PL_lastgotoprobe = NULL;
12305 PL_dumpindent = proto_perl->Idumpindent;
12307 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
12308 PL_sortstash = hv_dup(proto_perl->Isortstash, param);
12309 PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
12310 PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
12311 PL_efloatbuf = NULL; /* reinits on demand */
12312 PL_efloatsize = 0; /* reinits on demand */
12316 PL_screamfirst = NULL;
12317 PL_screamnext = NULL;
12318 PL_maxscream = -1; /* reinits on demand */
12319 PL_lastscream = NULL;
12322 PL_regdummy = proto_perl->Iregdummy;
12323 PL_colorset = 0; /* reinits PL_colors[] */
12324 /*PL_colors[6] = {0,0,0,0,0,0};*/
12328 /* Pluggable optimizer */
12329 PL_peepp = proto_perl->Ipeepp;
12331 PL_stashcache = newHV();
12333 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
12334 proto_perl->Iwatchaddr);
12335 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
12336 if (PL_debug && PL_watchaddr) {
12337 PerlIO_printf(Perl_debug_log,
12338 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
12339 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
12340 PTR2UV(PL_watchok));
12343 PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
12345 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12346 ptr_table_free(PL_ptr_table);
12347 PL_ptr_table = NULL;
12350 /* Call the ->CLONE method, if it exists, for each of the stashes
12351 identified by sv_dup() above.
12353 while(av_len(param->stashes) != -1) {
12354 HV* const stash = MUTABLE_HV(av_shift(param->stashes));
12355 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12356 if (cloner && GvCV(cloner)) {
12361 mXPUSHs(newSVhek(HvNAME_HEK(stash)));
12363 call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
12369 SvREFCNT_dec(param->stashes);
12371 /* orphaned? eg threads->new inside BEGIN or use */
12372 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12373 SvREFCNT_inc_simple_void(PL_compcv);
12374 SAVEFREESV(PL_compcv);
12380 #endif /* USE_ITHREADS */
12383 =head1 Unicode Support
12385 =for apidoc sv_recode_to_utf8
12387 The encoding is assumed to be an Encode object, on entry the PV
12388 of the sv is assumed to be octets in that encoding, and the sv
12389 will be converted into Unicode (and UTF-8).
12391 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12392 is not a reference, nothing is done to the sv. If the encoding is not
12393 an C<Encode::XS> Encoding object, bad things will happen.
12394 (See F<lib/encoding.pm> and L<Encode>).
12396 The PV of the sv is returned.
12401 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12405 PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
12407 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12421 Passing sv_yes is wrong - it needs to be or'ed set of constants
12422 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12423 remove converted chars from source.
12425 Both will default the value - let them.
12427 XPUSHs(&PL_sv_yes);
12430 call_method("decode", G_SCALAR);
12434 s = SvPV_const(uni, len);
12435 if (s != SvPVX_const(sv)) {
12436 SvGROW(sv, len + 1);
12437 Move(s, SvPVX(sv), len + 1, char);
12438 SvCUR_set(sv, len);
12445 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12449 =for apidoc sv_cat_decode
12451 The encoding is assumed to be an Encode object, the PV of the ssv is
12452 assumed to be octets in that encoding and decoding the input starts
12453 from the position which (PV + *offset) pointed to. The dsv will be
12454 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12455 when the string tstr appears in decoding output or the input ends on
12456 the PV of the ssv. The value which the offset points will be modified
12457 to the last input position on the ssv.
12459 Returns TRUE if the terminator was found, else returns FALSE.
12464 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12465 SV *ssv, int *offset, char *tstr, int tlen)
12470 PERL_ARGS_ASSERT_SV_CAT_DECODE;
12472 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12483 offsv = newSViv(*offset);
12485 mXPUSHp(tstr, tlen);
12487 call_method("cat_decode", G_SCALAR);
12489 ret = SvTRUE(TOPs);
12490 *offset = SvIV(offsv);
12496 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12501 /* ---------------------------------------------------------------------
12503 * support functions for report_uninit()
12506 /* the maxiumum size of array or hash where we will scan looking
12507 * for the undefined element that triggered the warning */
12509 #define FUV_MAX_SEARCH_SIZE 1000
12511 /* Look for an entry in the hash whose value has the same SV as val;
12512 * If so, return a mortal copy of the key. */
12515 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
12518 register HE **array;
12521 PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
12523 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
12524 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
12527 array = HvARRAY(hv);
12529 for (i=HvMAX(hv); i>0; i--) {
12530 register HE *entry;
12531 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
12532 if (HeVAL(entry) != val)
12534 if ( HeVAL(entry) == &PL_sv_undef ||
12535 HeVAL(entry) == &PL_sv_placeholder)
12539 if (HeKLEN(entry) == HEf_SVKEY)
12540 return sv_mortalcopy(HeKEY_sv(entry));
12541 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
12547 /* Look for an entry in the array whose value has the same SV as val;
12548 * If so, return the index, otherwise return -1. */
12551 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
12555 PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
12557 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
12558 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
12561 if (val != &PL_sv_undef) {
12562 SV ** const svp = AvARRAY(av);
12565 for (i=AvFILLp(av); i>=0; i--)
12572 /* S_varname(): return the name of a variable, optionally with a subscript.
12573 * If gv is non-zero, use the name of that global, along with gvtype (one
12574 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
12575 * targ. Depending on the value of the subscript_type flag, return:
12578 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
12579 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
12580 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
12581 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
12584 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
12585 const SV *const keyname, I32 aindex, int subscript_type)
12588 SV * const name = sv_newmortal();
12591 buffer[0] = gvtype;
12594 /* as gv_fullname4(), but add literal '^' for $^FOO names */
12596 gv_fullname4(name, gv, buffer, 0);
12598 if ((unsigned int)SvPVX(name)[1] <= 26) {
12600 buffer[1] = SvPVX(name)[1] + 'A' - 1;
12602 /* Swap the 1 unprintable control character for the 2 byte pretty
12603 version - ie substr($name, 1, 1) = $buffer; */
12604 sv_insert(name, 1, 1, buffer, 2);
12608 CV * const cv = find_runcv(NULL);
12612 if (!cv || !CvPADLIST(cv))
12614 av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
12615 sv = *av_fetch(av, targ, FALSE);
12616 sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
12619 if (subscript_type == FUV_SUBSCRIPT_HASH) {
12620 SV * const sv = newSV(0);
12621 *SvPVX(name) = '$';
12622 Perl_sv_catpvf(aTHX_ name, "{%s}",
12623 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
12626 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
12627 *SvPVX(name) = '$';
12628 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
12630 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
12631 /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
12632 Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
12640 =for apidoc find_uninit_var
12642 Find the name of the undefined variable (if any) that caused the operator o
12643 to issue a "Use of uninitialized value" warning.
12644 If match is true, only return a name if it's value matches uninit_sv.
12645 So roughly speaking, if a unary operator (such as OP_COS) generates a
12646 warning, then following the direct child of the op may yield an
12647 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
12648 other hand, with OP_ADD there are two branches to follow, so we only print
12649 the variable name if we get an exact match.
12651 The name is returned as a mortal SV.
12653 Assumes that PL_op is the op that originally triggered the error, and that
12654 PL_comppad/PL_curpad points to the currently executing pad.
12660 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
12666 const OP *o, *o2, *kid;
12668 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
12669 uninit_sv == &PL_sv_placeholder)))
12672 switch (obase->op_type) {
12679 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
12680 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
12683 int subscript_type = FUV_SUBSCRIPT_WITHIN;
12685 if (pad) { /* @lex, %lex */
12686 sv = PAD_SVl(obase->op_targ);
12690 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
12691 /* @global, %global */
12692 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
12695 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
12697 else /* @{expr}, %{expr} */
12698 return find_uninit_var(cUNOPx(obase)->op_first,
12702 /* attempt to find a match within the aggregate */
12704 keysv = find_hash_subscript((const HV*)sv, uninit_sv);
12706 subscript_type = FUV_SUBSCRIPT_HASH;
12709 index = find_array_subscript((const AV *)sv, uninit_sv);
12711 subscript_type = FUV_SUBSCRIPT_ARRAY;
12714 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
12717 return varname(gv, hash ? '%' : '@', obase->op_targ,
12718 keysv, index, subscript_type);
12722 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
12724 return varname(NULL, '$', obase->op_targ,
12725 NULL, 0, FUV_SUBSCRIPT_NONE);
12728 gv = cGVOPx_gv(obase);
12729 if (!gv || (match && GvSV(gv) != uninit_sv))
12731 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
12734 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
12737 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
12738 if (!av || SvRMAGICAL(av))
12740 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12741 if (!svp || *svp != uninit_sv)
12744 return varname(NULL, '$', obase->op_targ,
12745 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12748 gv = cGVOPx_gv(obase);
12753 AV *const av = GvAV(gv);
12754 if (!av || SvRMAGICAL(av))
12756 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12757 if (!svp || *svp != uninit_sv)
12760 return varname(gv, '$', 0,
12761 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12766 o = cUNOPx(obase)->op_first;
12767 if (!o || o->op_type != OP_NULL ||
12768 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
12770 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
12774 if (PL_op == obase)
12775 /* $a[uninit_expr] or $h{uninit_expr} */
12776 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
12779 o = cBINOPx(obase)->op_first;
12780 kid = cBINOPx(obase)->op_last;
12782 /* get the av or hv, and optionally the gv */
12784 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
12785 sv = PAD_SV(o->op_targ);
12787 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
12788 && cUNOPo->op_first->op_type == OP_GV)
12790 gv = cGVOPx_gv(cUNOPo->op_first);
12794 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
12799 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
12800 /* index is constant */
12804 if (obase->op_type == OP_HELEM) {
12805 HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
12806 if (!he || HeVAL(he) != uninit_sv)
12810 SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
12811 if (!svp || *svp != uninit_sv)
12815 if (obase->op_type == OP_HELEM)
12816 return varname(gv, '%', o->op_targ,
12817 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
12819 return varname(gv, '@', o->op_targ, NULL,
12820 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
12823 /* index is an expression;
12824 * attempt to find a match within the aggregate */
12825 if (obase->op_type == OP_HELEM) {
12826 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
12828 return varname(gv, '%', o->op_targ,
12829 keysv, 0, FUV_SUBSCRIPT_HASH);
12833 = find_array_subscript((const AV *)sv, uninit_sv);
12835 return varname(gv, '@', o->op_targ,
12836 NULL, index, FUV_SUBSCRIPT_ARRAY);
12841 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
12843 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
12848 /* only examine RHS */
12849 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
12852 o = cUNOPx(obase)->op_first;
12853 if (o->op_type == OP_PUSHMARK)
12856 if (!o->op_sibling) {
12857 /* one-arg version of open is highly magical */
12859 if (o->op_type == OP_GV) { /* open FOO; */
12861 if (match && GvSV(gv) != uninit_sv)
12863 return varname(gv, '$', 0,
12864 NULL, 0, FUV_SUBSCRIPT_NONE);
12866 /* other possibilities not handled are:
12867 * open $x; or open my $x; should return '${*$x}'
12868 * open expr; should return '$'.expr ideally
12874 /* ops where $_ may be an implicit arg */
12878 if ( !(obase->op_flags & OPf_STACKED)) {
12879 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
12880 ? PAD_SVl(obase->op_targ)
12883 sv = sv_newmortal();
12884 sv_setpvs(sv, "$_");
12893 match = 1; /* print etc can return undef on defined args */
12894 /* skip filehandle as it can't produce 'undef' warning */
12895 o = cUNOPx(obase)->op_first;
12896 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
12897 o = o->op_sibling->op_sibling;
12901 case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
12903 case OP_CUSTOM: /* XS or custom code could trigger random warnings */
12905 /* the following ops are capable of returning PL_sv_undef even for
12906 * defined arg(s) */
12925 case OP_GETPEERNAME:
12973 case OP_SMARTMATCH:
12982 /* XXX tmp hack: these two may call an XS sub, and currently
12983 XS subs don't have a SUB entry on the context stack, so CV and
12984 pad determination goes wrong, and BAD things happen. So, just
12985 don't try to determine the value under those circumstances.
12986 Need a better fix at dome point. DAPM 11/2007 */
12991 /* def-ness of rval pos() is independent of the def-ness of its arg */
12992 if ( !(obase->op_flags & OPf_MOD))
12997 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
12998 return newSVpvs_flags("${$/}", SVs_TEMP);
13003 if (!(obase->op_flags & OPf_KIDS))
13005 o = cUNOPx(obase)->op_first;
13011 /* if all except one arg are constant, or have no side-effects,
13012 * or are optimized away, then it's unambiguous */
13014 for (kid=o; kid; kid = kid->op_sibling) {
13016 const OPCODE type = kid->op_type;
13017 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
13018 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
13019 || (type == OP_PUSHMARK)
13023 if (o2) { /* more than one found */
13030 return find_uninit_var(o2, uninit_sv, match);
13032 /* scan all args */
13034 sv = find_uninit_var(o, uninit_sv, 1);
13046 =for apidoc report_uninit
13048 Print appropriate "Use of uninitialized variable" warning
13054 Perl_report_uninit(pTHX_ const SV *uninit_sv)
13058 SV* varname = NULL;
13060 varname = find_uninit_var(PL_op, uninit_sv,0);
13062 sv_insert(varname, 0, 0, " ", 1);
13064 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13065 varname ? SvPV_nolen_const(varname) : "",
13066 " in ", OP_DESC(PL_op));
13069 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13075 * c-indentation-style: bsd
13076 * c-basic-offset: 4
13077 * indent-tabs-mode: t
13080 * ex: set ts=8 sts=4 sw=4 noet: