3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'I wonder what the Entish is for "yes" and "no",' he thought.
15 * [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
21 * This file contains the code that creates, manipulates and destroys
22 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
23 * structure of an SV, so their creation and destruction is handled
24 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
25 * level functions (eg. substr, split, join) for each of the types are
37 /* Missing proto on LynxOS */
38 char *gconvert(double, int, int, char *);
41 #ifdef PERL_UTF8_CACHE_ASSERT
42 /* if adding more checks watch out for the following tests:
43 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
44 * lib/utf8.t lib/Unicode/Collate/t/index.t
47 # define ASSERT_UTF8_CACHE(cache) \
48 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
49 assert((cache)[2] <= (cache)[3]); \
50 assert((cache)[3] <= (cache)[1]);} \
53 # define ASSERT_UTF8_CACHE(cache) NOOP
56 #ifdef PERL_OLD_COPY_ON_WRITE
57 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
58 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
59 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
63 /* ============================================================================
65 =head1 Allocation and deallocation of SVs.
67 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
68 sv, av, hv...) contains type and reference count information, and for
69 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
70 contains fields specific to each type. Some types store all they need
71 in the head, so don't have a body.
73 In all but the most memory-paranoid configuations (ex: PURIFY), heads
74 and bodies are allocated out of arenas, which by default are
75 approximately 4K chunks of memory parcelled up into N heads or bodies.
76 Sv-bodies are allocated by their sv-type, guaranteeing size
77 consistency needed to allocate safely from arrays.
79 For SV-heads, the first slot in each arena is reserved, and holds a
80 link to the next arena, some flags, and a note of the number of slots.
81 Snaked through each arena chain is a linked list of free items; when
82 this becomes empty, an extra arena is allocated and divided up into N
83 items which are threaded into the free list.
85 SV-bodies are similar, but they use arena-sets by default, which
86 separate the link and info from the arena itself, and reclaim the 1st
87 slot in the arena. SV-bodies are further described later.
89 The following global variables are associated with arenas:
91 PL_sv_arenaroot pointer to list of SV arenas
92 PL_sv_root pointer to list of free SV structures
94 PL_body_arenas head of linked-list of body arenas
95 PL_body_roots[] array of pointers to list of free bodies of svtype
96 arrays are indexed by the svtype needed
98 A few special SV heads are not allocated from an arena, but are
99 instead directly created in the interpreter structure, eg PL_sv_undef.
100 The size of arenas can be changed from the default by setting
101 PERL_ARENA_SIZE appropriately at compile time.
103 The SV arena serves the secondary purpose of allowing still-live SVs
104 to be located and destroyed during final cleanup.
106 At the lowest level, the macros new_SV() and del_SV() grab and free
107 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
108 to return the SV to the free list with error checking.) new_SV() calls
109 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
110 SVs in the free list have their SvTYPE field set to all ones.
112 At the time of very final cleanup, sv_free_arenas() is called from
113 perl_destruct() to physically free all the arenas allocated since the
114 start of the interpreter.
116 The function visit() scans the SV arenas list, and calls a specified
117 function for each SV it finds which is still live - ie which has an SvTYPE
118 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
119 following functions (specified as [function that calls visit()] / [function
120 called by visit() for each SV]):
122 sv_report_used() / do_report_used()
123 dump all remaining SVs (debugging aid)
125 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
126 Attempt to free all objects pointed to by RVs,
127 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
128 try to do the same for all objects indirectly
129 referenced by typeglobs too. Called once from
130 perl_destruct(), prior to calling sv_clean_all()
133 sv_clean_all() / do_clean_all()
134 SvREFCNT_dec(sv) each remaining SV, possibly
135 triggering an sv_free(). It also sets the
136 SVf_BREAK flag on the SV to indicate that the
137 refcnt has been artificially lowered, and thus
138 stopping sv_free() from giving spurious warnings
139 about SVs which unexpectedly have a refcnt
140 of zero. called repeatedly from perl_destruct()
141 until there are no SVs left.
143 =head2 Arena allocator API Summary
145 Private API to rest of sv.c
149 new_XIV(), del_XIV(),
150 new_XNV(), del_XNV(),
155 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
159 ============================================================================ */
162 * "A time to plant, and a time to uproot what was planted..."
166 Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size)
172 PERL_ARGS_ASSERT_OFFER_NICE_CHUNK;
174 new_chunk = (void *)(chunk);
175 new_chunk_size = (chunk_size);
176 if (new_chunk_size > PL_nice_chunk_size) {
177 Safefree(PL_nice_chunk);
178 PL_nice_chunk = (char *) new_chunk;
179 PL_nice_chunk_size = new_chunk_size;
186 # define MEM_LOG_NEW_SV(sv, file, line, func) \
187 Perl_mem_log_new_sv(sv, file, line, func)
188 # define MEM_LOG_DEL_SV(sv, file, line, func) \
189 Perl_mem_log_del_sv(sv, file, line, func)
191 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
192 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
195 #ifdef DEBUG_LEAKING_SCALARS
196 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
197 # define DEBUG_SV_SERIAL(sv) \
198 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
199 PTR2UV(sv), (long)(sv)->sv_debug_serial))
201 # define FREE_SV_DEBUG_FILE(sv)
202 # define DEBUG_SV_SERIAL(sv) NOOP
206 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
207 # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
208 /* Whilst I'd love to do this, it seems that things like to check on
210 # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
212 # define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
213 PoisonNew(&SvREFCNT(sv), 1, U32)
215 # define SvARENA_CHAIN(sv) SvANY(sv)
216 # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
217 # define POSION_SV_HEAD(sv)
220 /* Mark an SV head as unused, and add to free list.
222 * If SVf_BREAK is set, skip adding it to the free list, as this SV had
223 * its refcount artificially decremented during global destruction, so
224 * there may be dangling pointers to it. The last thing we want in that
225 * case is for it to be reused. */
227 #define plant_SV(p) \
229 const U32 old_flags = SvFLAGS(p); \
230 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
231 DEBUG_SV_SERIAL(p); \
232 FREE_SV_DEBUG_FILE(p); \
234 SvFLAGS(p) = SVTYPEMASK; \
235 if (!(old_flags & SVf_BREAK)) { \
236 SvARENA_CHAIN_SET(p, PL_sv_root); \
242 #define uproot_SV(p) \
245 PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
250 /* make some more SVs by adding another arena */
259 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
260 PL_nice_chunk = NULL;
261 PL_nice_chunk_size = 0;
264 char *chunk; /* must use New here to match call to */
265 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
266 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
272 /* new_SV(): return a new, empty SV head */
274 #ifdef DEBUG_LEAKING_SCALARS
275 /* provide a real function for a debugger to play with */
277 S_new_SV(pTHX_ const char *file, int line, const char *func)
284 sv = S_more_sv(aTHX);
288 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
289 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
295 sv->sv_debug_inpad = 0;
296 sv->sv_debug_cloned = 0;
297 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
299 sv->sv_debug_serial = PL_sv_serial++;
301 MEM_LOG_NEW_SV(sv, file, line, func);
302 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
303 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
307 # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
315 (p) = S_more_sv(aTHX); \
319 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
324 /* del_SV(): return an empty SV head to the free list */
337 S_del_sv(pTHX_ SV *p)
341 PERL_ARGS_ASSERT_DEL_SV;
346 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
347 const SV * const sv = sva + 1;
348 const SV * const svend = &sva[SvREFCNT(sva)];
349 if (p >= sv && p < svend) {
355 if (ckWARN_d(WARN_INTERNAL))
356 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
357 "Attempt to free non-arena SV: 0x%"UVxf
358 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
365 #else /* ! DEBUGGING */
367 #define del_SV(p) plant_SV(p)
369 #endif /* DEBUGGING */
373 =head1 SV Manipulation Functions
375 =for apidoc sv_add_arena
377 Given a chunk of memory, link it to the head of the list of arenas,
378 and split it into a list of free SVs.
384 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
387 SV *const sva = MUTABLE_SV(ptr);
391 PERL_ARGS_ASSERT_SV_ADD_ARENA;
393 /* The first SV in an arena isn't an SV. */
394 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
395 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
396 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
398 PL_sv_arenaroot = sva;
399 PL_sv_root = sva + 1;
401 svend = &sva[SvREFCNT(sva) - 1];
404 SvARENA_CHAIN_SET(sv, (sv + 1));
408 /* Must always set typemask because it's always checked in on cleanup
409 when the arenas are walked looking for objects. */
410 SvFLAGS(sv) = SVTYPEMASK;
413 SvARENA_CHAIN_SET(sv, 0);
417 SvFLAGS(sv) = SVTYPEMASK;
420 /* visit(): call the named function for each non-free SV in the arenas
421 * whose flags field matches the flags/mask args. */
424 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
430 PERL_ARGS_ASSERT_VISIT;
432 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
433 register const SV * const svend = &sva[SvREFCNT(sva)];
435 for (sv = sva + 1; sv < svend; ++sv) {
436 if (SvTYPE(sv) != SVTYPEMASK
437 && (sv->sv_flags & mask) == flags
450 /* called by sv_report_used() for each live SV */
453 do_report_used(pTHX_ SV *const sv)
455 if (SvTYPE(sv) != SVTYPEMASK) {
456 PerlIO_printf(Perl_debug_log, "****\n");
463 =for apidoc sv_report_used
465 Dump the contents of all SVs not yet freed. (Debugging aid).
471 Perl_sv_report_used(pTHX)
474 visit(do_report_used, 0, 0);
480 /* called by sv_clean_objs() for each live SV */
483 do_clean_objs(pTHX_ SV *const ref)
488 SV * const target = SvRV(ref);
489 if (SvOBJECT(target)) {
490 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
491 if (SvWEAKREF(ref)) {
492 sv_del_backref(target, ref);
498 SvREFCNT_dec(target);
503 /* XXX Might want to check arrays, etc. */
506 /* called by sv_clean_objs() for each live SV */
508 #ifndef DISABLE_DESTRUCTOR_KLUDGE
510 do_clean_named_objs(pTHX_ SV *const sv)
513 assert(SvTYPE(sv) == SVt_PVGV);
514 assert(isGV_with_GP(sv));
517 #ifdef PERL_DONT_CREATE_GVSV
520 SvOBJECT(GvSV(sv))) ||
521 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
522 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
523 /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */
524 (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) ||
525 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
527 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
528 SvFLAGS(sv) |= SVf_BREAK;
536 =for apidoc sv_clean_objs
538 Attempt to destroy all objects not yet freed
544 Perl_sv_clean_objs(pTHX)
547 PL_in_clean_objs = TRUE;
548 visit(do_clean_objs, SVf_ROK, SVf_ROK);
549 #ifndef DISABLE_DESTRUCTOR_KLUDGE
550 /* some barnacles may yet remain, clinging to typeglobs */
551 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
553 PL_in_clean_objs = FALSE;
556 /* called by sv_clean_all() for each live SV */
559 do_clean_all(pTHX_ SV *const sv)
562 if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
563 /* don't clean pid table and strtab */
566 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
567 SvFLAGS(sv) |= SVf_BREAK;
572 =for apidoc sv_clean_all
574 Decrement the refcnt of each remaining SV, possibly triggering a
575 cleanup. This function may have to be called multiple times to free
576 SVs which are in complex self-referential hierarchies.
582 Perl_sv_clean_all(pTHX)
586 PL_in_clean_all = TRUE;
587 cleaned = visit(do_clean_all, 0,0);
588 PL_in_clean_all = FALSE;
593 ARENASETS: a meta-arena implementation which separates arena-info
594 into struct arena_set, which contains an array of struct
595 arena_descs, each holding info for a single arena. By separating
596 the meta-info from the arena, we recover the 1st slot, formerly
597 borrowed for list management. The arena_set is about the size of an
598 arena, avoiding the needless malloc overhead of a naive linked-list.
600 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
601 memory in the last arena-set (1/2 on average). In trade, we get
602 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
603 smaller types). The recovery of the wasted space allows use of
604 small arenas for large, rare body types, by changing array* fields
605 in body_details_by_type[] below.
608 char *arena; /* the raw storage, allocated aligned */
609 size_t size; /* its size ~4k typ */
610 U32 misc; /* type, and in future other things. */
615 /* Get the maximum number of elements in set[] such that struct arena_set
616 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
617 therefore likely to be 1 aligned memory page. */
619 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
620 - 2 * sizeof(int)) / sizeof (struct arena_desc))
623 struct arena_set* next;
624 unsigned int set_size; /* ie ARENAS_PER_SET */
625 unsigned int curr; /* index of next available arena-desc */
626 struct arena_desc set[ARENAS_PER_SET];
630 =for apidoc sv_free_arenas
632 Deallocate the memory used by all arenas. Note that all the individual SV
633 heads and bodies within the arenas must already have been freed.
638 Perl_sv_free_arenas(pTHX)
645 /* Free arenas here, but be careful about fake ones. (We assume
646 contiguity of the fake ones with the corresponding real ones.) */
648 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
649 svanext = MUTABLE_SV(SvANY(sva));
650 while (svanext && SvFAKE(svanext))
651 svanext = MUTABLE_SV(SvANY(svanext));
658 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
661 struct arena_set *current = aroot;
664 assert(aroot->set[i].arena);
665 Safefree(aroot->set[i].arena);
673 i = PERL_ARENA_ROOTS_SIZE;
675 PL_body_roots[i] = 0;
677 Safefree(PL_nice_chunk);
678 PL_nice_chunk = NULL;
679 PL_nice_chunk_size = 0;
685 Here are mid-level routines that manage the allocation of bodies out
686 of the various arenas. There are 5 kinds of arenas:
688 1. SV-head arenas, which are discussed and handled above
689 2. regular body arenas
690 3. arenas for reduced-size bodies
692 5. pte arenas (thread related)
694 Arena types 2 & 3 are chained by body-type off an array of
695 arena-root pointers, which is indexed by svtype. Some of the
696 larger/less used body types are malloced singly, since a large
697 unused block of them is wasteful. Also, several svtypes dont have
698 bodies; the data fits into the sv-head itself. The arena-root
699 pointer thus has a few unused root-pointers (which may be hijacked
700 later for arena types 4,5)
702 3 differs from 2 as an optimization; some body types have several
703 unused fields in the front of the structure (which are kept in-place
704 for consistency). These bodies can be allocated in smaller chunks,
705 because the leading fields arent accessed. Pointers to such bodies
706 are decremented to point at the unused 'ghost' memory, knowing that
707 the pointers are used with offsets to the real memory.
709 HE, HEK arenas are managed separately, with separate code, but may
710 be merge-able later..
712 PTE arenas are not sv-bodies, but they share these mid-level
713 mechanics, so are considered here. The new mid-level mechanics rely
714 on the sv_type of the body being allocated, so we just reserve one
715 of the unused body-slots for PTEs, then use it in those (2) PTE
716 contexts below (line ~10k)
719 /* get_arena(size): this creates custom-sized arenas
720 TBD: export properly for hv.c: S_more_he().
723 Perl_get_arena(pTHX_ const size_t arena_size, const U32 misc)
726 struct arena_desc* adesc;
727 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
730 /* shouldnt need this
731 if (!arena_size) arena_size = PERL_ARENA_SIZE;
734 /* may need new arena-set to hold new arena */
735 if (!aroot || aroot->curr >= aroot->set_size) {
736 struct arena_set *newroot;
737 Newxz(newroot, 1, struct arena_set);
738 newroot->set_size = ARENAS_PER_SET;
739 newroot->next = aroot;
741 PL_body_arenas = (void *) newroot;
742 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
745 /* ok, now have arena-set with at least 1 empty/available arena-desc */
746 curr = aroot->curr++;
747 adesc = &(aroot->set[curr]);
748 assert(!adesc->arena);
750 Newx(adesc->arena, arena_size, char);
751 adesc->size = arena_size;
753 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
754 curr, (void*)adesc->arena, (UV)arena_size));
760 /* return a thing to the free list */
762 #define del_body(thing, root) \
764 void ** const thing_copy = (void **)thing;\
765 *thing_copy = *root; \
766 *root = (void*)thing_copy; \
771 =head1 SV-Body Allocation
773 Allocation of SV-bodies is similar to SV-heads, differing as follows;
774 the allocation mechanism is used for many body types, so is somewhat
775 more complicated, it uses arena-sets, and has no need for still-live
778 At the outermost level, (new|del)_X*V macros return bodies of the
779 appropriate type. These macros call either (new|del)_body_type or
780 (new|del)_body_allocated macro pairs, depending on specifics of the
781 type. Most body types use the former pair, the latter pair is used to
782 allocate body types with "ghost fields".
784 "ghost fields" are fields that are unused in certain types, and
785 consequently dont need to actually exist. They are declared because
786 they're part of a "base type", which allows use of functions as
787 methods. The simplest examples are AVs and HVs, 2 aggregate types
788 which don't use the fields which support SCALAR semantics.
790 For these types, the arenas are carved up into *_allocated size
791 chunks, we thus avoid wasted memory for those unaccessed members.
792 When bodies are allocated, we adjust the pointer back in memory by the
793 size of the bit not allocated, so it's as if we allocated the full
794 structure. (But things will all go boom if you write to the part that
795 is "not there", because you'll be overwriting the last members of the
796 preceding structure in memory.)
798 We calculate the correction using the STRUCT_OFFSET macro. For
799 example, if xpv_allocated is the same structure as XPV then the two
800 OFFSETs sum to zero, and the pointer is unchanged. If the allocated
801 structure is smaller (no initial NV actually allocated) then the net
802 effect is to subtract the size of the NV from the pointer, to return a
803 new pointer as if an initial NV were actually allocated.
805 This is the same trick as was used for NV and IV bodies. Ironically it
806 doesn't need to be used for NV bodies any more, because NV is now at
807 the start of the structure. IV bodies don't need it either, because
808 they are no longer allocated.
810 In turn, the new_body_* allocators call S_new_body(), which invokes
811 new_body_inline macro, which takes a lock, and takes a body off the
812 linked list at PL_body_roots[sv_type], calling S_more_bodies() if
813 necessary to refresh an empty list. Then the lock is released, and
814 the body is returned.
816 S_more_bodies calls get_arena(), and carves it up into an array of N
817 bodies, which it strings into a linked list. It looks up arena-size
818 and body-size from the body_details table described below, thus
819 supporting the multiple body-types.
821 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
822 the (new|del)_X*V macros are mapped directly to malloc/free.
828 For each sv-type, struct body_details bodies_by_type[] carries
829 parameters which control these aspects of SV handling:
831 Arena_size determines whether arenas are used for this body type, and if
832 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
833 zero, forcing individual mallocs and frees.
835 Body_size determines how big a body is, and therefore how many fit into
836 each arena. Offset carries the body-pointer adjustment needed for
837 *_allocated body types, and is used in *_allocated macros.
839 But its main purpose is to parameterize info needed in
840 Perl_sv_upgrade(). The info here dramatically simplifies the function
841 vs the implementation in 5.8.7, making it table-driven. All fields
842 are used for this, except for arena_size.
844 For the sv-types that have no bodies, arenas are not used, so those
845 PL_body_roots[sv_type] are unused, and can be overloaded. In
846 something of a special case, SVt_NULL is borrowed for HE arenas;
847 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
848 bodies_by_type[SVt_NULL] slot is not used, as the table is not
851 PTEs also use arenas, but are never seen in Perl_sv_upgrade. Nonetheless,
852 they get their own slot in bodies_by_type[PTE_SVSLOT =SVt_IV], so they can
853 just use the same allocation semantics. At first, PTEs were also
854 overloaded to a non-body sv-type, but this yielded hard-to-find malloc
855 bugs, so was simplified by claiming a new slot. This choice has no
856 consequence at this time.
860 struct body_details {
861 U8 body_size; /* Size to allocate */
862 U8 copy; /* Size of structure to copy (may be shorter) */
864 unsigned int type : 4; /* We have space for a sanity check. */
865 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
866 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
867 unsigned int arena : 1; /* Allocated from an arena */
868 size_t arena_size; /* Size of arena to allocate */
876 /* With -DPURFIY we allocate everything directly, and don't use arenas.
877 This seems a rather elegant way to simplify some of the code below. */
878 #define HASARENA FALSE
880 #define HASARENA TRUE
882 #define NOARENA FALSE
884 /* Size the arenas to exactly fit a given number of bodies. A count
885 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
886 simplifying the default. If count > 0, the arena is sized to fit
887 only that many bodies, allowing arenas to be used for large, rare
888 bodies (XPVFM, XPVIO) without undue waste. The arena size is
889 limited by PERL_ARENA_SIZE, so we can safely oversize the
892 #define FIT_ARENA0(body_size) \
893 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
894 #define FIT_ARENAn(count,body_size) \
895 ( count * body_size <= PERL_ARENA_SIZE) \
896 ? count * body_size \
897 : FIT_ARENA0 (body_size)
898 #define FIT_ARENA(count,body_size) \
900 ? FIT_ARENAn (count, body_size) \
901 : FIT_ARENA0 (body_size)
903 /* A macro to work out the offset needed to subtract from a pointer to (say)
910 to make its members accessible via a pointer to (say)
920 #define relative_STRUCT_OFFSET(longer, shorter, member) \
921 (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
923 /* Calculate the length to copy. Specifically work out the length less any
924 final padding the compiler needed to add. See the comment in sv_upgrade
925 for why copying the padding proved to be a bug. */
927 #define copy_length(type, last_member) \
928 STRUCT_OFFSET(type, last_member) \
929 + sizeof (((type*)SvANY((const SV *)0))->last_member)
931 static const struct body_details bodies_by_type[] = {
932 { sizeof(HE), 0, 0, SVt_NULL,
933 FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
935 /* The bind placeholder pretends to be an RV for now.
936 Also it's marked as "can't upgrade" to stop anyone using it before it's
938 { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
940 /* IVs are in the head, so the allocation size is 0.
941 However, the slot is overloaded for PTEs. */
942 { sizeof(struct ptr_tbl_ent), /* This is used for PTEs. */
943 sizeof(IV), /* This is used to copy out the IV body. */
944 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
945 NOARENA /* IVS don't need an arena */,
946 /* But PTEs need to know the size of their arena */
947 FIT_ARENA(0, sizeof(struct ptr_tbl_ent))
950 /* 8 bytes on most ILP32 with IEEE doubles */
951 { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA,
952 FIT_ARENA(0, sizeof(NV)) },
954 /* 8 bytes on most ILP32 with IEEE doubles */
955 { sizeof(xpv_allocated),
956 copy_length(XPV, xpv_len)
957 - relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
958 + relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
959 SVt_PV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpv_allocated)) },
962 { sizeof(xpviv_allocated),
963 copy_length(XPVIV, xiv_u)
964 - relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
965 + relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
966 SVt_PVIV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpviv_allocated)) },
969 { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV,
970 HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
973 { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
974 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
977 { sizeof(struct regexp_allocated), sizeof(struct regexp_allocated),
978 + relative_STRUCT_OFFSET(struct regexp_allocated, regexp, xpv_cur),
979 SVt_REGEXP, FALSE, NONV, HASARENA,
980 FIT_ARENA(0, sizeof(struct regexp_allocated))
984 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
985 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
988 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
989 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
991 { sizeof(xpvav_allocated),
992 copy_length(XPVAV, xmg_stash)
993 - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
994 + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
995 SVt_PVAV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
997 { sizeof(xpvhv_allocated),
998 copy_length(XPVHV, xmg_stash)
999 - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
1000 + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
1001 SVt_PVHV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
1004 { sizeof(xpvcv_allocated), sizeof(xpvcv_allocated),
1005 + relative_STRUCT_OFFSET(xpvcv_allocated, XPVCV, xpv_cur),
1006 SVt_PVCV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvcv_allocated)) },
1008 { sizeof(xpvfm_allocated), sizeof(xpvfm_allocated),
1009 + relative_STRUCT_OFFSET(xpvfm_allocated, XPVFM, xpv_cur),
1010 SVt_PVFM, TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) },
1012 /* XPVIO is 84 bytes, fits 48x */
1013 { sizeof(xpvio_allocated), sizeof(xpvio_allocated),
1014 + relative_STRUCT_OFFSET(xpvio_allocated, XPVIO, xpv_cur),
1015 SVt_PVIO, TRUE, NONV, HASARENA, FIT_ARENA(24, sizeof(xpvio_allocated)) },
1018 #define new_body_type(sv_type) \
1019 (void *)((char *)S_new_body(aTHX_ sv_type))
1021 #define del_body_type(p, sv_type) \
1022 del_body(p, &PL_body_roots[sv_type])
1025 #define new_body_allocated(sv_type) \
1026 (void *)((char *)S_new_body(aTHX_ sv_type) \
1027 - bodies_by_type[sv_type].offset)
1029 #define del_body_allocated(p, sv_type) \
1030 del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
1033 #define my_safemalloc(s) (void*)safemalloc(s)
1034 #define my_safecalloc(s) (void*)safecalloc(s, 1)
1035 #define my_safefree(p) safefree((char*)p)
1039 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1040 #define del_XNV(p) my_safefree(p)
1042 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1043 #define del_XPVNV(p) my_safefree(p)
1045 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1046 #define del_XPVAV(p) my_safefree(p)
1048 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1049 #define del_XPVHV(p) my_safefree(p)
1051 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1052 #define del_XPVMG(p) my_safefree(p)
1054 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1055 #define del_XPVGV(p) my_safefree(p)
1059 #define new_XNV() new_body_type(SVt_NV)
1060 #define del_XNV(p) del_body_type(p, SVt_NV)
1062 #define new_XPVNV() new_body_type(SVt_PVNV)
1063 #define del_XPVNV(p) del_body_type(p, SVt_PVNV)
1065 #define new_XPVAV() new_body_allocated(SVt_PVAV)
1066 #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
1068 #define new_XPVHV() new_body_allocated(SVt_PVHV)
1069 #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
1071 #define new_XPVMG() new_body_type(SVt_PVMG)
1072 #define del_XPVMG(p) del_body_type(p, SVt_PVMG)
1074 #define new_XPVGV() new_body_type(SVt_PVGV)
1075 #define del_XPVGV(p) del_body_type(p, SVt_PVGV)
1079 /* no arena for you! */
1081 #define new_NOARENA(details) \
1082 my_safemalloc((details)->body_size + (details)->offset)
1083 #define new_NOARENAZ(details) \
1084 my_safecalloc((details)->body_size + (details)->offset)
1087 S_more_bodies (pTHX_ const svtype sv_type)
1090 void ** const root = &PL_body_roots[sv_type];
1091 const struct body_details * const bdp = &bodies_by_type[sv_type];
1092 const size_t body_size = bdp->body_size;
1095 const size_t arena_size = Perl_malloc_good_size(bdp->arena_size);
1096 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1097 static bool done_sanity_check;
1099 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1100 * variables like done_sanity_check. */
1101 if (!done_sanity_check) {
1102 unsigned int i = SVt_LAST;
1104 done_sanity_check = TRUE;
1107 assert (bodies_by_type[i].type == i);
1111 assert(bdp->arena_size);
1113 start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type);
1115 end = start + arena_size - 2 * body_size;
1117 /* computed count doesnt reflect the 1st slot reservation */
1118 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1119 DEBUG_m(PerlIO_printf(Perl_debug_log,
1120 "arena %p end %p arena-size %d (from %d) type %d "
1122 (void*)start, (void*)end, (int)arena_size,
1123 (int)bdp->arena_size, sv_type, (int)body_size,
1124 (int)arena_size / (int)body_size));
1126 DEBUG_m(PerlIO_printf(Perl_debug_log,
1127 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1128 (void*)start, (void*)end,
1129 (int)bdp->arena_size, sv_type, (int)body_size,
1130 (int)bdp->arena_size / (int)body_size));
1132 *root = (void *)start;
1134 while (start <= end) {
1135 char * const next = start + body_size;
1136 *(void**) start = (void *)next;
1139 *(void **)start = 0;
1144 /* grab a new thing from the free list, allocating more if necessary.
1145 The inline version is used for speed in hot routines, and the
1146 function using it serves the rest (unless PURIFY).
1148 #define new_body_inline(xpv, sv_type) \
1150 void ** const r3wt = &PL_body_roots[sv_type]; \
1151 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1152 ? *((void **)(r3wt)) : more_bodies(sv_type)); \
1153 *(r3wt) = *(void**)(xpv); \
1159 S_new_body(pTHX_ const svtype sv_type)
1163 new_body_inline(xpv, sv_type);
1169 static const struct body_details fake_rv =
1170 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1173 =for apidoc sv_upgrade
1175 Upgrade an SV to a more complex form. Generally adds a new body type to the
1176 SV, then copies across as much information as possible from the old body.
1177 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1183 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1188 const svtype old_type = SvTYPE(sv);
1189 const struct body_details *new_type_details;
1190 const struct body_details *old_type_details
1191 = bodies_by_type + old_type;
1192 SV *referant = NULL;
1194 PERL_ARGS_ASSERT_SV_UPGRADE;
1196 if (new_type != SVt_PV && SvIsCOW(sv)) {
1197 sv_force_normal_flags(sv, 0);
1200 if (old_type == new_type)
1203 old_body = SvANY(sv);
1205 /* Copying structures onto other structures that have been neatly zeroed
1206 has a subtle gotcha. Consider XPVMG
1208 +------+------+------+------+------+-------+-------+
1209 | NV | CUR | LEN | IV | MAGIC | STASH |
1210 +------+------+------+------+------+-------+-------+
1211 0 4 8 12 16 20 24 28
1213 where NVs are aligned to 8 bytes, so that sizeof that structure is
1214 actually 32 bytes long, with 4 bytes of padding at the end:
1216 +------+------+------+------+------+-------+-------+------+
1217 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1218 +------+------+------+------+------+-------+-------+------+
1219 0 4 8 12 16 20 24 28 32
1221 so what happens if you allocate memory for this structure:
1223 +------+------+------+------+------+-------+-------+------+------+...
1224 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1225 +------+------+------+------+------+-------+-------+------+------+...
1226 0 4 8 12 16 20 24 28 32 36
1228 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1229 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1230 started out as zero once, but it's quite possible that it isn't. So now,
1231 rather than a nicely zeroed GP, you have it pointing somewhere random.
1234 (In fact, GP ends up pointing at a previous GP structure, because the
1235 principle cause of the padding in XPVMG getting garbage is a copy of
1236 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1237 this happens to be moot because XPVGV has been re-ordered, with GP
1238 no longer after STASH)
1240 So we are careful and work out the size of used parts of all the
1248 referant = SvRV(sv);
1249 old_type_details = &fake_rv;
1250 if (new_type == SVt_NV)
1251 new_type = SVt_PVNV;
1253 if (new_type < SVt_PVIV) {
1254 new_type = (new_type == SVt_NV)
1255 ? SVt_PVNV : SVt_PVIV;
1260 if (new_type < SVt_PVNV) {
1261 new_type = SVt_PVNV;
1265 assert(new_type > SVt_PV);
1266 assert(SVt_IV < SVt_PV);
1267 assert(SVt_NV < SVt_PV);
1274 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1275 there's no way that it can be safely upgraded, because perl.c
1276 expects to Safefree(SvANY(PL_mess_sv)) */
1277 assert(sv != PL_mess_sv);
1278 /* This flag bit is used to mean other things in other scalar types.
1279 Given that it only has meaning inside the pad, it shouldn't be set
1280 on anything that can get upgraded. */
1281 assert(!SvPAD_TYPED(sv));
1284 if (old_type_details->cant_upgrade)
1285 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1286 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1289 if (old_type > new_type)
1290 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1291 (int)old_type, (int)new_type);
1293 new_type_details = bodies_by_type + new_type;
1295 SvFLAGS(sv) &= ~SVTYPEMASK;
1296 SvFLAGS(sv) |= new_type;
1298 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1299 the return statements above will have triggered. */
1300 assert (new_type != SVt_NULL);
1303 assert(old_type == SVt_NULL);
1304 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1308 assert(old_type == SVt_NULL);
1309 SvANY(sv) = new_XNV();
1314 assert(new_type_details->body_size);
1317 assert(new_type_details->arena);
1318 assert(new_type_details->arena_size);
1319 /* This points to the start of the allocated area. */
1320 new_body_inline(new_body, new_type);
1321 Zero(new_body, new_type_details->body_size, char);
1322 new_body = ((char *)new_body) - new_type_details->offset;
1324 /* We always allocated the full length item with PURIFY. To do this
1325 we fake things so that arena is false for all 16 types.. */
1326 new_body = new_NOARENAZ(new_type_details);
1328 SvANY(sv) = new_body;
1329 if (new_type == SVt_PVAV) {
1333 if (old_type_details->body_size) {
1336 /* It will have been zeroed when the new body was allocated.
1337 Lets not write to it, in case it confuses a write-back
1343 #ifndef NODEFAULT_SHAREKEYS
1344 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1346 HvMAX(sv) = 7; /* (start with 8 buckets) */
1347 if (old_type_details->body_size) {
1350 /* It will have been zeroed when the new body was allocated.
1351 Lets not write to it, in case it confuses a write-back
1356 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1357 The target created by newSVrv also is, and it can have magic.
1358 However, it never has SvPVX set.
1360 if (old_type == SVt_IV) {
1362 } else if (old_type >= SVt_PV) {
1363 assert(SvPVX_const(sv) == 0);
1366 if (old_type >= SVt_PVMG) {
1367 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1368 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1370 sv->sv_u.svu_array = NULL; /* or svu_hash */
1376 /* XXX Is this still needed? Was it ever needed? Surely as there is
1377 no route from NV to PVIV, NOK can never be true */
1378 assert(!SvNOKp(sv));
1390 assert(new_type_details->body_size);
1391 /* We always allocated the full length item with PURIFY. To do this
1392 we fake things so that arena is false for all 16 types.. */
1393 if(new_type_details->arena) {
1394 /* This points to the start of the allocated area. */
1395 new_body_inline(new_body, new_type);
1396 Zero(new_body, new_type_details->body_size, char);
1397 new_body = ((char *)new_body) - new_type_details->offset;
1399 new_body = new_NOARENAZ(new_type_details);
1401 SvANY(sv) = new_body;
1403 if (old_type_details->copy) {
1404 /* There is now the potential for an upgrade from something without
1405 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1406 int offset = old_type_details->offset;
1407 int length = old_type_details->copy;
1409 if (new_type_details->offset > old_type_details->offset) {
1410 const int difference
1411 = new_type_details->offset - old_type_details->offset;
1412 offset += difference;
1413 length -= difference;
1415 assert (length >= 0);
1417 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1421 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1422 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1423 * correct 0.0 for us. Otherwise, if the old body didn't have an
1424 * NV slot, but the new one does, then we need to initialise the
1425 * freshly created NV slot with whatever the correct bit pattern is
1427 if (old_type_details->zero_nv && !new_type_details->zero_nv
1428 && !isGV_with_GP(sv))
1432 if (new_type == SVt_PVIO)
1433 IoPAGE_LEN(sv) = 60;
1434 if (old_type < SVt_PV) {
1435 /* referant will be NULL unless the old type was SVt_IV emulating
1437 sv->sv_u.svu_rv = referant;
1441 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1442 (unsigned long)new_type);
1445 if (old_type_details->arena) {
1446 /* If there was an old body, then we need to free it.
1447 Note that there is an assumption that all bodies of types that
1448 can be upgraded came from arenas. Only the more complex non-
1449 upgradable types are allowed to be directly malloc()ed. */
1451 my_safefree(old_body);
1453 del_body((void*)((char*)old_body + old_type_details->offset),
1454 &PL_body_roots[old_type]);
1460 =for apidoc sv_backoff
1462 Remove any string offset. You should normally use the C<SvOOK_off> macro
1469 Perl_sv_backoff(pTHX_ register SV *const sv)
1472 const char * const s = SvPVX_const(sv);
1474 PERL_ARGS_ASSERT_SV_BACKOFF;
1475 PERL_UNUSED_CONTEXT;
1478 assert(SvTYPE(sv) != SVt_PVHV);
1479 assert(SvTYPE(sv) != SVt_PVAV);
1481 SvOOK_offset(sv, delta);
1483 SvLEN_set(sv, SvLEN(sv) + delta);
1484 SvPV_set(sv, SvPVX(sv) - delta);
1485 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1486 SvFLAGS(sv) &= ~SVf_OOK;
1493 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1494 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1495 Use the C<SvGROW> wrapper instead.
1501 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1505 PERL_ARGS_ASSERT_SV_GROW;
1507 if (PL_madskills && newlen >= 0x100000) {
1508 PerlIO_printf(Perl_debug_log,
1509 "Allocation too large: %"UVxf"\n", (UV)newlen);
1511 #ifdef HAS_64K_LIMIT
1512 if (newlen >= 0x10000) {
1513 PerlIO_printf(Perl_debug_log,
1514 "Allocation too large: %"UVxf"\n", (UV)newlen);
1517 #endif /* HAS_64K_LIMIT */
1520 if (SvTYPE(sv) < SVt_PV) {
1521 sv_upgrade(sv, SVt_PV);
1522 s = SvPVX_mutable(sv);
1524 else if (SvOOK(sv)) { /* pv is offset? */
1526 s = SvPVX_mutable(sv);
1527 if (newlen > SvLEN(sv))
1528 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1529 #ifdef HAS_64K_LIMIT
1530 if (newlen >= 0x10000)
1535 s = SvPVX_mutable(sv);
1537 if (newlen > SvLEN(sv)) { /* need more room? */
1538 #ifndef Perl_safesysmalloc_size
1539 newlen = PERL_STRLEN_ROUNDUP(newlen);
1541 if (SvLEN(sv) && s) {
1542 s = (char*)saferealloc(s, newlen);
1545 s = (char*)safemalloc(newlen);
1546 if (SvPVX_const(sv) && SvCUR(sv)) {
1547 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1551 #ifdef Perl_safesysmalloc_size
1552 /* Do this here, do it once, do it right, and then we will never get
1553 called back into sv_grow() unless there really is some growing
1555 SvLEN_set(sv, Perl_safesysmalloc_size(s));
1557 SvLEN_set(sv, newlen);
1564 =for apidoc sv_setiv
1566 Copies an integer into the given SV, upgrading first if necessary.
1567 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1573 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1577 PERL_ARGS_ASSERT_SV_SETIV;
1579 SV_CHECK_THINKFIRST_COW_DROP(sv);
1580 switch (SvTYPE(sv)) {
1583 sv_upgrade(sv, SVt_IV);
1586 sv_upgrade(sv, SVt_PVIV);
1590 if (!isGV_with_GP(sv))
1597 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1601 (void)SvIOK_only(sv); /* validate number */
1607 =for apidoc sv_setiv_mg
1609 Like C<sv_setiv>, but also handles 'set' magic.
1615 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1617 PERL_ARGS_ASSERT_SV_SETIV_MG;
1624 =for apidoc sv_setuv
1626 Copies an unsigned integer into the given SV, upgrading first if necessary.
1627 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1633 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1635 PERL_ARGS_ASSERT_SV_SETUV;
1637 /* With these two if statements:
1638 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1641 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1643 If you wish to remove them, please benchmark to see what the effect is
1645 if (u <= (UV)IV_MAX) {
1646 sv_setiv(sv, (IV)u);
1655 =for apidoc sv_setuv_mg
1657 Like C<sv_setuv>, but also handles 'set' magic.
1663 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1665 PERL_ARGS_ASSERT_SV_SETUV_MG;
1672 =for apidoc sv_setnv
1674 Copies a double into the given SV, upgrading first if necessary.
1675 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1681 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1685 PERL_ARGS_ASSERT_SV_SETNV;
1687 SV_CHECK_THINKFIRST_COW_DROP(sv);
1688 switch (SvTYPE(sv)) {
1691 sv_upgrade(sv, SVt_NV);
1695 sv_upgrade(sv, SVt_PVNV);
1699 if (!isGV_with_GP(sv))
1706 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1711 (void)SvNOK_only(sv); /* validate number */
1716 =for apidoc sv_setnv_mg
1718 Like C<sv_setnv>, but also handles 'set' magic.
1724 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1726 PERL_ARGS_ASSERT_SV_SETNV_MG;
1732 /* Print an "isn't numeric" warning, using a cleaned-up,
1733 * printable version of the offending string
1737 S_not_a_number(pTHX_ SV *const sv)
1744 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1747 dsv = newSVpvs_flags("", SVs_TEMP);
1748 pv = sv_uni_display(dsv, sv, 10, 0);
1751 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1752 /* each *s can expand to 4 chars + "...\0",
1753 i.e. need room for 8 chars */
1755 const char *s = SvPVX_const(sv);
1756 const char * const end = s + SvCUR(sv);
1757 for ( ; s < end && d < limit; s++ ) {
1759 if (ch & 128 && !isPRINT_LC(ch)) {
1768 else if (ch == '\r') {
1772 else if (ch == '\f') {
1776 else if (ch == '\\') {
1780 else if (ch == '\0') {
1784 else if (isPRINT_LC(ch))
1801 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1802 "Argument \"%s\" isn't numeric in %s", pv,
1805 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1806 "Argument \"%s\" isn't numeric", pv);
1810 =for apidoc looks_like_number
1812 Test if the content of an SV looks like a number (or is a number).
1813 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1814 non-numeric warning), even if your atof() doesn't grok them.
1820 Perl_looks_like_number(pTHX_ SV *const sv)
1822 register const char *sbegin;
1825 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1828 sbegin = SvPVX_const(sv);
1831 else if (SvPOKp(sv))
1832 sbegin = SvPV_const(sv, len);
1834 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1835 return grok_number(sbegin, len, NULL);
1839 S_glob_2number(pTHX_ GV * const gv)
1841 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1842 SV *const buffer = sv_newmortal();
1844 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1846 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1849 gv_efullname3(buffer, gv, "*");
1850 SvFLAGS(gv) |= wasfake;
1852 /* We know that all GVs stringify to something that is not-a-number,
1853 so no need to test that. */
1854 if (ckWARN(WARN_NUMERIC))
1855 not_a_number(buffer);
1856 /* We just want something true to return, so that S_sv_2iuv_common
1857 can tail call us and return true. */
1862 S_glob_2pv(pTHX_ GV * const gv, STRLEN * const len)
1864 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1865 SV *const buffer = sv_newmortal();
1867 PERL_ARGS_ASSERT_GLOB_2PV;
1869 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1872 gv_efullname3(buffer, gv, "*");
1873 SvFLAGS(gv) |= wasfake;
1875 assert(SvPOK(buffer));
1877 *len = SvCUR(buffer);
1879 return SvPVX(buffer);
1882 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1883 until proven guilty, assume that things are not that bad... */
1888 As 64 bit platforms often have an NV that doesn't preserve all bits of
1889 an IV (an assumption perl has been based on to date) it becomes necessary
1890 to remove the assumption that the NV always carries enough precision to
1891 recreate the IV whenever needed, and that the NV is the canonical form.
1892 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1893 precision as a side effect of conversion (which would lead to insanity
1894 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1895 1) to distinguish between IV/UV/NV slots that have cached a valid
1896 conversion where precision was lost and IV/UV/NV slots that have a
1897 valid conversion which has lost no precision
1898 2) to ensure that if a numeric conversion to one form is requested that
1899 would lose precision, the precise conversion (or differently
1900 imprecise conversion) is also performed and cached, to prevent
1901 requests for different numeric formats on the same SV causing
1902 lossy conversion chains. (lossless conversion chains are perfectly
1907 SvIOKp is true if the IV slot contains a valid value
1908 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1909 SvNOKp is true if the NV slot contains a valid value
1910 SvNOK is true only if the NV value is accurate
1913 while converting from PV to NV, check to see if converting that NV to an
1914 IV(or UV) would lose accuracy over a direct conversion from PV to
1915 IV(or UV). If it would, cache both conversions, return NV, but mark
1916 SV as IOK NOKp (ie not NOK).
1918 While converting from PV to IV, check to see if converting that IV to an
1919 NV would lose accuracy over a direct conversion from PV to NV. If it
1920 would, cache both conversions, flag similarly.
1922 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1923 correctly because if IV & NV were set NV *always* overruled.
1924 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1925 changes - now IV and NV together means that the two are interchangeable:
1926 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1928 The benefit of this is that operations such as pp_add know that if
1929 SvIOK is true for both left and right operands, then integer addition
1930 can be used instead of floating point (for cases where the result won't
1931 overflow). Before, floating point was always used, which could lead to
1932 loss of precision compared with integer addition.
1934 * making IV and NV equal status should make maths accurate on 64 bit
1936 * may speed up maths somewhat if pp_add and friends start to use
1937 integers when possible instead of fp. (Hopefully the overhead in
1938 looking for SvIOK and checking for overflow will not outweigh the
1939 fp to integer speedup)
1940 * will slow down integer operations (callers of SvIV) on "inaccurate"
1941 values, as the change from SvIOK to SvIOKp will cause a call into
1942 sv_2iv each time rather than a macro access direct to the IV slot
1943 * should speed up number->string conversion on integers as IV is
1944 favoured when IV and NV are equally accurate
1946 ####################################################################
1947 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1948 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1949 On the other hand, SvUOK is true iff UV.
1950 ####################################################################
1952 Your mileage will vary depending your CPU's relative fp to integer
1956 #ifndef NV_PRESERVES_UV
1957 # define IS_NUMBER_UNDERFLOW_IV 1
1958 # define IS_NUMBER_UNDERFLOW_UV 2
1959 # define IS_NUMBER_IV_AND_UV 2
1960 # define IS_NUMBER_OVERFLOW_IV 4
1961 # define IS_NUMBER_OVERFLOW_UV 5
1963 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1965 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1967 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1975 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1977 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));
1978 if (SvNVX(sv) < (NV)IV_MIN) {
1979 (void)SvIOKp_on(sv);
1981 SvIV_set(sv, IV_MIN);
1982 return IS_NUMBER_UNDERFLOW_IV;
1984 if (SvNVX(sv) > (NV)UV_MAX) {
1985 (void)SvIOKp_on(sv);
1988 SvUV_set(sv, UV_MAX);
1989 return IS_NUMBER_OVERFLOW_UV;
1991 (void)SvIOKp_on(sv);
1993 /* Can't use strtol etc to convert this string. (See truth table in
1995 if (SvNVX(sv) <= (UV)IV_MAX) {
1996 SvIV_set(sv, I_V(SvNVX(sv)));
1997 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1998 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2000 /* Integer is imprecise. NOK, IOKp */
2002 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2005 SvUV_set(sv, U_V(SvNVX(sv)));
2006 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2007 if (SvUVX(sv) == UV_MAX) {
2008 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2009 possibly be preserved by NV. Hence, it must be overflow.
2011 return IS_NUMBER_OVERFLOW_UV;
2013 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2015 /* Integer is imprecise. NOK, IOKp */
2017 return IS_NUMBER_OVERFLOW_IV;
2019 #endif /* !NV_PRESERVES_UV*/
2022 S_sv_2iuv_common(pTHX_ SV *const sv)
2026 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2029 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2030 * without also getting a cached IV/UV from it at the same time
2031 * (ie PV->NV conversion should detect loss of accuracy and cache
2032 * IV or UV at same time to avoid this. */
2033 /* IV-over-UV optimisation - choose to cache IV if possible */
2035 if (SvTYPE(sv) == SVt_NV)
2036 sv_upgrade(sv, SVt_PVNV);
2038 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2039 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2040 certainly cast into the IV range at IV_MAX, whereas the correct
2041 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2043 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2044 if (Perl_isnan(SvNVX(sv))) {
2050 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2051 SvIV_set(sv, I_V(SvNVX(sv)));
2052 if (SvNVX(sv) == (NV) SvIVX(sv)
2053 #ifndef NV_PRESERVES_UV
2054 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2055 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2056 /* Don't flag it as "accurately an integer" if the number
2057 came from a (by definition imprecise) NV operation, and
2058 we're outside the range of NV integer precision */
2062 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2064 /* scalar has trailing garbage, eg "42a" */
2066 DEBUG_c(PerlIO_printf(Perl_debug_log,
2067 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2073 /* IV not precise. No need to convert from PV, as NV
2074 conversion would already have cached IV if it detected
2075 that PV->IV would be better than PV->NV->IV
2076 flags already correct - don't set public IOK. */
2077 DEBUG_c(PerlIO_printf(Perl_debug_log,
2078 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2083 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2084 but the cast (NV)IV_MIN rounds to a the value less (more
2085 negative) than IV_MIN which happens to be equal to SvNVX ??
2086 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2087 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2088 (NV)UVX == NVX are both true, but the values differ. :-(
2089 Hopefully for 2s complement IV_MIN is something like
2090 0x8000000000000000 which will be exact. NWC */
2093 SvUV_set(sv, U_V(SvNVX(sv)));
2095 (SvNVX(sv) == (NV) SvUVX(sv))
2096 #ifndef NV_PRESERVES_UV
2097 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2098 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2099 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2100 /* Don't flag it as "accurately an integer" if the number
2101 came from a (by definition imprecise) NV operation, and
2102 we're outside the range of NV integer precision */
2108 DEBUG_c(PerlIO_printf(Perl_debug_log,
2109 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2115 else if (SvPOKp(sv) && SvLEN(sv)) {
2117 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2118 /* We want to avoid a possible problem when we cache an IV/ a UV which
2119 may be later translated to an NV, and the resulting NV is not
2120 the same as the direct translation of the initial string
2121 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2122 be careful to ensure that the value with the .456 is around if the
2123 NV value is requested in the future).
2125 This means that if we cache such an IV/a UV, we need to cache the
2126 NV as well. Moreover, we trade speed for space, and do not
2127 cache the NV if we are sure it's not needed.
2130 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2131 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2132 == IS_NUMBER_IN_UV) {
2133 /* It's definitely an integer, only upgrade to PVIV */
2134 if (SvTYPE(sv) < SVt_PVIV)
2135 sv_upgrade(sv, SVt_PVIV);
2137 } else if (SvTYPE(sv) < SVt_PVNV)
2138 sv_upgrade(sv, SVt_PVNV);
2140 /* If NVs preserve UVs then we only use the UV value if we know that
2141 we aren't going to call atof() below. If NVs don't preserve UVs
2142 then the value returned may have more precision than atof() will
2143 return, even though value isn't perfectly accurate. */
2144 if ((numtype & (IS_NUMBER_IN_UV
2145 #ifdef NV_PRESERVES_UV
2148 )) == IS_NUMBER_IN_UV) {
2149 /* This won't turn off the public IOK flag if it was set above */
2150 (void)SvIOKp_on(sv);
2152 if (!(numtype & IS_NUMBER_NEG)) {
2154 if (value <= (UV)IV_MAX) {
2155 SvIV_set(sv, (IV)value);
2157 /* it didn't overflow, and it was positive. */
2158 SvUV_set(sv, value);
2162 /* 2s complement assumption */
2163 if (value <= (UV)IV_MIN) {
2164 SvIV_set(sv, -(IV)value);
2166 /* Too negative for an IV. This is a double upgrade, but
2167 I'm assuming it will be rare. */
2168 if (SvTYPE(sv) < SVt_PVNV)
2169 sv_upgrade(sv, SVt_PVNV);
2173 SvNV_set(sv, -(NV)value);
2174 SvIV_set(sv, IV_MIN);
2178 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2179 will be in the previous block to set the IV slot, and the next
2180 block to set the NV slot. So no else here. */
2182 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2183 != IS_NUMBER_IN_UV) {
2184 /* It wasn't an (integer that doesn't overflow the UV). */
2185 SvNV_set(sv, Atof(SvPVX_const(sv)));
2187 if (! numtype && ckWARN(WARN_NUMERIC))
2190 #if defined(USE_LONG_DOUBLE)
2191 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2192 PTR2UV(sv), SvNVX(sv)));
2194 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2195 PTR2UV(sv), SvNVX(sv)));
2198 #ifdef NV_PRESERVES_UV
2199 (void)SvIOKp_on(sv);
2201 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2202 SvIV_set(sv, I_V(SvNVX(sv)));
2203 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2206 NOOP; /* Integer is imprecise. NOK, IOKp */
2208 /* UV will not work better than IV */
2210 if (SvNVX(sv) > (NV)UV_MAX) {
2212 /* Integer is inaccurate. NOK, IOKp, is UV */
2213 SvUV_set(sv, UV_MAX);
2215 SvUV_set(sv, U_V(SvNVX(sv)));
2216 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2217 NV preservse UV so can do correct comparison. */
2218 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2221 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
2226 #else /* NV_PRESERVES_UV */
2227 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2228 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2229 /* The IV/UV slot will have been set from value returned by
2230 grok_number above. The NV slot has just been set using
2233 assert (SvIOKp(sv));
2235 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2236 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2237 /* Small enough to preserve all bits. */
2238 (void)SvIOKp_on(sv);
2240 SvIV_set(sv, I_V(SvNVX(sv)));
2241 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2243 /* Assumption: first non-preserved integer is < IV_MAX,
2244 this NV is in the preserved range, therefore: */
2245 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2247 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);
2251 0 0 already failed to read UV.
2252 0 1 already failed to read UV.
2253 1 0 you won't get here in this case. IV/UV
2254 slot set, public IOK, Atof() unneeded.
2255 1 1 already read UV.
2256 so there's no point in sv_2iuv_non_preserve() attempting
2257 to use atol, strtol, strtoul etc. */
2259 sv_2iuv_non_preserve (sv, numtype);
2261 sv_2iuv_non_preserve (sv);
2265 #endif /* NV_PRESERVES_UV */
2266 /* It might be more code efficient to go through the entire logic above
2267 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2268 gets complex and potentially buggy, so more programmer efficient
2269 to do it this way, by turning off the public flags: */
2271 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2275 if (isGV_with_GP(sv))
2276 return glob_2number(MUTABLE_GV(sv));
2278 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2279 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2282 if (SvTYPE(sv) < SVt_IV)
2283 /* Typically the caller expects that sv_any is not NULL now. */
2284 sv_upgrade(sv, SVt_IV);
2285 /* Return 0 from the caller. */
2292 =for apidoc sv_2iv_flags
2294 Return the integer value of an SV, doing any necessary string
2295 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2296 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2302 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2307 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2308 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2309 cache IVs just in case. In practice it seems that they never
2310 actually anywhere accessible by user Perl code, let alone get used
2311 in anything other than a string context. */
2312 if (flags & SV_GMAGIC)
2317 return I_V(SvNVX(sv));
2319 if (SvPOKp(sv) && SvLEN(sv)) {
2322 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2324 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2325 == IS_NUMBER_IN_UV) {
2326 /* It's definitely an integer */
2327 if (numtype & IS_NUMBER_NEG) {
2328 if (value < (UV)IV_MIN)
2331 if (value < (UV)IV_MAX)
2336 if (ckWARN(WARN_NUMERIC))
2339 return I_V(Atof(SvPVX_const(sv)));
2344 assert(SvTYPE(sv) >= SVt_PVMG);
2345 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2346 } else if (SvTHINKFIRST(sv)) {
2350 SV * const tmpstr=AMG_CALLun(sv,numer);
2351 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2352 return SvIV(tmpstr);
2355 return PTR2IV(SvRV(sv));
2358 sv_force_normal_flags(sv, 0);
2360 if (SvREADONLY(sv) && !SvOK(sv)) {
2361 if (ckWARN(WARN_UNINITIALIZED))
2367 if (S_sv_2iuv_common(aTHX_ sv))
2370 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2371 PTR2UV(sv),SvIVX(sv)));
2372 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2376 =for apidoc sv_2uv_flags
2378 Return the unsigned integer value of an SV, doing any necessary string
2379 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2380 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2386 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2391 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2392 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2393 cache IVs just in case. */
2394 if (flags & SV_GMAGIC)
2399 return U_V(SvNVX(sv));
2400 if (SvPOKp(sv) && SvLEN(sv)) {
2403 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2405 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2406 == IS_NUMBER_IN_UV) {
2407 /* It's definitely an integer */
2408 if (!(numtype & IS_NUMBER_NEG))
2412 if (ckWARN(WARN_NUMERIC))
2415 return U_V(Atof(SvPVX_const(sv)));
2420 assert(SvTYPE(sv) >= SVt_PVMG);
2421 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2422 } else if (SvTHINKFIRST(sv)) {
2426 SV *const tmpstr = AMG_CALLun(sv,numer);
2427 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2428 return SvUV(tmpstr);
2431 return PTR2UV(SvRV(sv));
2434 sv_force_normal_flags(sv, 0);
2436 if (SvREADONLY(sv) && !SvOK(sv)) {
2437 if (ckWARN(WARN_UNINITIALIZED))
2443 if (S_sv_2iuv_common(aTHX_ sv))
2447 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2448 PTR2UV(sv),SvUVX(sv)));
2449 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2455 Return the num value of an SV, doing any necessary string or integer
2456 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2463 Perl_sv_2nv(pTHX_ register SV *const sv)
2468 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2469 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2470 cache IVs just in case. */
2474 if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2475 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2476 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2478 return Atof(SvPVX_const(sv));
2482 return (NV)SvUVX(sv);
2484 return (NV)SvIVX(sv);
2489 assert(SvTYPE(sv) >= SVt_PVMG);
2490 /* This falls through to the report_uninit near the end of the
2492 } else if (SvTHINKFIRST(sv)) {
2496 SV *const tmpstr = AMG_CALLun(sv,numer);
2497 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2498 return SvNV(tmpstr);
2501 return PTR2NV(SvRV(sv));
2504 sv_force_normal_flags(sv, 0);
2506 if (SvREADONLY(sv) && !SvOK(sv)) {
2507 if (ckWARN(WARN_UNINITIALIZED))
2512 if (SvTYPE(sv) < SVt_NV) {
2513 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2514 sv_upgrade(sv, SVt_NV);
2515 #ifdef USE_LONG_DOUBLE
2517 STORE_NUMERIC_LOCAL_SET_STANDARD();
2518 PerlIO_printf(Perl_debug_log,
2519 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2520 PTR2UV(sv), SvNVX(sv));
2521 RESTORE_NUMERIC_LOCAL();
2525 STORE_NUMERIC_LOCAL_SET_STANDARD();
2526 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2527 PTR2UV(sv), SvNVX(sv));
2528 RESTORE_NUMERIC_LOCAL();
2532 else if (SvTYPE(sv) < SVt_PVNV)
2533 sv_upgrade(sv, SVt_PVNV);
2538 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2539 #ifdef NV_PRESERVES_UV
2545 /* Only set the public NV OK flag if this NV preserves the IV */
2546 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2548 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2549 : (SvIVX(sv) == I_V(SvNVX(sv))))
2555 else if (SvPOKp(sv) && SvLEN(sv)) {
2557 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2558 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2560 #ifdef NV_PRESERVES_UV
2561 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2562 == IS_NUMBER_IN_UV) {
2563 /* It's definitely an integer */
2564 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2566 SvNV_set(sv, Atof(SvPVX_const(sv)));
2572 SvNV_set(sv, Atof(SvPVX_const(sv)));
2573 /* Only set the public NV OK flag if this NV preserves the value in
2574 the PV at least as well as an IV/UV would.
2575 Not sure how to do this 100% reliably. */
2576 /* if that shift count is out of range then Configure's test is
2577 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2579 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2580 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2581 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2582 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2583 /* Can't use strtol etc to convert this string, so don't try.
2584 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2587 /* value has been set. It may not be precise. */
2588 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2589 /* 2s complement assumption for (UV)IV_MIN */
2590 SvNOK_on(sv); /* Integer is too negative. */
2595 if (numtype & IS_NUMBER_NEG) {
2596 SvIV_set(sv, -(IV)value);
2597 } else if (value <= (UV)IV_MAX) {
2598 SvIV_set(sv, (IV)value);
2600 SvUV_set(sv, value);
2604 if (numtype & IS_NUMBER_NOT_INT) {
2605 /* I believe that even if the original PV had decimals,
2606 they are lost beyond the limit of the FP precision.
2607 However, neither is canonical, so both only get p
2608 flags. NWC, 2000/11/25 */
2609 /* Both already have p flags, so do nothing */
2611 const NV nv = SvNVX(sv);
2612 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2613 if (SvIVX(sv) == I_V(nv)) {
2616 /* It had no "." so it must be integer. */
2620 /* between IV_MAX and NV(UV_MAX).
2621 Could be slightly > UV_MAX */
2623 if (numtype & IS_NUMBER_NOT_INT) {
2624 /* UV and NV both imprecise. */
2626 const UV nv_as_uv = U_V(nv);
2628 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2637 /* It might be more code efficient to go through the entire logic above
2638 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2639 gets complex and potentially buggy, so more programmer efficient
2640 to do it this way, by turning off the public flags: */
2642 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2643 #endif /* NV_PRESERVES_UV */
2646 if (isGV_with_GP(sv)) {
2647 glob_2number(MUTABLE_GV(sv));
2651 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2653 assert (SvTYPE(sv) >= SVt_NV);
2654 /* Typically the caller expects that sv_any is not NULL now. */
2655 /* XXX Ilya implies that this is a bug in callers that assume this
2656 and ideally should be fixed. */
2659 #if defined(USE_LONG_DOUBLE)
2661 STORE_NUMERIC_LOCAL_SET_STANDARD();
2662 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2663 PTR2UV(sv), SvNVX(sv));
2664 RESTORE_NUMERIC_LOCAL();
2668 STORE_NUMERIC_LOCAL_SET_STANDARD();
2669 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2670 PTR2UV(sv), SvNVX(sv));
2671 RESTORE_NUMERIC_LOCAL();
2680 Return an SV with the numeric value of the source SV, doing any necessary
2681 reference or overload conversion. You must use the C<SvNUM(sv)> macro to
2682 access this function.
2688 Perl_sv_2num(pTHX_ register SV *const sv)
2690 PERL_ARGS_ASSERT_SV_2NUM;
2695 SV * const tmpsv = AMG_CALLun(sv,numer);
2696 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2697 return sv_2num(tmpsv);
2699 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2702 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2703 * UV as a string towards the end of buf, and return pointers to start and
2706 * We assume that buf is at least TYPE_CHARS(UV) long.
2710 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2712 char *ptr = buf + TYPE_CHARS(UV);
2713 char * const ebuf = ptr;
2716 PERL_ARGS_ASSERT_UIV_2BUF;
2728 *--ptr = '0' + (char)(uv % 10);
2737 =for apidoc sv_2pv_flags
2739 Returns a pointer to the string value of an SV, and sets *lp to its length.
2740 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2742 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2743 usually end up here too.
2749 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2759 if (SvGMAGICAL(sv)) {
2760 if (flags & SV_GMAGIC)
2765 if (flags & SV_MUTABLE_RETURN)
2766 return SvPVX_mutable(sv);
2767 if (flags & SV_CONST_RETURN)
2768 return (char *)SvPVX_const(sv);
2771 if (SvIOKp(sv) || SvNOKp(sv)) {
2772 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2777 ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2778 : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2780 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2787 #ifdef FIXNEGATIVEZERO
2788 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2794 SvUPGRADE(sv, SVt_PV);
2797 s = SvGROW_mutable(sv, len + 1);
2800 return (char*)memcpy(s, tbuf, len + 1);
2806 assert(SvTYPE(sv) >= SVt_PVMG);
2807 /* This falls through to the report_uninit near the end of the
2809 } else if (SvTHINKFIRST(sv)) {
2813 SV *const tmpstr = AMG_CALLun(sv,string);
2814 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2816 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2820 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2821 if (flags & SV_CONST_RETURN) {
2822 pv = (char *) SvPVX_const(tmpstr);
2824 pv = (flags & SV_MUTABLE_RETURN)
2825 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2828 *lp = SvCUR(tmpstr);
2830 pv = sv_2pv_flags(tmpstr, lp, flags);
2843 SV *const referent = SvRV(sv);
2847 retval = buffer = savepvn("NULLREF", len);
2848 } else if (SvTYPE(referent) == SVt_REGEXP) {
2849 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2854 /* If the regex is UTF-8 we want the containing scalar to
2855 have an UTF-8 flag too */
2861 if ((seen_evals = RX_SEEN_EVALS(re)))
2862 PL_reginterp_cnt += seen_evals;
2865 *lp = RX_WRAPLEN(re);
2867 return RX_WRAPPED(re);
2869 const char *const typestr = sv_reftype(referent, 0);
2870 const STRLEN typelen = strlen(typestr);
2871 UV addr = PTR2UV(referent);
2872 const char *stashname = NULL;
2873 STRLEN stashnamelen = 0; /* hush, gcc */
2874 const char *buffer_end;
2876 if (SvOBJECT(referent)) {
2877 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2880 stashname = HEK_KEY(name);
2881 stashnamelen = HEK_LEN(name);
2883 if (HEK_UTF8(name)) {
2889 stashname = "__ANON__";
2892 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2893 + 2 * sizeof(UV) + 2 /* )\0 */;
2895 len = typelen + 3 /* (0x */
2896 + 2 * sizeof(UV) + 2 /* )\0 */;
2899 Newx(buffer, len, char);
2900 buffer_end = retval = buffer + len;
2902 /* Working backwards */
2906 *--retval = PL_hexdigit[addr & 15];
2907 } while (addr >>= 4);
2913 memcpy(retval, typestr, typelen);
2917 retval -= stashnamelen;
2918 memcpy(retval, stashname, stashnamelen);
2920 /* retval may not neccesarily have reached the start of the
2922 assert (retval >= buffer);
2924 len = buffer_end - retval - 1; /* -1 for that \0 */
2932 if (SvREADONLY(sv) && !SvOK(sv)) {
2935 if (flags & SV_UNDEF_RETURNS_NULL)
2937 if (ckWARN(WARN_UNINITIALIZED))
2942 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2943 /* I'm assuming that if both IV and NV are equally valid then
2944 converting the IV is going to be more efficient */
2945 const U32 isUIOK = SvIsUV(sv);
2946 char buf[TYPE_CHARS(UV)];
2950 if (SvTYPE(sv) < SVt_PVIV)
2951 sv_upgrade(sv, SVt_PVIV);
2952 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2954 /* inlined from sv_setpvn */
2955 s = SvGROW_mutable(sv, len + 1);
2956 Move(ptr, s, len, char);
2960 else if (SvNOKp(sv)) {
2962 if (SvTYPE(sv) < SVt_PVNV)
2963 sv_upgrade(sv, SVt_PVNV);
2964 /* The +20 is pure guesswork. Configure test needed. --jhi */
2965 s = SvGROW_mutable(sv, NV_DIG + 20);
2966 /* some Xenix systems wipe out errno here */
2968 if (SvNVX(sv) == 0.0)
2969 my_strlcpy(s, "0", SvLEN(sv));
2973 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2976 #ifdef FIXNEGATIVEZERO
2977 if (*s == '-' && s[1] == '0' && !s[2]) {
2989 if (isGV_with_GP(sv))
2990 return glob_2pv(MUTABLE_GV(sv), lp);
2994 if (flags & SV_UNDEF_RETURNS_NULL)
2996 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2998 if (SvTYPE(sv) < SVt_PV)
2999 /* Typically the caller expects that sv_any is not NULL now. */
3000 sv_upgrade(sv, SVt_PV);
3004 const STRLEN len = s - SvPVX_const(sv);
3010 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3011 PTR2UV(sv),SvPVX_const(sv)));
3012 if (flags & SV_CONST_RETURN)
3013 return (char *)SvPVX_const(sv);
3014 if (flags & SV_MUTABLE_RETURN)
3015 return SvPVX_mutable(sv);
3020 =for apidoc sv_copypv
3022 Copies a stringified representation of the source SV into the
3023 destination SV. Automatically performs any necessary mg_get and
3024 coercion of numeric values into strings. Guaranteed to preserve
3025 UTF8 flag even from overloaded objects. Similar in nature to
3026 sv_2pv[_flags] but operates directly on an SV instead of just the
3027 string. Mostly uses sv_2pv_flags to do its work, except when that
3028 would lose the UTF-8'ness of the PV.
3034 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3037 const char * const s = SvPV_const(ssv,len);
3039 PERL_ARGS_ASSERT_SV_COPYPV;
3041 sv_setpvn(dsv,s,len);
3049 =for apidoc sv_2pvbyte
3051 Return a pointer to the byte-encoded representation of the SV, and set *lp
3052 to its length. May cause the SV to be downgraded from UTF-8 as a
3055 Usually accessed via the C<SvPVbyte> macro.
3061 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3063 PERL_ARGS_ASSERT_SV_2PVBYTE;
3065 sv_utf8_downgrade(sv,0);
3066 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3070 =for apidoc sv_2pvutf8
3072 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3073 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3075 Usually accessed via the C<SvPVutf8> macro.
3081 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3083 PERL_ARGS_ASSERT_SV_2PVUTF8;
3085 sv_utf8_upgrade(sv);
3086 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3091 =for apidoc sv_2bool
3093 This function is only called on magical items, and is only used by
3094 sv_true() or its macro equivalent.
3100 Perl_sv_2bool(pTHX_ register SV *const sv)
3104 PERL_ARGS_ASSERT_SV_2BOOL;
3112 SV * const tmpsv = AMG_CALLun(sv,bool_);
3113 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3114 return (bool)SvTRUE(tmpsv);
3116 return SvRV(sv) != 0;
3119 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3121 (*sv->sv_u.svu_pv > '0' ||
3122 Xpvtmp->xpv_cur > 1 ||
3123 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3130 return SvIVX(sv) != 0;
3133 return SvNVX(sv) != 0.0;
3135 if (isGV_with_GP(sv))
3145 =for apidoc sv_utf8_upgrade
3147 Converts the PV of an SV to its UTF-8-encoded form.
3148 Forces the SV to string form if it is not already.
3149 Will C<mg_get> on C<sv> if appropriate.
3150 Always sets the SvUTF8 flag to avoid future validity checks even
3151 if the whole string is the same in UTF-8 as not.
3152 Returns the number of bytes in the converted string
3154 This is not as a general purpose byte encoding to Unicode interface:
3155 use the Encode extension for that.
3157 =for apidoc sv_utf8_upgrade_nomg
3159 Like sv_utf8_upgrade, but doesn't do magic on C<sv>
3161 =for apidoc sv_utf8_upgrade_flags
3163 Converts the PV of an SV to its UTF-8-encoded form.
3164 Forces the SV to string form if it is not already.
3165 Always sets the SvUTF8 flag to avoid future validity checks even
3166 if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
3167 will C<mg_get> on C<sv> if appropriate, else not.
3168 Returns the number of bytes in the converted string
3169 C<sv_utf8_upgrade> and
3170 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3172 This is not as a general purpose byte encoding to Unicode interface:
3173 use the Encode extension for that.
3177 The grow version is currently not externally documented. It adds a parameter,
3178 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3179 have free after it upon return. This allows the caller to reserve extra space
3180 that it intends to fill, to avoid extra grows.
3182 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3183 which can be used to tell this function to not first check to see if there are
3184 any characters that are different in UTF-8 (variant characters) which would
3185 force it to allocate a new string to sv, but to assume there are. Typically
3186 this flag is used by a routine that has already parsed the string to find that
3187 there are such characters, and passes this information on so that the work
3188 doesn't have to be repeated.
3190 (One might think that the calling routine could pass in the position of the
3191 first such variant, so it wouldn't have to be found again. But that is not the
3192 case, because typically when the caller is likely to use this flag, it won't be
3193 calling this routine unless it finds something that won't fit into a byte.
3194 Otherwise it tries to not upgrade and just use bytes. But some things that
3195 do fit into a byte are variants in utf8, and the caller may not have been
3196 keeping track of these.)
3198 If the routine itself changes the string, it adds a trailing NUL. Such a NUL
3199 isn't guaranteed due to having other routines do the work in some input cases,
3200 or if the input is already flagged as being in utf8.
3202 The speed of this could perhaps be improved for many cases if someone wanted to
3203 write a fast function that counts the number of variant characters in a string,
3204 especially if it could return the position of the first one.
3209 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
3213 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3215 if (sv == &PL_sv_undef)
3219 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3220 (void) sv_2pv_flags(sv,&len, flags);
3222 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3226 (void) SvPV_force(sv,len);
3231 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3236 sv_force_normal_flags(sv, 0);
3239 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3240 sv_recode_to_utf8(sv, PL_encoding);
3241 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3245 if (SvCUR(sv) > 0) { /* Assume Latin-1/EBCDIC */
3246 /* This function could be much more efficient if we
3247 * had a FLAG in SVs to signal if there are any variant
3248 * chars in the PV. Given that there isn't such a flag
3249 * make the loop as fast as possible (although there are certainly ways
3250 * to speed this up, eg. through vectorization) */
3251 U8 * s = (U8 *) SvPVX_const(sv);
3252 U8 * e = (U8 *) SvEND(sv);
3254 STRLEN two_byte_count = 0;
3256 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3258 /* See if really will need to convert to utf8. We mustn't rely on our
3259 * incoming SV being well formed and having a trailing '\0', as certain
3260 * code in pp_formline can send us partially built SVs. */
3264 if (NATIVE_IS_INVARIANT(ch)) continue;
3266 t--; /* t already incremented; re-point to first variant */
3271 /* utf8 conversion not needed because all are invariants. Mark as
3272 * UTF-8 even if no variant - saves scanning loop */
3278 /* Here, the string should be converted to utf8, either because of an
3279 * input flag (two_byte_count = 0), or because a character that
3280 * requires 2 bytes was found (two_byte_count = 1). t points either to
3281 * the beginning of the string (if we didn't examine anything), or to
3282 * the first variant. In either case, everything from s to t - 1 will
3283 * occupy only 1 byte each on output.
3285 * There are two main ways to convert. One is to create a new string
3286 * and go through the input starting from the beginning, appending each
3287 * converted value onto the new string as we go along. It's probably
3288 * best to allocate enough space in the string for the worst possible
3289 * case rather than possibly running out of space and having to
3290 * reallocate and then copy what we've done so far. Since everything
3291 * from s to t - 1 is invariant, the destination can be initialized
3292 * with these using a fast memory copy
3294 * The other way is to figure out exactly how big the string should be
3295 * by parsing the entire input. Then you don't have to make it big
3296 * enough to handle the worst possible case, and more importantly, if
3297 * the string you already have is large enough, you don't have to
3298 * allocate a new string, you can copy the last character in the input
3299 * string to the final position(s) that will be occupied by the
3300 * converted string and go backwards, stopping at t, since everything
3301 * before that is invariant.
3303 * There are advantages and disadvantages to each method.
3305 * In the first method, we can allocate a new string, do the memory
3306 * copy from the s to t - 1, and then proceed through the rest of the
3307 * string byte-by-byte.
3309 * In the second method, we proceed through the rest of the input
3310 * string just calculating how big the converted string will be. Then
3311 * there are two cases:
3312 * 1) if the string has enough extra space to handle the converted
3313 * value. We go backwards through the string, converting until we
3314 * get to the position we are at now, and then stop. If this
3315 * position is far enough along in the string, this method is
3316 * faster than the other method. If the memory copy were the same
3317 * speed as the byte-by-byte loop, that position would be about
3318 * half-way, as at the half-way mark, parsing to the end and back
3319 * is one complete string's parse, the same amount as starting
3320 * over and going all the way through. Actually, it would be
3321 * somewhat less than half-way, as it's faster to just count bytes
3322 * than to also copy, and we don't have the overhead of allocating
3323 * a new string, changing the scalar to use it, and freeing the
3324 * existing one. But if the memory copy is fast, the break-even
3325 * point is somewhere after half way. The counting loop could be
3326 * sped up by vectorization, etc, to move the break-even point
3327 * further towards the beginning.
3328 * 2) if the string doesn't have enough space to handle the converted
3329 * value. A new string will have to be allocated, and one might
3330 * as well, given that, start from the beginning doing the first
3331 * method. We've spent extra time parsing the string and in
3332 * exchange all we've gotten is that we know precisely how big to
3333 * make the new one. Perl is more optimized for time than space,
3334 * so this case is a loser.
3335 * So what I've decided to do is not use the 2nd method unless it is
3336 * guaranteed that a new string won't have to be allocated, assuming
3337 * the worst case. I also decided not to put any more conditions on it
3338 * than this, for now. It seems likely that, since the worst case is
3339 * twice as big as the unknown portion of the string (plus 1), we won't
3340 * be guaranteed enough space, causing us to go to the first method,
3341 * unless the string is short, or the first variant character is near
3342 * the end of it. In either of these cases, it seems best to use the
3343 * 2nd method. The only circumstance I can think of where this would
3344 * be really slower is if the string had once had much more data in it
3345 * than it does now, but there is still a substantial amount in it */
3348 STRLEN invariant_head = t - s;
3349 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3350 if (SvLEN(sv) < size) {
3352 /* Here, have decided to allocate a new string */
3357 Newx(dst, size, U8);
3359 /* If no known invariants at the beginning of the input string,
3360 * set so starts from there. Otherwise, can use memory copy to
3361 * get up to where we are now, and then start from here */
3363 if (invariant_head <= 0) {
3366 Copy(s, dst, invariant_head, char);
3367 d = dst + invariant_head;
3371 const UV uv = NATIVE8_TO_UNI(*t++);
3372 if (UNI_IS_INVARIANT(uv))
3373 *d++ = (U8)UNI_TO_NATIVE(uv);
3375 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3376 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3380 SvPV_free(sv); /* No longer using pre-existing string */
3381 SvPV_set(sv, (char*)dst);
3382 SvCUR_set(sv, d - dst);
3383 SvLEN_set(sv, size);
3386 /* Here, have decided to get the exact size of the string.
3387 * Currently this happens only when we know that there is
3388 * guaranteed enough space to fit the converted string, so
3389 * don't have to worry about growing. If two_byte_count is 0,
3390 * then t points to the first byte of the string which hasn't
3391 * been examined yet. Otherwise two_byte_count is 1, and t
3392 * points to the first byte in the string that will expand to
3393 * two. Depending on this, start examining at t or 1 after t.
3396 U8 *d = t + two_byte_count;
3399 /* Count up the remaining bytes that expand to two */
3402 const U8 chr = *d++;
3403 if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3406 /* The string will expand by just the number of bytes that
3407 * occupy two positions. But we are one afterwards because of
3408 * the increment just above. This is the place to put the
3409 * trailing NUL, and to set the length before we decrement */
3411 d += two_byte_count;
3412 SvCUR_set(sv, d - s);
3416 /* Having decremented d, it points to the position to put the
3417 * very last byte of the expanded string. Go backwards through
3418 * the string, copying and expanding as we go, stopping when we
3419 * get to the part that is invariant the rest of the way down */
3423 const U8 ch = NATIVE8_TO_UNI(*e--);
3424 if (UNI_IS_INVARIANT(ch)) {
3425 *d-- = UNI_TO_NATIVE(ch);
3427 *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3428 *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3435 /* Mark as UTF-8 even if no variant - saves scanning loop */
3441 =for apidoc sv_utf8_downgrade
3443 Attempts to convert the PV of an SV from characters to bytes.
3444 If the PV contains a character that cannot fit
3445 in a byte, this conversion will fail;
3446 in this case, either returns false or, if C<fail_ok> is not
3449 This is not as a general purpose Unicode to byte encoding interface:
3450 use the Encode extension for that.
3456 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3460 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3462 if (SvPOKp(sv) && SvUTF8(sv)) {
3468 sv_force_normal_flags(sv, 0);
3470 s = (U8 *) SvPV(sv, len);
3471 if (!utf8_to_bytes(s, &len)) {
3476 Perl_croak(aTHX_ "Wide character in %s",
3479 Perl_croak(aTHX_ "Wide character");
3490 =for apidoc sv_utf8_encode
3492 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3493 flag off so that it looks like octets again.
3499 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3501 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3504 sv_force_normal_flags(sv, 0);
3506 if (SvREADONLY(sv)) {
3507 Perl_croak(aTHX_ "%s", PL_no_modify);
3509 (void) sv_utf8_upgrade(sv);
3514 =for apidoc sv_utf8_decode
3516 If the PV of the SV is an octet sequence in UTF-8
3517 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3518 so that it looks like a character. If the PV contains only single-byte
3519 characters, the C<SvUTF8> flag stays being off.
3520 Scans PV for validity and returns false if the PV is invalid UTF-8.
3526 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3528 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3534 /* The octets may have got themselves encoded - get them back as
3537 if (!sv_utf8_downgrade(sv, TRUE))
3540 /* it is actually just a matter of turning the utf8 flag on, but
3541 * we want to make sure everything inside is valid utf8 first.
3543 c = (const U8 *) SvPVX_const(sv);
3544 if (!is_utf8_string(c, SvCUR(sv)+1))
3546 e = (const U8 *) SvEND(sv);
3549 if (!UTF8_IS_INVARIANT(ch)) {
3559 =for apidoc sv_setsv
3561 Copies the contents of the source SV C<ssv> into the destination SV
3562 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3563 function if the source SV needs to be reused. Does not handle 'set' magic.
3564 Loosely speaking, it performs a copy-by-value, obliterating any previous
3565 content of the destination.
3567 You probably want to use one of the assortment of wrappers, such as
3568 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3569 C<SvSetMagicSV_nosteal>.
3571 =for apidoc sv_setsv_flags
3573 Copies the contents of the source SV C<ssv> into the destination SV
3574 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3575 function if the source SV needs to be reused. Does not handle 'set' magic.
3576 Loosely speaking, it performs a copy-by-value, obliterating any previous
3577 content of the destination.
3578 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3579 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3580 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3581 and C<sv_setsv_nomg> are implemented in terms of this function.
3583 You probably want to use one of the assortment of wrappers, such as
3584 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3585 C<SvSetMagicSV_nosteal>.
3587 This is the primary function for copying scalars, and most other
3588 copy-ish functions and macros use this underneath.
3594 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3596 I32 mro_changes = 0; /* 1 = method, 2 = isa */
3598 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3600 if (dtype != SVt_PVGV) {
3601 const char * const name = GvNAME(sstr);
3602 const STRLEN len = GvNAMELEN(sstr);
3604 if (dtype >= SVt_PV) {
3610 SvUPGRADE(dstr, SVt_PVGV);
3611 (void)SvOK_off(dstr);
3612 /* FIXME - why are we doing this, then turning it off and on again
3614 isGV_with_GP_on(dstr);
3616 GvSTASH(dstr) = GvSTASH(sstr);
3618 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3619 gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
3620 SvFAKE_on(dstr); /* can coerce to non-glob */
3623 #ifdef GV_UNIQUE_CHECK
3624 if (GvUNIQUE((const GV *)dstr)) {
3625 Perl_croak(aTHX_ "%s", PL_no_modify);
3629 if(GvGP(MUTABLE_GV(sstr))) {
3630 /* If source has method cache entry, clear it */
3632 SvREFCNT_dec(GvCV(sstr));
3636 /* If source has a real method, then a method is
3638 else if(GvCV((const GV *)sstr)) {
3643 /* If dest already had a real method, that's a change as well */
3644 if(!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)) {
3648 if(strEQ(GvNAME((const GV *)dstr),"ISA"))
3651 gp_free(MUTABLE_GV(dstr));
3652 isGV_with_GP_off(dstr);
3653 (void)SvOK_off(dstr);
3654 isGV_with_GP_on(dstr);
3655 GvINTRO_off(dstr); /* one-shot flag */
3656 GvGP(dstr) = gp_ref(GvGP(sstr));
3657 if (SvTAINTED(sstr))
3659 if (GvIMPORTED(dstr) != GVf_IMPORTED
3660 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3662 GvIMPORTED_on(dstr);
3665 if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
3666 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3671 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3673 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3675 const int intro = GvINTRO(dstr);
3678 const U32 stype = SvTYPE(sref);
3680 PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3682 #ifdef GV_UNIQUE_CHECK
3683 if (GvUNIQUE((const GV *)dstr)) {
3684 Perl_croak(aTHX_ "%s", PL_no_modify);
3689 GvINTRO_off(dstr); /* one-shot flag */
3690 GvLINE(dstr) = CopLINE(PL_curcop);
3691 GvEGV(dstr) = MUTABLE_GV(dstr);
3696 location = (SV **) &GvCV(dstr);
3697 import_flag = GVf_IMPORTED_CV;
3700 location = (SV **) &GvHV(dstr);
3701 import_flag = GVf_IMPORTED_HV;
3704 location = (SV **) &GvAV(dstr);
3705 import_flag = GVf_IMPORTED_AV;
3708 location = (SV **) &GvIOp(dstr);
3711 location = (SV **) &GvFORM(dstr);
3713 location = &GvSV(dstr);
3714 import_flag = GVf_IMPORTED_SV;
3717 if (stype == SVt_PVCV) {
3718 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3719 if (GvCVGEN(dstr)) {
3720 SvREFCNT_dec(GvCV(dstr));
3722 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3725 SAVEGENERICSV(*location);
3729 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3730 CV* const cv = MUTABLE_CV(*location);
3732 if (!GvCVGEN((const GV *)dstr) &&
3733 (CvROOT(cv) || CvXSUB(cv)))
3735 /* Redefining a sub - warning is mandatory if
3736 it was a const and its value changed. */
3737 if (CvCONST(cv) && CvCONST((const CV *)sref)
3739 == cv_const_sv((const CV *)sref)) {
3741 /* They are 2 constant subroutines generated from
3742 the same constant. This probably means that
3743 they are really the "same" proxy subroutine
3744 instantiated in 2 places. Most likely this is
3745 when a constant is exported twice. Don't warn.
3748 else if (ckWARN(WARN_REDEFINE)
3750 && (!CvCONST((const CV *)sref)
3751 || sv_cmp(cv_const_sv(cv),
3752 cv_const_sv((const CV *)
3754 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3757 ? "Constant subroutine %s::%s redefined"
3758 : "Subroutine %s::%s redefined"),
3759 HvNAME_get(GvSTASH((const GV *)dstr)),
3760 GvENAME(MUTABLE_GV(dstr)));
3764 cv_ckproto_len(cv, (const GV *)dstr,
3765 SvPOK(sref) ? SvPVX_const(sref) : NULL,
3766 SvPOK(sref) ? SvCUR(sref) : 0);
3768 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3769 GvASSUMECV_on(dstr);
3770 if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3773 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3774 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3775 GvFLAGS(dstr) |= import_flag;
3780 if (SvTAINTED(sstr))
3786 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3789 register U32 sflags;
3791 register svtype stype;
3793 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3798 if (SvIS_FREED(dstr)) {
3799 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3800 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3802 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3804 sstr = &PL_sv_undef;
3805 if (SvIS_FREED(sstr)) {
3806 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3807 (void*)sstr, (void*)dstr);
3809 stype = SvTYPE(sstr);
3810 dtype = SvTYPE(dstr);
3812 (void)SvAMAGIC_off(dstr);
3815 /* need to nuke the magic */
3819 /* There's a lot of redundancy below but we're going for speed here */
3824 if (dtype != SVt_PVGV) {
3825 (void)SvOK_off(dstr);
3833 sv_upgrade(dstr, SVt_IV);
3837 sv_upgrade(dstr, SVt_PVIV);
3840 goto end_of_first_switch;
3842 (void)SvIOK_only(dstr);
3843 SvIV_set(dstr, SvIVX(sstr));
3846 /* SvTAINTED can only be true if the SV has taint magic, which in
3847 turn means that the SV type is PVMG (or greater). This is the
3848 case statement for SVt_IV, so this cannot be true (whatever gcov
3850 assert(!SvTAINTED(sstr));
3855 if (dtype < SVt_PV && dtype != SVt_IV)
3856 sv_upgrade(dstr, SVt_IV);
3864 sv_upgrade(dstr, SVt_NV);
3868 sv_upgrade(dstr, SVt_PVNV);
3871 goto end_of_first_switch;
3873 SvNV_set(dstr, SvNVX(sstr));
3874 (void)SvNOK_only(dstr);
3875 /* SvTAINTED can only be true if the SV has taint magic, which in
3876 turn means that the SV type is PVMG (or greater). This is the
3877 case statement for SVt_NV, so this cannot be true (whatever gcov
3879 assert(!SvTAINTED(sstr));
3885 #ifdef PERL_OLD_COPY_ON_WRITE
3886 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3887 if (dtype < SVt_PVIV)
3888 sv_upgrade(dstr, SVt_PVIV);
3896 sv_upgrade(dstr, SVt_PV);
3899 if (dtype < SVt_PVIV)
3900 sv_upgrade(dstr, SVt_PVIV);
3903 if (dtype < SVt_PVNV)
3904 sv_upgrade(dstr, SVt_PVNV);
3908 const char * const type = sv_reftype(sstr,0);
3910 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3912 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3916 /* case SVt_BIND: */
3919 if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
3920 glob_assign_glob(dstr, sstr, dtype);
3923 /* SvVALID means that this PVGV is playing at being an FBM. */
3927 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3929 if (SvTYPE(sstr) != stype) {
3930 stype = SvTYPE(sstr);
3931 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
3932 glob_assign_glob(dstr, sstr, dtype);
3937 if (stype == SVt_PVLV)
3938 SvUPGRADE(dstr, SVt_PVNV);
3940 SvUPGRADE(dstr, (svtype)stype);
3942 end_of_first_switch:
3944 /* dstr may have been upgraded. */
3945 dtype = SvTYPE(dstr);
3946 sflags = SvFLAGS(sstr);
3948 if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
3949 /* Assigning to a subroutine sets the prototype. */
3952 const char *const ptr = SvPV_const(sstr, len);
3954 SvGROW(dstr, len + 1);
3955 Copy(ptr, SvPVX(dstr), len + 1, char);
3956 SvCUR_set(dstr, len);
3958 SvFLAGS(dstr) |= sflags & SVf_UTF8;
3962 } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3963 const char * const type = sv_reftype(dstr,0);
3965 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op));
3967 Perl_croak(aTHX_ "Cannot copy to %s", type);
3968 } else if (sflags & SVf_ROK) {
3969 if (isGV_with_GP(dstr) && dtype == SVt_PVGV
3970 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
3973 if (GvIMPORTED(dstr) != GVf_IMPORTED
3974 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3976 GvIMPORTED_on(dstr);
3981 glob_assign_glob(dstr, sstr, dtype);
3985 if (dtype >= SVt_PV) {
3986 if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3987 glob_assign_ref(dstr, sstr);
3990 if (SvPVX_const(dstr)) {
3996 (void)SvOK_off(dstr);
3997 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3998 SvFLAGS(dstr) |= sflags & SVf_ROK;
3999 assert(!(sflags & SVp_NOK));
4000 assert(!(sflags & SVp_IOK));
4001 assert(!(sflags & SVf_NOK));
4002 assert(!(sflags & SVf_IOK));
4004 else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
4005 if (!(sflags & SVf_OK)) {
4006 if (ckWARN(WARN_MISC))
4007 Perl_warner(aTHX_ packWARN(WARN_MISC),
4008 "Undefined value assigned to typeglob");
4011 GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
4012 if (dstr != (const SV *)gv) {
4014 gp_free(MUTABLE_GV(dstr));
4015 GvGP(dstr) = gp_ref(GvGP(gv));
4019 else if (sflags & SVp_POK) {
4023 * Check to see if we can just swipe the string. If so, it's a
4024 * possible small lose on short strings, but a big win on long ones.
4025 * It might even be a win on short strings if SvPVX_const(dstr)
4026 * has to be allocated and SvPVX_const(sstr) has to be freed.
4027 * Likewise if we can set up COW rather than doing an actual copy, we
4028 * drop to the else clause, as the swipe code and the COW setup code
4029 * have much in common.
4032 /* Whichever path we take through the next code, we want this true,
4033 and doing it now facilitates the COW check. */
4034 (void)SvPOK_only(dstr);
4037 /* If we're already COW then this clause is not true, and if COW
4038 is allowed then we drop down to the else and make dest COW
4039 with us. If caller hasn't said that we're allowed to COW
4040 shared hash keys then we don't do the COW setup, even if the
4041 source scalar is a shared hash key scalar. */
4042 (((flags & SV_COW_SHARED_HASH_KEYS)
4043 ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4044 : 1 /* If making a COW copy is forbidden then the behaviour we
4045 desire is as if the source SV isn't actually already
4046 COW, even if it is. So we act as if the source flags
4047 are not COW, rather than actually testing them. */
4049 #ifndef PERL_OLD_COPY_ON_WRITE
4050 /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4051 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4052 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4053 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4054 but in turn, it's somewhat dead code, never expected to go
4055 live, but more kept as a placeholder on how to do it better
4056 in a newer implementation. */
4057 /* If we are COW and dstr is a suitable target then we drop down
4058 into the else and make dest a COW of us. */
4059 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4064 (sflags & SVs_TEMP) && /* slated for free anyway? */
4065 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4066 (!(flags & SV_NOSTEAL)) &&
4067 /* and we're allowed to steal temps */
4068 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4069 SvLEN(sstr) && /* and really is a string */
4070 /* and won't be needed again, potentially */
4071 !(PL_op && PL_op->op_type == OP_AASSIGN))
4072 #ifdef PERL_OLD_COPY_ON_WRITE
4073 && ((flags & SV_COW_SHARED_HASH_KEYS)
4074 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4075 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4076 && SvTYPE(sstr) >= SVt_PVIV))
4080 /* Failed the swipe test, and it's not a shared hash key either.
4081 Have to copy the string. */
4082 STRLEN len = SvCUR(sstr);
4083 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4084 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4085 SvCUR_set(dstr, len);
4086 *SvEND(dstr) = '\0';
4088 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4090 /* Either it's a shared hash key, or it's suitable for
4091 copy-on-write or we can swipe the string. */
4093 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4097 #ifdef PERL_OLD_COPY_ON_WRITE
4099 /* I believe I should acquire a global SV mutex if
4100 it's a COW sv (not a shared hash key) to stop
4101 it going un copy-on-write.
4102 If the source SV has gone un copy on write between up there
4103 and down here, then (assert() that) it is of the correct
4104 form to make it copy on write again */
4105 if ((sflags & (SVf_FAKE | SVf_READONLY))
4106 != (SVf_FAKE | SVf_READONLY)) {
4107 SvREADONLY_on(sstr);
4109 /* Make the source SV into a loop of 1.
4110 (about to become 2) */
4111 SV_COW_NEXT_SV_SET(sstr, sstr);
4115 /* Initial code is common. */
4116 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4121 /* making another shared SV. */
4122 STRLEN cur = SvCUR(sstr);
4123 STRLEN len = SvLEN(sstr);
4124 #ifdef PERL_OLD_COPY_ON_WRITE
4126 assert (SvTYPE(dstr) >= SVt_PVIV);
4127 /* SvIsCOW_normal */
4128 /* splice us in between source and next-after-source. */
4129 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4130 SV_COW_NEXT_SV_SET(sstr, dstr);
4131 SvPV_set(dstr, SvPVX_mutable(sstr));
4135 /* SvIsCOW_shared_hash */
4136 DEBUG_C(PerlIO_printf(Perl_debug_log,
4137 "Copy on write: Sharing hash\n"));
4139 assert (SvTYPE(dstr) >= SVt_PV);
4141 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4143 SvLEN_set(dstr, len);
4144 SvCUR_set(dstr, cur);
4145 SvREADONLY_on(dstr);
4147 /* Relesase a global SV mutex. */
4150 { /* Passes the swipe test. */
4151 SvPV_set(dstr, SvPVX_mutable(sstr));
4152 SvLEN_set(dstr, SvLEN(sstr));
4153 SvCUR_set(dstr, SvCUR(sstr));
4156 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4157 SvPV_set(sstr, NULL);
4163 if (sflags & SVp_NOK) {
4164 SvNV_set(dstr, SvNVX(sstr));
4166 if (sflags & SVp_IOK) {
4167 SvIV_set(dstr, SvIVX(sstr));
4168 /* Must do this otherwise some other overloaded use of 0x80000000
4169 gets confused. I guess SVpbm_VALID */
4170 if (sflags & SVf_IVisUV)
4173 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4175 const MAGIC * const smg = SvVSTRING_mg(sstr);
4177 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4178 smg->mg_ptr, smg->mg_len);
4179 SvRMAGICAL_on(dstr);
4183 else if (sflags & (SVp_IOK|SVp_NOK)) {
4184 (void)SvOK_off(dstr);
4185 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4186 if (sflags & SVp_IOK) {
4187 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4188 SvIV_set(dstr, SvIVX(sstr));
4190 if (sflags & SVp_NOK) {
4191 SvNV_set(dstr, SvNVX(sstr));
4195 if (isGV_with_GP(sstr)) {
4196 /* This stringification rule for globs is spread in 3 places.
4197 This feels bad. FIXME. */
4198 const U32 wasfake = sflags & SVf_FAKE;
4200 /* FAKE globs can get coerced, so need to turn this off
4201 temporarily if it is on. */
4203 gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4204 SvFLAGS(sstr) |= wasfake;
4207 (void)SvOK_off(dstr);
4209 if (SvTAINTED(sstr))
4214 =for apidoc sv_setsv_mg
4216 Like C<sv_setsv>, but also handles 'set' magic.
4222 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4224 PERL_ARGS_ASSERT_SV_SETSV_MG;
4226 sv_setsv(dstr,sstr);
4230 #ifdef PERL_OLD_COPY_ON_WRITE
4232 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4234 STRLEN cur = SvCUR(sstr);
4235 STRLEN len = SvLEN(sstr);
4236 register char *new_pv;
4238 PERL_ARGS_ASSERT_SV_SETSV_COW;
4241 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4242 (void*)sstr, (void*)dstr);
4249 if (SvTHINKFIRST(dstr))
4250 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4251 else if (SvPVX_const(dstr))
4252 Safefree(SvPVX_const(dstr));
4256 SvUPGRADE(dstr, SVt_PVIV);
4258 assert (SvPOK(sstr));
4259 assert (SvPOKp(sstr));
4260 assert (!SvIOK(sstr));
4261 assert (!SvIOKp(sstr));
4262 assert (!SvNOK(sstr));
4263 assert (!SvNOKp(sstr));
4265 if (SvIsCOW(sstr)) {
4267 if (SvLEN(sstr) == 0) {
4268 /* source is a COW shared hash key. */
4269 DEBUG_C(PerlIO_printf(Perl_debug_log,
4270 "Fast copy on write: Sharing hash\n"));
4271 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4274 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4276 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4277 SvUPGRADE(sstr, SVt_PVIV);
4278 SvREADONLY_on(sstr);
4280 DEBUG_C(PerlIO_printf(Perl_debug_log,
4281 "Fast copy on write: Converting sstr to COW\n"));
4282 SV_COW_NEXT_SV_SET(dstr, sstr);
4284 SV_COW_NEXT_SV_SET(sstr, dstr);
4285 new_pv = SvPVX_mutable(sstr);
4288 SvPV_set(dstr, new_pv);
4289 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4292 SvLEN_set(dstr, len);
4293 SvCUR_set(dstr, cur);
4302 =for apidoc sv_setpvn
4304 Copies a string into an SV. The C<len> parameter indicates the number of
4305 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4306 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4312 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4315 register char *dptr;
4317 PERL_ARGS_ASSERT_SV_SETPVN;
4319 SV_CHECK_THINKFIRST_COW_DROP(sv);
4325 /* len is STRLEN which is unsigned, need to copy to signed */
4328 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4330 SvUPGRADE(sv, SVt_PV);
4332 dptr = SvGROW(sv, len + 1);
4333 Move(ptr,dptr,len,char);
4336 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4341 =for apidoc sv_setpvn_mg
4343 Like C<sv_setpvn>, but also handles 'set' magic.
4349 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4351 PERL_ARGS_ASSERT_SV_SETPVN_MG;
4353 sv_setpvn(sv,ptr,len);
4358 =for apidoc sv_setpv
4360 Copies a string into an SV. The string must be null-terminated. Does not
4361 handle 'set' magic. See C<sv_setpv_mg>.
4367 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4370 register STRLEN len;
4372 PERL_ARGS_ASSERT_SV_SETPV;
4374 SV_CHECK_THINKFIRST_COW_DROP(sv);
4380 SvUPGRADE(sv, SVt_PV);
4382 SvGROW(sv, len + 1);
4383 Move(ptr,SvPVX(sv),len+1,char);
4385 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4390 =for apidoc sv_setpv_mg
4392 Like C<sv_setpv>, but also handles 'set' magic.
4398 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4400 PERL_ARGS_ASSERT_SV_SETPV_MG;
4407 =for apidoc sv_usepvn_flags
4409 Tells an SV to use C<ptr> to find its string value. Normally the
4410 string is stored inside the SV but sv_usepvn allows the SV to use an
4411 outside string. The C<ptr> should point to memory that was allocated
4412 by C<malloc>. The string length, C<len>, must be supplied. By default
4413 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4414 so that pointer should not be freed or used by the programmer after
4415 giving it to sv_usepvn, and neither should any pointers from "behind"
4416 that pointer (e.g. ptr + 1) be used.
4418 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4419 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4420 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4421 C<len>, and already meets the requirements for storing in C<SvPVX>)
4427 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4432 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4434 SV_CHECK_THINKFIRST_COW_DROP(sv);
4435 SvUPGRADE(sv, SVt_PV);
4438 if (flags & SV_SMAGIC)
4442 if (SvPVX_const(sv))
4446 if (flags & SV_HAS_TRAILING_NUL)
4447 assert(ptr[len] == '\0');
4450 allocate = (flags & SV_HAS_TRAILING_NUL)
4452 #ifdef Perl_safesysmalloc_size
4455 PERL_STRLEN_ROUNDUP(len + 1);
4457 if (flags & SV_HAS_TRAILING_NUL) {
4458 /* It's long enough - do nothing.
4459 Specfically Perl_newCONSTSUB is relying on this. */
4462 /* Force a move to shake out bugs in callers. */
4463 char *new_ptr = (char*)safemalloc(allocate);
4464 Copy(ptr, new_ptr, len, char);
4465 PoisonFree(ptr,len,char);
4469 ptr = (char*) saferealloc (ptr, allocate);
4472 #ifdef Perl_safesysmalloc_size
4473 SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4475 SvLEN_set(sv, allocate);
4479 if (!(flags & SV_HAS_TRAILING_NUL)) {
4482 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4484 if (flags & SV_SMAGIC)
4488 #ifdef PERL_OLD_COPY_ON_WRITE
4489 /* Need to do this *after* making the SV normal, as we need the buffer
4490 pointer to remain valid until after we've copied it. If we let go too early,
4491 another thread could invalidate it by unsharing last of the same hash key
4492 (which it can do by means other than releasing copy-on-write Svs)
4493 or by changing the other copy-on-write SVs in the loop. */
4495 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4497 PERL_ARGS_ASSERT_SV_RELEASE_COW;
4499 { /* this SV was SvIsCOW_normal(sv) */
4500 /* we need to find the SV pointing to us. */
4501 SV *current = SV_COW_NEXT_SV(after);
4503 if (current == sv) {
4504 /* The SV we point to points back to us (there were only two of us
4506 Hence other SV is no longer copy on write either. */
4508 SvREADONLY_off(after);
4510 /* We need to follow the pointers around the loop. */
4512 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4515 /* don't loop forever if the structure is bust, and we have
4516 a pointer into a closed loop. */
4517 assert (current != after);
4518 assert (SvPVX_const(current) == pvx);
4520 /* Make the SV before us point to the SV after us. */
4521 SV_COW_NEXT_SV_SET(current, after);
4527 =for apidoc sv_force_normal_flags
4529 Undo various types of fakery on an SV: if the PV is a shared string, make
4530 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4531 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4532 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4533 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4534 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4535 set to some other value.) In addition, the C<flags> parameter gets passed to
4536 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4537 with flags set to 0.
4543 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4547 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4549 #ifdef PERL_OLD_COPY_ON_WRITE
4550 if (SvREADONLY(sv)) {
4551 /* At this point I believe I should acquire a global SV mutex. */
4553 const char * const pvx = SvPVX_const(sv);
4554 const STRLEN len = SvLEN(sv);
4555 const STRLEN cur = SvCUR(sv);
4556 /* next COW sv in the loop. If len is 0 then this is a shared-hash
4557 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4558 we'll fail an assertion. */
4559 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4562 PerlIO_printf(Perl_debug_log,
4563 "Copy on write: Force normal %ld\n",
4569 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4572 if (flags & SV_COW_DROP_PV) {
4573 /* OK, so we don't need to copy our buffer. */
4576 SvGROW(sv, cur + 1);
4577 Move(pvx,SvPVX(sv),cur,char);
4582 sv_release_COW(sv, pvx, next);
4584 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4590 else if (IN_PERL_RUNTIME)
4591 Perl_croak(aTHX_ "%s", PL_no_modify);
4592 /* At this point I believe that I can drop the global SV mutex. */
4595 if (SvREADONLY(sv)) {
4597 const char * const pvx = SvPVX_const(sv);
4598 const STRLEN len = SvCUR(sv);
4603 SvGROW(sv, len + 1);
4604 Move(pvx,SvPVX(sv),len,char);
4606 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4608 else if (IN_PERL_RUNTIME)
4609 Perl_croak(aTHX_ "%s", PL_no_modify);
4613 sv_unref_flags(sv, flags);
4614 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4621 Efficient removal of characters from the beginning of the string buffer.
4622 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4623 the string buffer. The C<ptr> becomes the first character of the adjusted
4624 string. Uses the "OOK hack".
4625 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4626 refer to the same chunk of data.
4632 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4638 const U8 *real_start;
4642 PERL_ARGS_ASSERT_SV_CHOP;
4644 if (!ptr || !SvPOKp(sv))
4646 delta = ptr - SvPVX_const(sv);
4648 /* Nothing to do. */
4651 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4652 nothing uses the value of ptr any more. */
4653 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4654 if (ptr <= SvPVX_const(sv))
4655 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4656 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4657 SV_CHECK_THINKFIRST(sv);
4658 if (delta > max_delta)
4659 Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4660 SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4661 SvPVX_const(sv) + max_delta);
4664 if (!SvLEN(sv)) { /* make copy of shared string */
4665 const char *pvx = SvPVX_const(sv);
4666 const STRLEN len = SvCUR(sv);
4667 SvGROW(sv, len + 1);
4668 Move(pvx,SvPVX(sv),len,char);
4671 SvFLAGS(sv) |= SVf_OOK;
4674 SvOOK_offset(sv, old_delta);
4676 SvLEN_set(sv, SvLEN(sv) - delta);
4677 SvCUR_set(sv, SvCUR(sv) - delta);
4678 SvPV_set(sv, SvPVX(sv) + delta);
4680 p = (U8 *)SvPVX_const(sv);
4685 real_start = p - delta;
4689 if (delta < 0x100) {
4693 p -= sizeof(STRLEN);
4694 Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4698 /* Fill the preceding buffer with sentinals to verify that no-one is
4700 while (p > real_start) {
4708 =for apidoc sv_catpvn
4710 Concatenates the string onto the end of the string which is in the SV. The
4711 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4712 status set, then the bytes appended should be valid UTF-8.
4713 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4715 =for apidoc sv_catpvn_flags
4717 Concatenates the string onto the end of the string which is in the SV. The
4718 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4719 status set, then the bytes appended should be valid UTF-8.
4720 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4721 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4722 in terms of this function.
4728 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4732 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4734 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4736 SvGROW(dsv, dlen + slen + 1);
4738 sstr = SvPVX_const(dsv);
4739 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4740 SvCUR_set(dsv, SvCUR(dsv) + slen);
4742 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4744 if (flags & SV_SMAGIC)
4749 =for apidoc sv_catsv
4751 Concatenates the string from SV C<ssv> onto the end of the string in
4752 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4753 not 'set' magic. See C<sv_catsv_mg>.
4755 =for apidoc sv_catsv_flags
4757 Concatenates the string from SV C<ssv> onto the end of the string in
4758 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4759 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4760 and C<sv_catsv_nomg> are implemented in terms of this function.
4765 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4769 PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4773 const char *spv = SvPV_const(ssv, slen);
4775 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4776 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4777 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4778 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4779 dsv->sv_flags doesn't have that bit set.
4780 Andy Dougherty 12 Oct 2001
4782 const I32 sutf8 = DO_UTF8(ssv);
4785 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4787 dutf8 = DO_UTF8(dsv);
4789 if (dutf8 != sutf8) {
4791 /* Not modifying source SV, so taking a temporary copy. */
4792 SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4794 sv_utf8_upgrade(csv);
4795 spv = SvPV_const(csv, slen);
4798 sv_utf8_upgrade_nomg(dsv);
4800 sv_catpvn_nomg(dsv, spv, slen);
4803 if (flags & SV_SMAGIC)
4808 =for apidoc sv_catpv
4810 Concatenates the string onto the end of the string which is in the SV.
4811 If the SV has the UTF-8 status set, then the bytes appended should be
4812 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4817 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4820 register STRLEN len;
4824 PERL_ARGS_ASSERT_SV_CATPV;
4828 junk = SvPV_force(sv, tlen);
4830 SvGROW(sv, tlen + len + 1);
4832 ptr = SvPVX_const(sv);
4833 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4834 SvCUR_set(sv, SvCUR(sv) + len);
4835 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4840 =for apidoc sv_catpv_mg
4842 Like C<sv_catpv>, but also handles 'set' magic.
4848 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4850 PERL_ARGS_ASSERT_SV_CATPV_MG;
4859 Creates a new SV. A non-zero C<len> parameter indicates the number of
4860 bytes of preallocated string space the SV should have. An extra byte for a
4861 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
4862 space is allocated.) The reference count for the new SV is set to 1.
4864 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4865 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4866 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4867 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
4868 modules supporting older perls.
4874 Perl_newSV(pTHX_ const STRLEN len)
4881 sv_upgrade(sv, SVt_PV);
4882 SvGROW(sv, len + 1);
4887 =for apidoc sv_magicext
4889 Adds magic to an SV, upgrading it if necessary. Applies the
4890 supplied vtable and returns a pointer to the magic added.
4892 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4893 In particular, you can add magic to SvREADONLY SVs, and add more than
4894 one instance of the same 'how'.
4896 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4897 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4898 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4899 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4901 (This is now used as a subroutine by C<sv_magic>.)
4906 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
4907 const MGVTBL *const vtable, const char *const name, const I32 namlen)
4912 PERL_ARGS_ASSERT_SV_MAGICEXT;
4914 SvUPGRADE(sv, SVt_PVMG);
4915 Newxz(mg, 1, MAGIC);
4916 mg->mg_moremagic = SvMAGIC(sv);
4917 SvMAGIC_set(sv, mg);
4919 /* Sometimes a magic contains a reference loop, where the sv and
4920 object refer to each other. To prevent a reference loop that
4921 would prevent such objects being freed, we look for such loops
4922 and if we find one we avoid incrementing the object refcount.
4924 Note we cannot do this to avoid self-tie loops as intervening RV must
4925 have its REFCNT incremented to keep it in existence.
4928 if (!obj || obj == sv ||
4929 how == PERL_MAGIC_arylen ||
4930 how == PERL_MAGIC_symtab ||
4931 (SvTYPE(obj) == SVt_PVGV &&
4932 (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
4933 || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
4934 || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
4939 mg->mg_obj = SvREFCNT_inc_simple(obj);
4940 mg->mg_flags |= MGf_REFCOUNTED;
4943 /* Normal self-ties simply pass a null object, and instead of
4944 using mg_obj directly, use the SvTIED_obj macro to produce a
4945 new RV as needed. For glob "self-ties", we are tieing the PVIO
4946 with an RV obj pointing to the glob containing the PVIO. In
4947 this case, to avoid a reference loop, we need to weaken the
4951 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4952 obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
4958 mg->mg_len = namlen;
4961 mg->mg_ptr = savepvn(name, namlen);
4962 else if (namlen == HEf_SVKEY) {
4963 /* Yes, this is casting away const. This is only for the case of
4964 HEf_SVKEY. I think we need to document this abberation of the
4965 constness of the API, rather than making name non-const, as
4966 that change propagating outwards a long way. */
4967 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
4969 mg->mg_ptr = (char *) name;
4971 mg->mg_virtual = (MGVTBL *) vtable;
4975 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4980 =for apidoc sv_magic
4982 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4983 then adds a new magic item of type C<how> to the head of the magic list.
4985 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4986 handling of the C<name> and C<namlen> arguments.
4988 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4989 to add more than one instance of the same 'how'.
4995 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
4996 const char *const name, const I32 namlen)
4999 const MGVTBL *vtable;
5002 PERL_ARGS_ASSERT_SV_MAGIC;
5004 #ifdef PERL_OLD_COPY_ON_WRITE
5006 sv_force_normal_flags(sv, 0);
5008 if (SvREADONLY(sv)) {
5010 /* its okay to attach magic to shared strings; the subsequent
5011 * upgrade to PVMG will unshare the string */
5012 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
5015 && how != PERL_MAGIC_regex_global
5016 && how != PERL_MAGIC_bm
5017 && how != PERL_MAGIC_fm
5018 && how != PERL_MAGIC_sv
5019 && how != PERL_MAGIC_backref
5022 Perl_croak(aTHX_ "%s", PL_no_modify);
5025 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5026 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5027 /* sv_magic() refuses to add a magic of the same 'how' as an
5030 if (how == PERL_MAGIC_taint) {
5032 /* Any scalar which already had taint magic on which someone
5033 (erroneously?) did SvIOK_on() or similar will now be
5034 incorrectly sporting public "OK" flags. */
5035 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5043 vtable = &PL_vtbl_sv;
5045 case PERL_MAGIC_overload:
5046 vtable = &PL_vtbl_amagic;
5048 case PERL_MAGIC_overload_elem:
5049 vtable = &PL_vtbl_amagicelem;
5051 case PERL_MAGIC_overload_table:
5052 vtable = &PL_vtbl_ovrld;
5055 vtable = &PL_vtbl_bm;
5057 case PERL_MAGIC_regdata:
5058 vtable = &PL_vtbl_regdata;
5060 case PERL_MAGIC_regdatum:
5061 vtable = &PL_vtbl_regdatum;
5063 case PERL_MAGIC_env:
5064 vtable = &PL_vtbl_env;
5067 vtable = &PL_vtbl_fm;
5069 case PERL_MAGIC_envelem:
5070 vtable = &PL_vtbl_envelem;
5072 case PERL_MAGIC_regex_global:
5073 vtable = &PL_vtbl_mglob;
5075 case PERL_MAGIC_isa:
5076 vtable = &PL_vtbl_isa;
5078 case PERL_MAGIC_isaelem:
5079 vtable = &PL_vtbl_isaelem;
5081 case PERL_MAGIC_nkeys:
5082 vtable = &PL_vtbl_nkeys;
5084 case PERL_MAGIC_dbfile:
5087 case PERL_MAGIC_dbline:
5088 vtable = &PL_vtbl_dbline;
5090 #ifdef USE_LOCALE_COLLATE
5091 case PERL_MAGIC_collxfrm:
5092 vtable = &PL_vtbl_collxfrm;
5094 #endif /* USE_LOCALE_COLLATE */
5095 case PERL_MAGIC_tied:
5096 vtable = &PL_vtbl_pack;
5098 case PERL_MAGIC_tiedelem:
5099 case PERL_MAGIC_tiedscalar:
5100 vtable = &PL_vtbl_packelem;
5103 vtable = &PL_vtbl_regexp;
5105 case PERL_MAGIC_hints:
5106 /* As this vtable is all NULL, we can reuse it. */
5107 case PERL_MAGIC_sig:
5108 vtable = &PL_vtbl_sig;
5110 case PERL_MAGIC_sigelem:
5111 vtable = &PL_vtbl_sigelem;
5113 case PERL_MAGIC_taint:
5114 vtable = &PL_vtbl_taint;
5116 case PERL_MAGIC_uvar:
5117 vtable = &PL_vtbl_uvar;
5119 case PERL_MAGIC_vec:
5120 vtable = &PL_vtbl_vec;
5122 case PERL_MAGIC_arylen_p:
5123 case PERL_MAGIC_rhash:
5124 case PERL_MAGIC_symtab:
5125 case PERL_MAGIC_vstring:
5128 case PERL_MAGIC_utf8:
5129 vtable = &PL_vtbl_utf8;
5131 case PERL_MAGIC_substr:
5132 vtable = &PL_vtbl_substr;
5134 case PERL_MAGIC_defelem:
5135 vtable = &PL_vtbl_defelem;
5137 case PERL_MAGIC_arylen:
5138 vtable = &PL_vtbl_arylen;
5140 case PERL_MAGIC_pos:
5141 vtable = &PL_vtbl_pos;
5143 case PERL_MAGIC_backref:
5144 vtable = &PL_vtbl_backref;
5146 case PERL_MAGIC_hintselem:
5147 vtable = &PL_vtbl_hintselem;
5149 case PERL_MAGIC_ext:
5150 /* Reserved for use by extensions not perl internals. */
5151 /* Useful for attaching extension internal data to perl vars. */
5152 /* Note that multiple extensions may clash if magical scalars */
5153 /* etc holding private data from one are passed to another. */
5157 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5160 /* Rest of work is done else where */
5161 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5164 case PERL_MAGIC_taint:
5167 case PERL_MAGIC_ext:
5168 case PERL_MAGIC_dbfile:
5175 =for apidoc sv_unmagic
5177 Removes all magic of type C<type> from an SV.
5183 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5188 PERL_ARGS_ASSERT_SV_UNMAGIC;
5190 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5192 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5193 for (mg = *mgp; mg; mg = *mgp) {
5194 if (mg->mg_type == type) {
5195 const MGVTBL* const vtbl = mg->mg_virtual;
5196 *mgp = mg->mg_moremagic;
5197 if (vtbl && vtbl->svt_free)
5198 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5199 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5201 Safefree(mg->mg_ptr);
5202 else if (mg->mg_len == HEf_SVKEY)
5203 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5204 else if (mg->mg_type == PERL_MAGIC_utf8)
5205 Safefree(mg->mg_ptr);
5207 if (mg->mg_flags & MGf_REFCOUNTED)
5208 SvREFCNT_dec(mg->mg_obj);
5212 mgp = &mg->mg_moremagic;
5216 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5217 SvMAGIC_set(sv, NULL);
5224 =for apidoc sv_rvweaken
5226 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5227 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5228 push a back-reference to this RV onto the array of backreferences
5229 associated with that magic. If the RV is magical, set magic will be
5230 called after the RV is cleared.
5236 Perl_sv_rvweaken(pTHX_ SV *const sv)
5240 PERL_ARGS_ASSERT_SV_RVWEAKEN;
5242 if (!SvOK(sv)) /* let undefs pass */
5245 Perl_croak(aTHX_ "Can't weaken a nonreference");
5246 else if (SvWEAKREF(sv)) {
5247 if (ckWARN(WARN_MISC))
5248 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5252 Perl_sv_add_backref(aTHX_ tsv, sv);
5258 /* Give tsv backref magic if it hasn't already got it, then push a
5259 * back-reference to sv onto the array associated with the backref magic.
5262 /* A discussion about the backreferences array and its refcount:
5264 * The AV holding the backreferences is pointed to either as the mg_obj of
5265 * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
5266 * structure, from the xhv_backreferences field. (A HV without hv_aux will
5267 * have the standard magic instead.) The array is created with a refcount
5268 * of 2. This means that if during global destruction the array gets
5269 * picked on first to have its refcount decremented by the random zapper,
5270 * it won't actually be freed, meaning it's still theere for when its
5271 * parent gets freed.
5272 * When the parent SV is freed, in the case of magic, the magic is freed,
5273 * Perl_magic_killbackrefs is called which decrements one refcount, then
5274 * mg_obj is freed which kills the second count.
5275 * In the vase of a HV being freed, one ref is removed by
5276 * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
5281 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5286 PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5288 if (SvTYPE(tsv) == SVt_PVHV) {
5289 AV **const avp = Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5293 /* There is no AV in the offical place - try a fixup. */
5294 MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
5297 /* Aha. They've got it stowed in magic. Bring it back. */
5298 av = MUTABLE_AV(mg->mg_obj);
5299 /* Stop mg_free decreasing the refernce count. */
5301 /* Stop mg_free even calling the destructor, given that
5302 there's no AV to free up. */
5304 sv_unmagic(tsv, PERL_MAGIC_backref);
5308 SvREFCNT_inc_simple_void(av); /* see discussion above */
5313 const MAGIC *const mg
5314 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5316 av = MUTABLE_AV(mg->mg_obj);
5320 sv_magic(tsv, MUTABLE_SV(av), PERL_MAGIC_backref, NULL, 0);
5321 /* av now has a refcnt of 2; see discussion above */
5324 if (AvFILLp(av) >= AvMAX(av)) {
5325 av_extend(av, AvFILLp(av)+1);
5327 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5330 /* delete a back-reference to ourselves from the backref magic associated
5331 * with the SV we point to.
5335 S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5342 PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5344 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5345 av = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5346 /* We mustn't attempt to "fix up" the hash here by moving the
5347 backreference array back to the hv_aux structure, as that is stored
5348 in the main HvARRAY(), and hfreentries assumes that no-one
5349 reallocates HvARRAY() while it is running. */
5352 const MAGIC *const mg
5353 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5355 av = MUTABLE_AV(mg->mg_obj);
5359 Perl_croak(aTHX_ "panic: del_backref");
5361 assert(!SvIS_FREED(av));
5364 /* We shouldn't be in here more than once, but for paranoia reasons lets
5366 for (i = AvFILLp(av); i >= 0; i--) {
5368 const SSize_t fill = AvFILLp(av);
5370 /* We weren't the last entry.
5371 An unordered list has this property that you can take the
5372 last element off the end to fill the hole, and it's still
5373 an unordered list :-)
5378 AvFILLp(av) = fill - 1;
5384 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5386 SV **svp = AvARRAY(av);
5388 PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5389 PERL_UNUSED_ARG(sv);
5391 assert(!svp || !SvIS_FREED(av));
5393 SV *const *const last = svp + AvFILLp(av);
5395 while (svp <= last) {
5397 SV *const referrer = *svp;
5398 if (SvWEAKREF(referrer)) {
5399 /* XXX Should we check that it hasn't changed? */
5400 SvRV_set(referrer, 0);
5402 SvWEAKREF_off(referrer);
5403 SvSETMAGIC(referrer);
5404 } else if (SvTYPE(referrer) == SVt_PVGV ||
5405 SvTYPE(referrer) == SVt_PVLV) {
5406 /* You lookin' at me? */
5407 assert(GvSTASH(referrer));
5408 assert(GvSTASH(referrer) == (const HV *)sv);
5409 GvSTASH(referrer) = 0;
5412 "panic: magic_killbackrefs (flags=%"UVxf")",
5413 (UV)SvFLAGS(referrer));
5421 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5426 =for apidoc sv_insert
5428 Inserts a string at the specified offset/length within the SV. Similar to
5429 the Perl substr() function. Handles get magic.
5431 =for apidoc sv_insert_flags
5433 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5439 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5444 register char *midend;
5445 register char *bigend;
5449 PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5452 Perl_croak(aTHX_ "Can't modify non-existent substring");
5453 SvPV_force_flags(bigstr, curlen, flags);
5454 (void)SvPOK_only_UTF8(bigstr);
5455 if (offset + len > curlen) {
5456 SvGROW(bigstr, offset+len+1);
5457 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5458 SvCUR_set(bigstr, offset+len);
5462 i = littlelen - len;
5463 if (i > 0) { /* string might grow */
5464 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5465 mid = big + offset + len;
5466 midend = bigend = big + SvCUR(bigstr);
5469 while (midend > mid) /* shove everything down */
5470 *--bigend = *--midend;
5471 Move(little,big+offset,littlelen,char);
5472 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5477 Move(little,SvPVX(bigstr)+offset,len,char);
5482 big = SvPVX(bigstr);
5485 bigend = big + SvCUR(bigstr);
5487 if (midend > bigend)
5488 Perl_croak(aTHX_ "panic: sv_insert");
5490 if (mid - big > bigend - midend) { /* faster to shorten from end */
5492 Move(little, mid, littlelen,char);
5495 i = bigend - midend;
5497 Move(midend, mid, i,char);
5501 SvCUR_set(bigstr, mid - big);
5503 else if ((i = mid - big)) { /* faster from front */
5504 midend -= littlelen;
5506 Move(big, midend - i, i, char);
5507 sv_chop(bigstr,midend-i);
5509 Move(little, mid, littlelen,char);
5511 else if (littlelen) {
5512 midend -= littlelen;
5513 sv_chop(bigstr,midend);
5514 Move(little,midend,littlelen,char);
5517 sv_chop(bigstr,midend);
5523 =for apidoc sv_replace
5525 Make the first argument a copy of the second, then delete the original.
5526 The target SV physically takes over ownership of the body of the source SV
5527 and inherits its flags; however, the target keeps any magic it owns,
5528 and any magic in the source is discarded.
5529 Note that this is a rather specialist SV copying operation; most of the
5530 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5536 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5539 const U32 refcnt = SvREFCNT(sv);
5541 PERL_ARGS_ASSERT_SV_REPLACE;
5543 SV_CHECK_THINKFIRST_COW_DROP(sv);
5544 if (SvREFCNT(nsv) != 1) {
5545 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
5546 UVuf " != 1)", (UV) SvREFCNT(nsv));
5548 if (SvMAGICAL(sv)) {
5552 sv_upgrade(nsv, SVt_PVMG);
5553 SvMAGIC_set(nsv, SvMAGIC(sv));
5554 SvFLAGS(nsv) |= SvMAGICAL(sv);
5556 SvMAGIC_set(sv, NULL);
5560 assert(!SvREFCNT(sv));
5561 #ifdef DEBUG_LEAKING_SCALARS
5562 sv->sv_flags = nsv->sv_flags;
5563 sv->sv_any = nsv->sv_any;
5564 sv->sv_refcnt = nsv->sv_refcnt;
5565 sv->sv_u = nsv->sv_u;
5567 StructCopy(nsv,sv,SV);
5569 if(SvTYPE(sv) == SVt_IV) {
5571 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5575 #ifdef PERL_OLD_COPY_ON_WRITE
5576 if (SvIsCOW_normal(nsv)) {
5577 /* We need to follow the pointers around the loop to make the
5578 previous SV point to sv, rather than nsv. */
5581 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5584 assert(SvPVX_const(current) == SvPVX_const(nsv));
5586 /* Make the SV before us point to the SV after us. */
5588 PerlIO_printf(Perl_debug_log, "previous is\n");
5590 PerlIO_printf(Perl_debug_log,
5591 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5592 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5594 SV_COW_NEXT_SV_SET(current, sv);
5597 SvREFCNT(sv) = refcnt;
5598 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5604 =for apidoc sv_clear
5606 Clear an SV: call any destructors, free up any memory used by the body,
5607 and free the body itself. The SV's head is I<not> freed, although
5608 its type is set to all 1's so that it won't inadvertently be assumed
5609 to be live during global destruction etc.
5610 This function should only be called when REFCNT is zero. Most of the time
5611 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5618 Perl_sv_clear(pTHX_ register SV *const sv)
5621 const U32 type = SvTYPE(sv);
5622 const struct body_details *const sv_type_details
5623 = bodies_by_type + type;
5626 PERL_ARGS_ASSERT_SV_CLEAR;
5627 assert(SvREFCNT(sv) == 0);
5628 assert(SvTYPE(sv) != SVTYPEMASK);
5630 if (type <= SVt_IV) {
5631 /* See the comment in sv.h about the collusion between this early
5632 return and the overloading of the NULL and IV slots in the size
5635 SV * const target = SvRV(sv);
5637 sv_del_backref(target, sv);
5639 SvREFCNT_dec(target);
5641 SvFLAGS(sv) &= SVf_BREAK;
5642 SvFLAGS(sv) |= SVTYPEMASK;
5647 if (PL_defstash && /* Still have a symbol table? */
5654 stash = SvSTASH(sv);
5655 destructor = StashHANDLER(stash,DESTROY);
5657 SV* const tmpref = newRV(sv);
5658 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5660 PUSHSTACKi(PERLSI_DESTROY);
5665 call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5671 if(SvREFCNT(tmpref) < 2) {
5672 /* tmpref is not kept alive! */
5674 SvRV_set(tmpref, NULL);
5677 SvREFCNT_dec(tmpref);
5679 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5683 if (PL_in_clean_objs)
5684 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5686 /* DESTROY gave object new lease on life */
5692 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5693 SvOBJECT_off(sv); /* Curse the object. */
5694 if (type != SVt_PVIO)
5695 --PL_sv_objcount; /* XXX Might want something more general */
5698 if (type >= SVt_PVMG) {
5699 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
5700 SvREFCNT_dec(SvOURSTASH(sv));
5701 } else if (SvMAGIC(sv))
5703 if (type == SVt_PVMG && SvPAD_TYPED(sv))
5704 SvREFCNT_dec(SvSTASH(sv));
5707 /* case SVt_BIND: */
5710 IoIFP(sv) != PerlIO_stdin() &&
5711 IoIFP(sv) != PerlIO_stdout() &&
5712 IoIFP(sv) != PerlIO_stderr())
5714 io_close(MUTABLE_IO(sv), FALSE);
5716 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5717 PerlDir_close(IoDIRP(sv));
5718 IoDIRP(sv) = (DIR*)NULL;
5719 Safefree(IoTOP_NAME(sv));
5720 Safefree(IoFMT_NAME(sv));
5721 Safefree(IoBOTTOM_NAME(sv));
5724 /* FIXME for plugins */
5725 pregfree2((REGEXP*) sv);
5729 cv_undef(MUTABLE_CV(sv));
5732 if (PL_last_swash_hv == (const HV *)sv) {
5733 PL_last_swash_hv = NULL;
5735 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
5736 hv_undef(MUTABLE_HV(sv));
5739 if (PL_comppad == MUTABLE_AV(sv)) {
5743 av_undef(MUTABLE_AV(sv));
5746 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5747 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5748 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5749 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5751 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5752 SvREFCNT_dec(LvTARG(sv));
5754 if (isGV_with_GP(sv)) {
5755 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
5756 && HvNAME_get(stash))
5757 mro_method_changed_in(stash);
5758 gp_free(MUTABLE_GV(sv));
5760 unshare_hek(GvNAME_HEK(sv));
5761 /* If we're in a stash, we don't own a reference to it. However it does
5762 have a back reference to us, which needs to be cleared. */
5763 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
5764 sv_del_backref(MUTABLE_SV(stash), sv);
5766 /* FIXME. There are probably more unreferenced pointers to SVs in the
5767 interpreter struct that we should check and tidy in a similar
5769 if ((const GV *)sv == PL_last_in_gv)
5770 PL_last_in_gv = NULL;
5776 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5779 SvOOK_offset(sv, offset);
5780 SvPV_set(sv, SvPVX_mutable(sv) - offset);
5781 /* Don't even bother with turning off the OOK flag. */
5784 SV * const target = SvRV(sv);
5786 sv_del_backref(target, sv);
5788 SvREFCNT_dec(target);
5790 #ifdef PERL_OLD_COPY_ON_WRITE
5791 else if (SvPVX_const(sv)) {
5793 /* I believe I need to grab the global SV mutex here and
5794 then recheck the COW status. */
5796 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5800 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
5802 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5805 /* And drop it here. */
5807 } else if (SvLEN(sv)) {
5808 Safefree(SvPVX_const(sv));
5812 else if (SvPVX_const(sv) && SvLEN(sv))
5813 Safefree(SvPVX_mutable(sv));
5814 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5815 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5824 SvFLAGS(sv) &= SVf_BREAK;
5825 SvFLAGS(sv) |= SVTYPEMASK;
5827 if (sv_type_details->arena) {
5828 del_body(((char *)SvANY(sv) + sv_type_details->offset),
5829 &PL_body_roots[type]);
5831 else if (sv_type_details->body_size) {
5832 my_safefree(SvANY(sv));
5837 =for apidoc sv_newref
5839 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5846 Perl_sv_newref(pTHX_ SV *const sv)
5848 PERL_UNUSED_CONTEXT;
5857 Decrement an SV's reference count, and if it drops to zero, call
5858 C<sv_clear> to invoke destructors and free up any memory used by
5859 the body; finally, deallocate the SV's head itself.
5860 Normally called via a wrapper macro C<SvREFCNT_dec>.
5866 Perl_sv_free(pTHX_ SV *const sv)
5871 if (SvREFCNT(sv) == 0) {
5872 if (SvFLAGS(sv) & SVf_BREAK)
5873 /* this SV's refcnt has been artificially decremented to
5874 * trigger cleanup */
5876 if (PL_in_clean_all) /* All is fair */
5878 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5879 /* make sure SvREFCNT(sv)==0 happens very seldom */
5880 SvREFCNT(sv) = (~(U32)0)/2;
5883 if (ckWARN_d(WARN_INTERNAL)) {
5884 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5885 Perl_dump_sv_child(aTHX_ sv);
5887 #ifdef DEBUG_LEAKING_SCALARS
5890 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5891 if (PL_warnhook == PERL_WARNHOOK_FATAL
5892 || ckDEAD(packWARN(WARN_INTERNAL))) {
5893 /* Don't let Perl_warner cause us to escape our fate: */
5897 /* This may not return: */
5898 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5899 "Attempt to free unreferenced scalar: SV 0x%"UVxf
5900 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5903 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5908 if (--(SvREFCNT(sv)) > 0)
5910 Perl_sv_free2(aTHX_ sv);
5914 Perl_sv_free2(pTHX_ SV *const sv)
5918 PERL_ARGS_ASSERT_SV_FREE2;
5922 if (ckWARN_d(WARN_DEBUGGING))
5923 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5924 "Attempt to free temp prematurely: SV 0x%"UVxf
5925 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5929 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5930 /* make sure SvREFCNT(sv)==0 happens very seldom */
5931 SvREFCNT(sv) = (~(U32)0)/2;
5942 Returns the length of the string in the SV. Handles magic and type
5943 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5949 Perl_sv_len(pTHX_ register SV *const sv)
5957 len = mg_length(sv);
5959 (void)SvPV_const(sv, len);
5964 =for apidoc sv_len_utf8
5966 Returns the number of characters in the string in an SV, counting wide
5967 UTF-8 bytes as a single character. Handles magic and type coercion.
5973 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
5974 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
5975 * (Note that the mg_len is not the length of the mg_ptr field.
5976 * This allows the cache to store the character length of the string without
5977 * needing to malloc() extra storage to attach to the mg_ptr.)
5982 Perl_sv_len_utf8(pTHX_ register SV *const sv)
5988 return mg_length(sv);
5992 const U8 *s = (U8*)SvPV_const(sv, len);
5996 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
5998 if (mg && mg->mg_len != -1) {
6000 if (PL_utf8cache < 0) {
6001 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6003 /* Need to turn the assertions off otherwise we may
6004 recurse infinitely while printing error messages.
6006 SAVEI8(PL_utf8cache);
6008 Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
6009 " real %"UVuf" for %"SVf,
6010 (UV) ulen, (UV) real, SVfARG(sv));
6015 ulen = Perl_utf8_length(aTHX_ s, s + len);
6016 if (!SvREADONLY(sv)) {
6018 mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
6019 &PL_vtbl_utf8, 0, 0);
6027 return Perl_utf8_length(aTHX_ s, s + len);
6031 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6034 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6037 const U8 *s = start;
6039 PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6041 while (s < send && uoffset--)
6044 /* This is the existing behaviour. Possibly it should be a croak, as
6045 it's actually a bounds error */
6051 /* Given the length of the string in both bytes and UTF-8 characters, decide
6052 whether to walk forwards or backwards to find the byte corresponding to
6053 the passed in UTF-8 offset. */
6055 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6056 const STRLEN uoffset, const STRLEN uend)
6058 STRLEN backw = uend - uoffset;
6060 PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6062 if (uoffset < 2 * backw) {
6063 /* The assumption is that going forwards is twice the speed of going
6064 forward (that's where the 2 * backw comes from).
6065 (The real figure of course depends on the UTF-8 data.) */
6066 return sv_pos_u2b_forwards(start, send, uoffset);
6071 while (UTF8_IS_CONTINUATION(*send))
6074 return send - start;
6077 /* For the string representation of the given scalar, find the byte
6078 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
6079 give another position in the string, *before* the sought offset, which
6080 (which is always true, as 0, 0 is a valid pair of positions), which should
6081 help reduce the amount of linear searching.
6082 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6083 will be used to reduce the amount of linear searching. The cache will be
6084 created if necessary, and the found value offered to it for update. */
6086 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6087 const U8 *const send, const STRLEN uoffset,
6088 STRLEN uoffset0, STRLEN boffset0)
6090 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
6093 PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6095 assert (uoffset >= uoffset0);
6097 if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
6098 && (*mgp || (*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6099 if ((*mgp)->mg_ptr) {
6100 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6101 if (cache[0] == uoffset) {
6102 /* An exact match. */
6105 if (cache[2] == uoffset) {
6106 /* An exact match. */
6110 if (cache[0] < uoffset) {
6111 /* The cache already knows part of the way. */
6112 if (cache[0] > uoffset0) {
6113 /* The cache knows more than the passed in pair */
6114 uoffset0 = cache[0];
6115 boffset0 = cache[1];
6117 if ((*mgp)->mg_len != -1) {
6118 /* And we know the end too. */
6120 + sv_pos_u2b_midway(start + boffset0, send,
6122 (*mgp)->mg_len - uoffset0);
6125 + sv_pos_u2b_forwards(start + boffset0,
6126 send, uoffset - uoffset0);
6129 else if (cache[2] < uoffset) {
6130 /* We're between the two cache entries. */
6131 if (cache[2] > uoffset0) {
6132 /* and the cache knows more than the passed in pair */
6133 uoffset0 = cache[2];
6134 boffset0 = cache[3];
6138 + sv_pos_u2b_midway(start + boffset0,
6141 cache[0] - uoffset0);
6144 + sv_pos_u2b_midway(start + boffset0,
6147 cache[2] - uoffset0);
6151 else if ((*mgp)->mg_len != -1) {
6152 /* If we can take advantage of a passed in offset, do so. */
6153 /* In fact, offset0 is either 0, or less than offset, so don't
6154 need to worry about the other possibility. */
6156 + sv_pos_u2b_midway(start + boffset0, send,
6158 (*mgp)->mg_len - uoffset0);
6163 if (!found || PL_utf8cache < 0) {
6164 const STRLEN real_boffset
6165 = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6166 send, uoffset - uoffset0);
6168 if (found && PL_utf8cache < 0) {
6169 if (real_boffset != boffset) {
6170 /* Need to turn the assertions off otherwise we may recurse
6171 infinitely while printing error messages. */
6172 SAVEI8(PL_utf8cache);
6174 Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
6175 " real %"UVuf" for %"SVf,
6176 (UV) boffset, (UV) real_boffset, SVfARG(sv));
6179 boffset = real_boffset;
6183 utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6189 =for apidoc sv_pos_u2b
6191 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6192 the start of the string, to a count of the equivalent number of bytes; if
6193 lenp is non-zero, it does the same to lenp, but this time starting from
6194 the offset, rather than from the start of the string. Handles magic and
6201 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6202 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6203 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6208 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6213 PERL_ARGS_ASSERT_SV_POS_U2B;
6218 start = (U8*)SvPV_const(sv, len);
6220 STRLEN uoffset = (STRLEN) *offsetp;
6221 const U8 * const send = start + len;
6223 const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send,
6226 *offsetp = (I32) boffset;
6229 /* Convert the relative offset to absolute. */
6230 const STRLEN uoffset2 = uoffset + (STRLEN) *lenp;
6231 const STRLEN boffset2
6232 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6233 uoffset, boffset) - boffset;
6247 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6248 byte length pairing. The (byte) length of the total SV is passed in too,
6249 as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6250 may not have updated SvCUR, so we can't rely on reading it directly.
6252 The proffered utf8/byte length pairing isn't used if the cache already has
6253 two pairs, and swapping either for the proffered pair would increase the
6254 RMS of the intervals between known byte offsets.
6256 The cache itself consists of 4 STRLEN values
6257 0: larger UTF-8 offset
6258 1: corresponding byte offset
6259 2: smaller UTF-8 offset
6260 3: corresponding byte offset
6262 Unused cache pairs have the value 0, 0.
6263 Keeping the cache "backwards" means that the invariant of
6264 cache[0] >= cache[2] is maintained even with empty slots, which means that
6265 the code that uses it doesn't need to worry if only 1 entry has actually
6266 been set to non-zero. It also makes the "position beyond the end of the
6267 cache" logic much simpler, as the first slot is always the one to start
6271 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6272 const STRLEN utf8, const STRLEN blen)
6276 PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6282 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6284 (*mgp)->mg_len = -1;
6288 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6289 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6290 (*mgp)->mg_ptr = (char *) cache;
6294 if (PL_utf8cache < 0) {
6295 const U8 *start = (const U8 *) SvPVX_const(sv);
6296 const STRLEN realutf8 = utf8_length(start, start + byte);
6298 if (realutf8 != utf8) {
6299 /* Need to turn the assertions off otherwise we may recurse
6300 infinitely while printing error messages. */
6301 SAVEI8(PL_utf8cache);
6303 Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
6304 " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
6308 /* Cache is held with the later position first, to simplify the code
6309 that deals with unbounded ends. */
6311 ASSERT_UTF8_CACHE(cache);
6312 if (cache[1] == 0) {
6313 /* Cache is totally empty */
6316 } else if (cache[3] == 0) {
6317 if (byte > cache[1]) {
6318 /* New one is larger, so goes first. */
6319 cache[2] = cache[0];
6320 cache[3] = cache[1];
6328 #define THREEWAY_SQUARE(a,b,c,d) \
6329 ((float)((d) - (c))) * ((float)((d) - (c))) \
6330 + ((float)((c) - (b))) * ((float)((c) - (b))) \
6331 + ((float)((b) - (a))) * ((float)((b) - (a)))
6333 /* Cache has 2 slots in use, and we know three potential pairs.
6334 Keep the two that give the lowest RMS distance. Do the
6335 calcualation in bytes simply because we always know the byte
6336 length. squareroot has the same ordering as the positive value,
6337 so don't bother with the actual square root. */
6338 const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6339 if (byte > cache[1]) {
6340 /* New position is after the existing pair of pairs. */
6341 const float keep_earlier
6342 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6343 const float keep_later
6344 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6346 if (keep_later < keep_earlier) {
6347 if (keep_later < existing) {
6348 cache[2] = cache[0];
6349 cache[3] = cache[1];
6355 if (keep_earlier < existing) {
6361 else if (byte > cache[3]) {
6362 /* New position is between the existing pair of pairs. */
6363 const float keep_earlier
6364 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6365 const float keep_later
6366 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6368 if (keep_later < keep_earlier) {
6369 if (keep_later < existing) {
6375 if (keep_earlier < existing) {
6382 /* New position is before the existing pair of pairs. */
6383 const float keep_earlier
6384 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6385 const float keep_later
6386 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6388 if (keep_later < keep_earlier) {
6389 if (keep_later < existing) {
6395 if (keep_earlier < existing) {
6396 cache[0] = cache[2];
6397 cache[1] = cache[3];
6404 ASSERT_UTF8_CACHE(cache);
6407 /* We already know all of the way, now we may be able to walk back. The same
6408 assumption is made as in S_sv_pos_u2b_midway(), namely that walking
6409 backward is half the speed of walking forward. */
6411 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
6412 const U8 *end, STRLEN endu)
6414 const STRLEN forw = target - s;
6415 STRLEN backw = end - target;
6417 PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
6419 if (forw < 2 * backw) {
6420 return utf8_length(s, target);
6423 while (end > target) {
6425 while (UTF8_IS_CONTINUATION(*end)) {
6434 =for apidoc sv_pos_b2u
6436 Converts the value pointed to by offsetp from a count of bytes from the
6437 start of the string, to a count of the equivalent number of UTF-8 chars.
6438 Handles magic and type coercion.
6444 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6445 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6450 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
6453 const STRLEN byte = *offsetp;
6454 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
6460 PERL_ARGS_ASSERT_SV_POS_B2U;
6465 s = (const U8*)SvPV_const(sv, blen);
6468 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6472 if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
6473 && (mg = mg_find(sv, PERL_MAGIC_utf8))) {
6475 STRLEN * const cache = (STRLEN *) mg->mg_ptr;
6476 if (cache[1] == byte) {
6477 /* An exact match. */
6478 *offsetp = cache[0];
6481 if (cache[3] == byte) {
6482 /* An exact match. */
6483 *offsetp = cache[2];
6487 if (cache[1] < byte) {
6488 /* We already know part of the way. */
6489 if (mg->mg_len != -1) {
6490 /* Actually, we know the end too. */
6492 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
6493 s + blen, mg->mg_len - cache[0]);
6495 len = cache[0] + utf8_length(s + cache[1], send);
6498 else if (cache[3] < byte) {
6499 /* We're between the two cached pairs, so we do the calculation
6500 offset by the byte/utf-8 positions for the earlier pair,
6501 then add the utf-8 characters from the string start to
6503 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
6504 s + cache[1], cache[0] - cache[2])
6508 else { /* cache[3] > byte */
6509 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
6513 ASSERT_UTF8_CACHE(cache);
6515 } else if (mg->mg_len != -1) {
6516 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
6520 if (!found || PL_utf8cache < 0) {
6521 const STRLEN real_len = utf8_length(s, send);
6523 if (found && PL_utf8cache < 0) {
6524 if (len != real_len) {
6525 /* Need to turn the assertions off otherwise we may recurse
6526 infinitely while printing error messages. */
6527 SAVEI8(PL_utf8cache);
6529 Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
6530 " real %"UVuf" for %"SVf,
6531 (UV) len, (UV) real_len, SVfARG(sv));
6539 utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
6545 Returns a boolean indicating whether the strings in the two SVs are
6546 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6547 coerce its args to strings if necessary.
6553 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6562 SV* svrecode = NULL;
6569 /* if pv1 and pv2 are the same, second SvPV_const call may
6570 * invalidate pv1, so we may need to make a copy */
6571 if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
6572 pv1 = SvPV_const(sv1, cur1);
6573 sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
6575 pv1 = SvPV_const(sv1, cur1);
6583 pv2 = SvPV_const(sv2, cur2);
6585 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6586 /* Differing utf8ness.
6587 * Do not UTF8size the comparands as a side-effect. */
6590 svrecode = newSVpvn(pv2, cur2);
6591 sv_recode_to_utf8(svrecode, PL_encoding);
6592 pv2 = SvPV_const(svrecode, cur2);
6595 svrecode = newSVpvn(pv1, cur1);
6596 sv_recode_to_utf8(svrecode, PL_encoding);
6597 pv1 = SvPV_const(svrecode, cur1);
6599 /* Now both are in UTF-8. */
6601 SvREFCNT_dec(svrecode);
6606 bool is_utf8 = TRUE;
6609 /* sv1 is the UTF-8 one,
6610 * if is equal it must be downgrade-able */
6611 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6617 /* sv2 is the UTF-8 one,
6618 * if is equal it must be downgrade-able */
6619 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6625 /* Downgrade not possible - cannot be eq */
6633 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6635 SvREFCNT_dec(svrecode);
6645 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6646 string in C<sv1> is less than, equal to, or greater than the string in
6647 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6648 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6654 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
6658 const char *pv1, *pv2;
6661 SV *svrecode = NULL;
6668 pv1 = SvPV_const(sv1, cur1);
6675 pv2 = SvPV_const(sv2, cur2);
6677 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6678 /* Differing utf8ness.
6679 * Do not UTF8size the comparands as a side-effect. */
6682 svrecode = newSVpvn(pv2, cur2);
6683 sv_recode_to_utf8(svrecode, PL_encoding);
6684 pv2 = SvPV_const(svrecode, cur2);
6687 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6692 svrecode = newSVpvn(pv1, cur1);
6693 sv_recode_to_utf8(svrecode, PL_encoding);
6694 pv1 = SvPV_const(svrecode, cur1);
6697 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6703 cmp = cur2 ? -1 : 0;
6707 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6710 cmp = retval < 0 ? -1 : 1;
6711 } else if (cur1 == cur2) {
6714 cmp = cur1 < cur2 ? -1 : 1;
6718 SvREFCNT_dec(svrecode);
6726 =for apidoc sv_cmp_locale
6728 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6729 'use bytes' aware, handles get magic, and will coerce its args to strings
6730 if necessary. See also C<sv_cmp>.
6736 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
6739 #ifdef USE_LOCALE_COLLATE
6745 if (PL_collation_standard)
6749 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6751 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6753 if (!pv1 || !len1) {
6764 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6767 return retval < 0 ? -1 : 1;
6770 * When the result of collation is equality, that doesn't mean
6771 * that there are no differences -- some locales exclude some
6772 * characters from consideration. So to avoid false equalities,
6773 * we use the raw string as a tiebreaker.
6779 #endif /* USE_LOCALE_COLLATE */
6781 return sv_cmp(sv1, sv2);
6785 #ifdef USE_LOCALE_COLLATE
6788 =for apidoc sv_collxfrm
6790 Add Collate Transform magic to an SV if it doesn't already have it.
6792 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6793 scalar data of the variable, but transformed to such a format that a normal
6794 memory comparison can be used to compare the data according to the locale
6801 Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
6806 PERL_ARGS_ASSERT_SV_COLLXFRM;
6808 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6809 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6815 Safefree(mg->mg_ptr);
6816 s = SvPV_const(sv, len);
6817 if ((xf = mem_collxfrm(s, len, &xlen))) {
6819 #ifdef PERL_OLD_COPY_ON_WRITE
6821 sv_force_normal_flags(sv, 0);
6823 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
6837 if (mg && mg->mg_ptr) {
6839 return mg->mg_ptr + sizeof(PL_collation_ix);
6847 #endif /* USE_LOCALE_COLLATE */
6852 Get a line from the filehandle and store it into the SV, optionally
6853 appending to the currently-stored string.
6859 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
6864 register STDCHAR rslast;
6865 register STDCHAR *bp;
6870 PERL_ARGS_ASSERT_SV_GETS;
6872 if (SvTHINKFIRST(sv))
6873 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6874 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6876 However, perlbench says it's slower, because the existing swipe code
6877 is faster than copy on write.
6878 Swings and roundabouts. */
6879 SvUPGRADE(sv, SVt_PV);
6884 if (PerlIO_isutf8(fp)) {
6886 sv_utf8_upgrade_nomg(sv);
6887 sv_pos_u2b(sv,&append,0);
6889 } else if (SvUTF8(sv)) {
6890 SV * const tsv = newSV(0);
6891 sv_gets(tsv, fp, 0);
6892 sv_utf8_upgrade_nomg(tsv);
6893 SvCUR_set(sv,append);
6896 goto return_string_or_null;
6901 if (PerlIO_isutf8(fp))
6904 if (IN_PERL_COMPILETIME) {
6905 /* we always read code in line mode */
6909 else if (RsSNARF(PL_rs)) {
6910 /* If it is a regular disk file use size from stat() as estimate
6911 of amount we are going to read -- may result in mallocing
6912 more memory than we really need if the layers below reduce
6913 the size we read (e.g. CRLF or a gzip layer).
6916 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6917 const Off_t offset = PerlIO_tell(fp);
6918 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6919 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6925 else if (RsRECORD(PL_rs)) {
6933 /* Grab the size of the record we're getting */
6934 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
6935 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6938 /* VMS wants read instead of fread, because fread doesn't respect */
6939 /* RMS record boundaries. This is not necessarily a good thing to be */
6940 /* doing, but we've got no other real choice - except avoid stdio
6941 as implementation - perhaps write a :vms layer ?
6943 fd = PerlIO_fileno(fp);
6944 if (fd == -1) { /* in-memory file from PerlIO::Scalar */
6945 bytesread = PerlIO_read(fp, buffer, recsize);
6948 bytesread = PerlLIO_read(fd, buffer, recsize);
6951 bytesread = PerlIO_read(fp, buffer, recsize);
6955 SvCUR_set(sv, bytesread + append);
6956 buffer[bytesread] = '\0';
6957 goto return_string_or_null;
6959 else if (RsPARA(PL_rs)) {
6965 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6966 if (PerlIO_isutf8(fp)) {
6967 rsptr = SvPVutf8(PL_rs, rslen);
6970 if (SvUTF8(PL_rs)) {
6971 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6972 Perl_croak(aTHX_ "Wide character in $/");
6975 rsptr = SvPV_const(PL_rs, rslen);
6979 rslast = rslen ? rsptr[rslen - 1] : '\0';
6981 if (rspara) { /* have to do this both before and after */
6982 do { /* to make sure file boundaries work right */
6985 i = PerlIO_getc(fp);
6989 PerlIO_ungetc(fp,i);
6995 /* See if we know enough about I/O mechanism to cheat it ! */
6997 /* This used to be #ifdef test - it is made run-time test for ease
6998 of abstracting out stdio interface. One call should be cheap
6999 enough here - and may even be a macro allowing compile
7003 if (PerlIO_fast_gets(fp)) {
7006 * We're going to steal some values from the stdio struct
7007 * and put EVERYTHING in the innermost loop into registers.
7009 register STDCHAR *ptr;
7013 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7014 /* An ungetc()d char is handled separately from the regular
7015 * buffer, so we getc() it back out and stuff it in the buffer.
7017 i = PerlIO_getc(fp);
7018 if (i == EOF) return 0;
7019 *(--((*fp)->_ptr)) = (unsigned char) i;
7023 /* Here is some breathtakingly efficient cheating */
7025 cnt = PerlIO_get_cnt(fp); /* get count into register */
7026 /* make sure we have the room */
7027 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7028 /* Not room for all of it
7029 if we are looking for a separator and room for some
7031 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7032 /* just process what we have room for */
7033 shortbuffered = cnt - SvLEN(sv) + append + 1;
7034 cnt -= shortbuffered;
7038 /* remember that cnt can be negative */
7039 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7044 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
7045 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7046 DEBUG_P(PerlIO_printf(Perl_debug_log,
7047 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7048 DEBUG_P(PerlIO_printf(Perl_debug_log,
7049 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7050 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7051 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7056 while (cnt > 0) { /* this | eat */
7058 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7059 goto thats_all_folks; /* screams | sed :-) */
7063 Copy(ptr, bp, cnt, char); /* this | eat */
7064 bp += cnt; /* screams | dust */
7065 ptr += cnt; /* louder | sed :-) */
7070 if (shortbuffered) { /* oh well, must extend */
7071 cnt = shortbuffered;
7073 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7075 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7076 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7080 DEBUG_P(PerlIO_printf(Perl_debug_log,
7081 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7082 PTR2UV(ptr),(long)cnt));
7083 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7085 DEBUG_P(PerlIO_printf(Perl_debug_log,
7086 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7087 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7088 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7090 /* This used to call 'filbuf' in stdio form, but as that behaves like
7091 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7092 another abstraction. */
7093 i = PerlIO_getc(fp); /* get more characters */
7095 DEBUG_P(PerlIO_printf(Perl_debug_log,
7096 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7097 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7098 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7100 cnt = PerlIO_get_cnt(fp);
7101 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7102 DEBUG_P(PerlIO_printf(Perl_debug_log,
7103 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7105 if (i == EOF) /* all done for ever? */
7106 goto thats_really_all_folks;
7108 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7110 SvGROW(sv, bpx + cnt + 2);
7111 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7113 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7115 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7116 goto thats_all_folks;
7120 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7121 memNE((char*)bp - rslen, rsptr, rslen))
7122 goto screamer; /* go back to the fray */
7123 thats_really_all_folks:
7125 cnt += shortbuffered;
7126 DEBUG_P(PerlIO_printf(Perl_debug_log,
7127 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7128 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7129 DEBUG_P(PerlIO_printf(Perl_debug_log,
7130 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7131 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7132 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7134 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
7135 DEBUG_P(PerlIO_printf(Perl_debug_log,
7136 "Screamer: done, len=%ld, string=|%.*s|\n",
7137 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7141 /*The big, slow, and stupid way. */
7142 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
7143 STDCHAR *buf = NULL;
7144 Newx(buf, 8192, STDCHAR);
7152 register const STDCHAR * const bpe = buf + sizeof(buf);
7154 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7155 ; /* keep reading */
7159 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7160 /* Accomodate broken VAXC compiler, which applies U8 cast to
7161 * both args of ?: operator, causing EOF to change into 255
7164 i = (U8)buf[cnt - 1];
7170 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7172 sv_catpvn(sv, (char *) buf, cnt);
7174 sv_setpvn(sv, (char *) buf, cnt);
7176 if (i != EOF && /* joy */
7178 SvCUR(sv) < rslen ||
7179 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7183 * If we're reading from a TTY and we get a short read,
7184 * indicating that the user hit his EOF character, we need
7185 * to notice it now, because if we try to read from the TTY
7186 * again, the EOF condition will disappear.
7188 * The comparison of cnt to sizeof(buf) is an optimization
7189 * that prevents unnecessary calls to feof().
7193 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7197 #ifdef USE_HEAP_INSTEAD_OF_STACK
7202 if (rspara) { /* have to do this both before and after */
7203 while (i != EOF) { /* to make sure file boundaries work right */
7204 i = PerlIO_getc(fp);
7206 PerlIO_ungetc(fp,i);
7212 return_string_or_null:
7213 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7219 Auto-increment of the value in the SV, doing string to numeric conversion
7220 if necessary. Handles 'get' magic.
7226 Perl_sv_inc(pTHX_ register SV *const sv)
7235 if (SvTHINKFIRST(sv)) {
7237 sv_force_normal_flags(sv, 0);
7238 if (SvREADONLY(sv)) {
7239 if (IN_PERL_RUNTIME)
7240 Perl_croak(aTHX_ "%s", PL_no_modify);
7244 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7246 i = PTR2IV(SvRV(sv));
7251 flags = SvFLAGS(sv);
7252 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7253 /* It's (privately or publicly) a float, but not tested as an
7254 integer, so test it to see. */
7256 flags = SvFLAGS(sv);
7258 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7259 /* It's publicly an integer, or privately an integer-not-float */
7260 #ifdef PERL_PRESERVE_IVUV
7264 if (SvUVX(sv) == UV_MAX)
7265 sv_setnv(sv, UV_MAX_P1);
7267 (void)SvIOK_only_UV(sv);
7268 SvUV_set(sv, SvUVX(sv) + 1);
7270 if (SvIVX(sv) == IV_MAX)
7271 sv_setuv(sv, (UV)IV_MAX + 1);
7273 (void)SvIOK_only(sv);
7274 SvIV_set(sv, SvIVX(sv) + 1);
7279 if (flags & SVp_NOK) {
7280 const NV was = SvNVX(sv);
7281 if (NV_OVERFLOWS_INTEGERS_AT &&
7282 was >= NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
7283 Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
7284 "Lost precision when incrementing %" NVff " by 1",
7287 (void)SvNOK_only(sv);
7288 SvNV_set(sv, was + 1.0);
7292 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7293 if ((flags & SVTYPEMASK) < SVt_PVIV)
7294 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
7295 (void)SvIOK_only(sv);
7300 while (isALPHA(*d)) d++;
7301 while (isDIGIT(*d)) d++;
7303 #ifdef PERL_PRESERVE_IVUV
7304 /* Got to punt this as an integer if needs be, but we don't issue
7305 warnings. Probably ought to make the sv_iv_please() that does
7306 the conversion if possible, and silently. */
7307 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7308 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7309 /* Need to try really hard to see if it's an integer.
7310 9.22337203685478e+18 is an integer.
7311 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7312 so $a="9.22337203685478e+18"; $a+0; $a++
7313 needs to be the same as $a="9.22337203685478e+18"; $a++
7320 /* sv_2iv *should* have made this an NV */
7321 if (flags & SVp_NOK) {
7322 (void)SvNOK_only(sv);
7323 SvNV_set(sv, SvNVX(sv) + 1.0);
7326 /* I don't think we can get here. Maybe I should assert this
7327 And if we do get here I suspect that sv_setnv will croak. NWC
7329 #if defined(USE_LONG_DOUBLE)
7330 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",
7331 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7333 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7334 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7337 #endif /* PERL_PRESERVE_IVUV */
7338 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7342 while (d >= SvPVX_const(sv)) {
7350 /* MKS: The original code here died if letters weren't consecutive.
7351 * at least it didn't have to worry about non-C locales. The
7352 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7353 * arranged in order (although not consecutively) and that only
7354 * [A-Za-z] are accepted by isALPHA in the C locale.
7356 if (*d != 'z' && *d != 'Z') {
7357 do { ++*d; } while (!isALPHA(*d));
7360 *(d--) -= 'z' - 'a';
7365 *(d--) -= 'z' - 'a' + 1;
7369 /* oh,oh, the number grew */
7370 SvGROW(sv, SvCUR(sv) + 2);
7371 SvCUR_set(sv, SvCUR(sv) + 1);
7372 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7383 Auto-decrement of the value in the SV, doing string to numeric conversion
7384 if necessary. Handles 'get' magic.
7390 Perl_sv_dec(pTHX_ register SV *const sv)
7398 if (SvTHINKFIRST(sv)) {
7400 sv_force_normal_flags(sv, 0);
7401 if (SvREADONLY(sv)) {
7402 if (IN_PERL_RUNTIME)
7403 Perl_croak(aTHX_ "%s", PL_no_modify);
7407 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7409 i = PTR2IV(SvRV(sv));
7414 /* Unlike sv_inc we don't have to worry about string-never-numbers
7415 and keeping them magic. But we mustn't warn on punting */
7416 flags = SvFLAGS(sv);
7417 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7418 /* It's publicly an integer, or privately an integer-not-float */
7419 #ifdef PERL_PRESERVE_IVUV
7423 if (SvUVX(sv) == 0) {
7424 (void)SvIOK_only(sv);
7428 (void)SvIOK_only_UV(sv);
7429 SvUV_set(sv, SvUVX(sv) - 1);
7432 if (SvIVX(sv) == IV_MIN) {
7433 sv_setnv(sv, (NV)IV_MIN);
7437 (void)SvIOK_only(sv);
7438 SvIV_set(sv, SvIVX(sv) - 1);
7443 if (flags & SVp_NOK) {
7446 const NV was = SvNVX(sv);
7447 if (NV_OVERFLOWS_INTEGERS_AT &&
7448 was <= -NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
7449 Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
7450 "Lost precision when decrementing %" NVff " by 1",
7453 (void)SvNOK_only(sv);
7454 SvNV_set(sv, was - 1.0);
7458 if (!(flags & SVp_POK)) {
7459 if ((flags & SVTYPEMASK) < SVt_PVIV)
7460 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
7462 (void)SvIOK_only(sv);
7465 #ifdef PERL_PRESERVE_IVUV
7467 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7468 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7469 /* Need to try really hard to see if it's an integer.
7470 9.22337203685478e+18 is an integer.
7471 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7472 so $a="9.22337203685478e+18"; $a+0; $a--
7473 needs to be the same as $a="9.22337203685478e+18"; $a--
7480 /* sv_2iv *should* have made this an NV */
7481 if (flags & SVp_NOK) {
7482 (void)SvNOK_only(sv);
7483 SvNV_set(sv, SvNVX(sv) - 1.0);
7486 /* I don't think we can get here. Maybe I should assert this
7487 And if we do get here I suspect that sv_setnv will croak. NWC
7489 #if defined(USE_LONG_DOUBLE)
7490 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",
7491 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7493 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7494 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7498 #endif /* PERL_PRESERVE_IVUV */
7499 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
7503 =for apidoc sv_mortalcopy
7505 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7506 The new SV is marked as mortal. It will be destroyed "soon", either by an
7507 explicit call to FREETMPS, or by an implicit call at places such as
7508 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7513 /* Make a string that will exist for the duration of the expression
7514 * evaluation. Actually, it may have to last longer than that, but
7515 * hopefully we won't free it until it has been assigned to a
7516 * permanent location. */
7519 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
7525 sv_setsv(sv,oldstr);
7527 PL_tmps_stack[++PL_tmps_ix] = sv;
7533 =for apidoc sv_newmortal
7535 Creates a new null SV which is mortal. The reference count of the SV is
7536 set to 1. It will be destroyed "soon", either by an explicit call to
7537 FREETMPS, or by an implicit call at places such as statement boundaries.
7538 See also C<sv_mortalcopy> and C<sv_2mortal>.
7544 Perl_sv_newmortal(pTHX)
7550 SvFLAGS(sv) = SVs_TEMP;
7552 PL_tmps_stack[++PL_tmps_ix] = sv;
7558 =for apidoc newSVpvn_flags
7560 Creates a new SV and copies a string into it. The reference count for the
7561 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7562 string. You are responsible for ensuring that the source string is at least
7563 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7564 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
7565 If C<SVs_TEMP> is set, then C<sv2mortal()> is called on the result before
7566 returning. If C<SVf_UTF8> is set, then it will be set on the new SV.
7567 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
7569 #define newSVpvn_utf8(s, len, u) \
7570 newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
7576 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
7581 /* All the flags we don't support must be zero.
7582 And we're new code so I'm going to assert this from the start. */
7583 assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
7585 sv_setpvn(sv,s,len);
7586 SvFLAGS(sv) |= (flags & SVf_UTF8);
7587 return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv;
7591 =for apidoc sv_2mortal
7593 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7594 by an explicit call to FREETMPS, or by an implicit call at places such as
7595 statement boundaries. SvTEMP() is turned on which means that the SV's
7596 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7597 and C<sv_mortalcopy>.
7603 Perl_sv_2mortal(pTHX_ register SV *const sv)
7608 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7611 PL_tmps_stack[++PL_tmps_ix] = sv;
7619 Creates a new SV and copies a string into it. The reference count for the
7620 SV is set to 1. If C<len> is zero, Perl will compute the length using
7621 strlen(). For efficiency, consider using C<newSVpvn> instead.
7627 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
7633 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
7638 =for apidoc newSVpvn
7640 Creates a new SV and copies a string into it. The reference count for the
7641 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7642 string. You are responsible for ensuring that the source string is at least
7643 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7649 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
7655 sv_setpvn(sv,s,len);
7660 =for apidoc newSVhek
7662 Creates a new SV from the hash key structure. It will generate scalars that
7663 point to the shared string table where possible. Returns a new (undefined)
7664 SV if the hek is NULL.
7670 Perl_newSVhek(pTHX_ const HEK *const hek)
7680 if (HEK_LEN(hek) == HEf_SVKEY) {
7681 return newSVsv(*(SV**)HEK_KEY(hek));
7683 const int flags = HEK_FLAGS(hek);
7684 if (flags & HVhek_WASUTF8) {
7686 Andreas would like keys he put in as utf8 to come back as utf8
7688 STRLEN utf8_len = HEK_LEN(hek);
7689 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7690 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7693 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7695 } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
7696 /* We don't have a pointer to the hv, so we have to replicate the
7697 flag into every HEK. This hv is using custom a hasing
7698 algorithm. Hence we can't return a shared string scalar, as
7699 that would contain the (wrong) hash value, and might get passed
7700 into an hv routine with a regular hash.
7701 Similarly, a hash that isn't using shared hash keys has to have
7702 the flag in every key so that we know not to try to call
7703 share_hek_kek on it. */
7705 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7710 /* This will be overwhelminly the most common case. */
7712 /* Inline most of newSVpvn_share(), because share_hek_hek() is far
7713 more efficient than sharepvn(). */
7717 sv_upgrade(sv, SVt_PV);
7718 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
7719 SvCUR_set(sv, HEK_LEN(hek));
7732 =for apidoc newSVpvn_share
7734 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7735 table. If the string does not already exist in the table, it is created
7736 first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
7737 value is used; otherwise the hash is computed. The string's hash can be later
7738 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
7739 that as the string table is used for shared hash keys these strings will have
7740 SvPVX_const == HeKEY and hash lookup will avoid string compare.
7746 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7750 bool is_utf8 = FALSE;
7751 const char *const orig_src = src;
7754 STRLEN tmplen = -len;
7756 /* See the note in hv.c:hv_fetch() --jhi */
7757 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7761 PERL_HASH(hash, src, len);
7763 /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
7764 changes here, update it there too. */
7765 sv_upgrade(sv, SVt_PV);
7766 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7774 if (src != orig_src)
7780 #if defined(PERL_IMPLICIT_CONTEXT)
7782 /* pTHX_ magic can't cope with varargs, so this is a no-context
7783 * version of the main function, (which may itself be aliased to us).
7784 * Don't access this version directly.
7788 Perl_newSVpvf_nocontext(const char *const pat, ...)
7794 PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
7796 va_start(args, pat);
7797 sv = vnewSVpvf(pat, &args);
7804 =for apidoc newSVpvf
7806 Creates a new SV and initializes it with the string formatted like
7813 Perl_newSVpvf(pTHX_ const char *const pat, ...)
7818 PERL_ARGS_ASSERT_NEWSVPVF;
7820 va_start(args, pat);
7821 sv = vnewSVpvf(pat, &args);
7826 /* backend for newSVpvf() and newSVpvf_nocontext() */
7829 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
7834 PERL_ARGS_ASSERT_VNEWSVPVF;
7837 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7844 Creates a new SV and copies a floating point value into it.
7845 The reference count for the SV is set to 1.
7851 Perl_newSVnv(pTHX_ const NV n)
7864 Creates a new SV and copies an integer into it. The reference count for the
7871 Perl_newSViv(pTHX_ const IV i)
7884 Creates a new SV and copies an unsigned integer into it.
7885 The reference count for the SV is set to 1.
7891 Perl_newSVuv(pTHX_ const UV u)
7902 =for apidoc newSV_type
7904 Creates a new SV, of the type specified. The reference count for the new SV
7911 Perl_newSV_type(pTHX_ const svtype type)
7916 sv_upgrade(sv, type);
7921 =for apidoc newRV_noinc
7923 Creates an RV wrapper for an SV. The reference count for the original
7924 SV is B<not> incremented.
7930 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
7933 register SV *sv = newSV_type(SVt_IV);
7935 PERL_ARGS_ASSERT_NEWRV_NOINC;
7938 SvRV_set(sv, tmpRef);
7943 /* newRV_inc is the official function name to use now.
7944 * newRV_inc is in fact #defined to newRV in sv.h
7948 Perl_newRV(pTHX_ SV *const sv)
7952 PERL_ARGS_ASSERT_NEWRV;
7954 return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
7960 Creates a new SV which is an exact duplicate of the original SV.
7967 Perl_newSVsv(pTHX_ register SV *const old)
7974 if (SvTYPE(old) == SVTYPEMASK) {
7975 if (ckWARN_d(WARN_INTERNAL))
7976 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7980 /* SV_GMAGIC is the default for sv_setv()
7981 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7982 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7983 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7988 =for apidoc sv_reset
7990 Underlying implementation for the C<reset> Perl function.
7991 Note that the perl-level function is vaguely deprecated.
7997 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
8000 char todo[PERL_UCHAR_MAX+1];
8002 PERL_ARGS_ASSERT_SV_RESET;
8007 if (!*s) { /* reset ?? searches */
8008 MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
8010 const U32 count = mg->mg_len / sizeof(PMOP**);
8011 PMOP **pmp = (PMOP**) mg->mg_ptr;
8012 PMOP *const *const end = pmp + count;
8016 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
8018 (*pmp)->op_pmflags &= ~PMf_USED;
8026 /* reset variables */
8028 if (!HvARRAY(stash))
8031 Zero(todo, 256, char);
8034 I32 i = (unsigned char)*s;
8038 max = (unsigned char)*s++;
8039 for ( ; i <= max; i++) {
8042 for (i = 0; i <= (I32) HvMAX(stash); i++) {
8044 for (entry = HvARRAY(stash)[i];
8046 entry = HeNEXT(entry))
8051 if (!todo[(U8)*HeKEY(entry)])
8053 gv = MUTABLE_GV(HeVAL(entry));
8056 if (SvTHINKFIRST(sv)) {
8057 if (!SvREADONLY(sv) && SvROK(sv))
8059 /* XXX Is this continue a bug? Why should THINKFIRST
8060 exempt us from resetting arrays and hashes? */
8064 if (SvTYPE(sv) >= SVt_PV) {
8066 if (SvPVX_const(sv) != NULL)
8074 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8076 Perl_die(aTHX_ "Can't reset %%ENV on this system");
8079 # if defined(USE_ENVIRON_ARRAY)
8082 # endif /* USE_ENVIRON_ARRAY */
8093 Using various gambits, try to get an IO from an SV: the IO slot if its a
8094 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8095 named after the PV if we're a string.
8101 Perl_sv_2io(pTHX_ SV *const sv)
8106 PERL_ARGS_ASSERT_SV_2IO;
8108 switch (SvTYPE(sv)) {
8110 io = MUTABLE_IO(sv);
8113 if (isGV_with_GP(sv)) {
8114 gv = MUTABLE_GV(sv);
8117 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8123 Perl_croak(aTHX_ PL_no_usym, "filehandle");
8125 return sv_2io(SvRV(sv));
8126 gv = gv_fetchsv(sv, 0, SVt_PVIO);
8132 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
8141 Using various gambits, try to get a CV from an SV; in addition, try if
8142 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8143 The flags in C<lref> are passed to sv_fetchsv.
8149 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8155 PERL_ARGS_ASSERT_SV_2CV;
8162 switch (SvTYPE(sv)) {
8166 return MUTABLE_CV(sv);
8173 if (isGV_with_GP(sv)) {
8174 gv = MUTABLE_GV(sv);
8183 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
8185 tryAMAGICunDEREF(to_cv);
8188 if (SvTYPE(sv) == SVt_PVCV) {
8189 cv = MUTABLE_CV(sv);
8194 else if(isGV_with_GP(sv))
8195 gv = MUTABLE_GV(sv);
8197 Perl_croak(aTHX_ "Not a subroutine reference");
8199 else if (isGV_with_GP(sv)) {
8201 gv = MUTABLE_GV(sv);
8204 gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
8210 /* Some flags to gv_fetchsv mean don't really create the GV */
8211 if (!isGV_with_GP(gv)) {
8217 if (lref && !GvCVu(gv)) {
8221 gv_efullname3(tmpsv, gv, NULL);
8222 /* XXX this is probably not what they think they're getting.
8223 * It has the same effect as "sub name;", i.e. just a forward
8225 newSUB(start_subparse(FALSE, 0),
8226 newSVOP(OP_CONST, 0, tmpsv),
8230 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8231 SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8240 Returns true if the SV has a true value by Perl's rules.
8241 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8242 instead use an in-line version.
8248 Perl_sv_true(pTHX_ register SV *const sv)
8253 register const XPV* const tXpv = (XPV*)SvANY(sv);
8255 (tXpv->xpv_cur > 1 ||
8256 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
8263 return SvIVX(sv) != 0;
8266 return SvNVX(sv) != 0.0;
8268 return sv_2bool(sv);
8274 =for apidoc sv_pvn_force
8276 Get a sensible string out of the SV somehow.
8277 A private implementation of the C<SvPV_force> macro for compilers which
8278 can't cope with complex macro expressions. Always use the macro instead.
8280 =for apidoc sv_pvn_force_flags
8282 Get a sensible string out of the SV somehow.
8283 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8284 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8285 implemented in terms of this function.
8286 You normally want to use the various wrapper macros instead: see
8287 C<SvPV_force> and C<SvPV_force_nomg>
8293 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
8297 PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
8299 if (SvTHINKFIRST(sv) && !SvROK(sv))
8300 sv_force_normal_flags(sv, 0);
8310 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8311 const char * const ref = sv_reftype(sv,0);
8313 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8314 ref, OP_NAME(PL_op));
8316 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
8318 if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
8319 || isGV_with_GP(sv))
8320 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8322 s = sv_2pv_flags(sv, &len, flags);
8326 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
8329 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8330 SvGROW(sv, len + 1);
8331 Move(s,SvPVX(sv),len,char);
8333 SvPVX(sv)[len] = '\0';
8336 SvPOK_on(sv); /* validate pointer */
8338 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8339 PTR2UV(sv),SvPVX_const(sv)));
8342 return SvPVX_mutable(sv);
8346 =for apidoc sv_pvbyten_force
8348 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
8354 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
8356 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
8358 sv_pvn_force(sv,lp);
8359 sv_utf8_downgrade(sv,0);
8365 =for apidoc sv_pvutf8n_force
8367 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
8373 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
8375 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
8377 sv_pvn_force(sv,lp);
8378 sv_utf8_upgrade(sv);
8384 =for apidoc sv_reftype
8386 Returns a string describing what the SV is a reference to.
8392 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
8394 PERL_ARGS_ASSERT_SV_REFTYPE;
8396 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8397 inside return suggests a const propagation bug in g++. */
8398 if (ob && SvOBJECT(sv)) {
8399 char * const name = HvNAME_get(SvSTASH(sv));
8400 return name ? name : (char *) "__ANON__";
8403 switch (SvTYPE(sv)) {
8418 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
8419 /* tied lvalues should appear to be
8420 * scalars for backwards compatitbility */
8421 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8422 ? "SCALAR" : "LVALUE");
8423 case SVt_PVAV: return "ARRAY";
8424 case SVt_PVHV: return "HASH";
8425 case SVt_PVCV: return "CODE";
8426 case SVt_PVGV: return (char *) (isGV_with_GP(sv)
8427 ? "GLOB" : "SCALAR");
8428 case SVt_PVFM: return "FORMAT";
8429 case SVt_PVIO: return "IO";
8430 case SVt_BIND: return "BIND";
8431 case SVt_REGEXP: return "REGEXP";
8432 default: return "UNKNOWN";
8438 =for apidoc sv_isobject
8440 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8441 object. If the SV is not an RV, or if the object is not blessed, then this
8448 Perl_sv_isobject(pTHX_ SV *sv)
8464 Returns a boolean indicating whether the SV is blessed into the specified
8465 class. This does not check for subtypes; use C<sv_derived_from> to verify
8466 an inheritance relationship.
8472 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
8476 PERL_ARGS_ASSERT_SV_ISA;
8486 hvname = HvNAME_get(SvSTASH(sv));
8490 return strEQ(hvname, name);
8496 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8497 it will be upgraded to one. If C<classname> is non-null then the new SV will
8498 be blessed in the specified package. The new SV is returned and its
8499 reference count is 1.
8505 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
8510 PERL_ARGS_ASSERT_NEWSVRV;
8514 SV_CHECK_THINKFIRST_COW_DROP(rv);
8515 (void)SvAMAGIC_off(rv);
8517 if (SvTYPE(rv) >= SVt_PVMG) {
8518 const U32 refcnt = SvREFCNT(rv);
8522 SvREFCNT(rv) = refcnt;
8524 sv_upgrade(rv, SVt_IV);
8525 } else if (SvROK(rv)) {
8526 SvREFCNT_dec(SvRV(rv));
8528 prepare_SV_for_RV(rv);
8536 HV* const stash = gv_stashpv(classname, GV_ADD);
8537 (void)sv_bless(rv, stash);
8543 =for apidoc sv_setref_pv
8545 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8546 argument will be upgraded to an RV. That RV will be modified to point to
8547 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8548 into the SV. The C<classname> argument indicates the package for the
8549 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8550 will have a reference count of 1, and the RV will be returned.
8552 Do not use with other Perl types such as HV, AV, SV, CV, because those
8553 objects will become corrupted by the pointer copy process.
8555 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8561 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
8565 PERL_ARGS_ASSERT_SV_SETREF_PV;
8568 sv_setsv(rv, &PL_sv_undef);
8572 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8577 =for apidoc sv_setref_iv
8579 Copies an 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_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
8591 PERL_ARGS_ASSERT_SV_SETREF_IV;
8593 sv_setiv(newSVrv(rv,classname), iv);
8598 =for apidoc sv_setref_uv
8600 Copies an unsigned integer 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_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
8612 PERL_ARGS_ASSERT_SV_SETREF_UV;
8614 sv_setuv(newSVrv(rv,classname), uv);
8619 =for apidoc sv_setref_nv
8621 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8622 argument will be upgraded to an RV. That RV will be modified to point to
8623 the new SV. The C<classname> argument indicates the package for the
8624 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8625 will have a reference count of 1, and the RV will be returned.
8631 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
8633 PERL_ARGS_ASSERT_SV_SETREF_NV;
8635 sv_setnv(newSVrv(rv,classname), nv);
8640 =for apidoc sv_setref_pvn
8642 Copies a string into a new SV, optionally blessing the SV. The length of the
8643 string must be specified with C<n>. The C<rv> argument will be upgraded to
8644 an RV. That RV will be modified to point to the new SV. The C<classname>
8645 argument indicates the package for the blessing. Set C<classname> to
8646 C<NULL> to avoid the blessing. The new SV will have a reference count
8647 of 1, and the RV will be returned.
8649 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8655 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
8656 const char *const pv, const STRLEN n)
8658 PERL_ARGS_ASSERT_SV_SETREF_PVN;
8660 sv_setpvn(newSVrv(rv,classname), pv, n);
8665 =for apidoc sv_bless
8667 Blesses an SV into a specified package. The SV must be an RV. The package
8668 must be designated by its stash (see C<gv_stashpv()>). The reference count
8669 of the SV is unaffected.
8675 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
8680 PERL_ARGS_ASSERT_SV_BLESS;
8683 Perl_croak(aTHX_ "Can't bless non-reference value");
8685 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8686 if (SvIsCOW(tmpRef))
8687 sv_force_normal_flags(tmpRef, 0);
8688 if (SvREADONLY(tmpRef))
8689 Perl_croak(aTHX_ "%s", PL_no_modify);
8690 if (SvOBJECT(tmpRef)) {
8691 if (SvTYPE(tmpRef) != SVt_PVIO)
8693 SvREFCNT_dec(SvSTASH(tmpRef));
8696 SvOBJECT_on(tmpRef);
8697 if (SvTYPE(tmpRef) != SVt_PVIO)
8699 SvUPGRADE(tmpRef, SVt_PVMG);
8700 SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
8705 (void)SvAMAGIC_off(sv);
8707 if(SvSMAGICAL(tmpRef))
8708 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8716 /* Downgrades a PVGV to a PVMG.
8720 S_sv_unglob(pTHX_ SV *const sv)
8725 SV * const temp = sv_newmortal();
8727 PERL_ARGS_ASSERT_SV_UNGLOB;
8729 assert(SvTYPE(sv) == SVt_PVGV);
8731 gv_efullname3(temp, MUTABLE_GV(sv), "*");
8734 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
8735 && HvNAME_get(stash))
8736 mro_method_changed_in(stash);
8737 gp_free(MUTABLE_GV(sv));
8740 sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
8744 if (GvNAME_HEK(sv)) {
8745 unshare_hek(GvNAME_HEK(sv));
8747 isGV_with_GP_off(sv);
8749 /* need to keep SvANY(sv) in the right arena */
8750 xpvmg = new_XPVMG();
8751 StructCopy(SvANY(sv), xpvmg, XPVMG);
8752 del_XPVGV(SvANY(sv));
8755 SvFLAGS(sv) &= ~SVTYPEMASK;
8756 SvFLAGS(sv) |= SVt_PVMG;
8758 /* Intentionally not calling any local SET magic, as this isn't so much a
8759 set operation as merely an internal storage change. */
8760 sv_setsv_flags(sv, temp, 0);
8764 =for apidoc sv_unref_flags
8766 Unsets the RV status of the SV, and decrements the reference count of
8767 whatever was being referenced by the RV. This can almost be thought of
8768 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8769 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8770 (otherwise the decrementing is conditional on the reference count being
8771 different from one or the reference being a readonly SV).
8778 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
8780 SV* const target = SvRV(ref);
8782 PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
8784 if (SvWEAKREF(ref)) {
8785 sv_del_backref(target, ref);
8787 SvRV_set(ref, NULL);
8790 SvRV_set(ref, NULL);
8792 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8793 assigned to as BEGIN {$a = \"Foo"} will fail. */
8794 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8795 SvREFCNT_dec(target);
8796 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8797 sv_2mortal(target); /* Schedule for freeing later */
8801 =for apidoc sv_untaint
8803 Untaint an SV. Use C<SvTAINTED_off> instead.
8808 Perl_sv_untaint(pTHX_ SV *const sv)
8810 PERL_ARGS_ASSERT_SV_UNTAINT;
8812 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8813 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8820 =for apidoc sv_tainted
8822 Test an SV for taintedness. Use C<SvTAINTED> instead.
8827 Perl_sv_tainted(pTHX_ SV *const sv)
8829 PERL_ARGS_ASSERT_SV_TAINTED;
8831 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8832 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8833 if (mg && (mg->mg_len & 1) )
8840 =for apidoc sv_setpviv
8842 Copies an integer into the given SV, also updating its string value.
8843 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8849 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
8851 char buf[TYPE_CHARS(UV)];
8853 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8855 PERL_ARGS_ASSERT_SV_SETPVIV;
8857 sv_setpvn(sv, ptr, ebuf - ptr);
8861 =for apidoc sv_setpviv_mg
8863 Like C<sv_setpviv>, but also handles 'set' magic.
8869 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
8871 PERL_ARGS_ASSERT_SV_SETPVIV_MG;
8877 #if defined(PERL_IMPLICIT_CONTEXT)
8879 /* pTHX_ magic can't cope with varargs, so this is a no-context
8880 * version of the main function, (which may itself be aliased to us).
8881 * Don't access this version directly.
8885 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
8890 PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
8892 va_start(args, pat);
8893 sv_vsetpvf(sv, pat, &args);
8897 /* pTHX_ magic can't cope with varargs, so this is a no-context
8898 * version of the main function, (which may itself be aliased to us).
8899 * Don't access this version directly.
8903 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
8908 PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
8910 va_start(args, pat);
8911 sv_vsetpvf_mg(sv, pat, &args);
8917 =for apidoc sv_setpvf
8919 Works like C<sv_catpvf> but copies the text into the SV instead of
8920 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8926 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
8930 PERL_ARGS_ASSERT_SV_SETPVF;
8932 va_start(args, pat);
8933 sv_vsetpvf(sv, pat, &args);
8938 =for apidoc sv_vsetpvf
8940 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8941 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8943 Usually used via its frontend C<sv_setpvf>.
8949 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8951 PERL_ARGS_ASSERT_SV_VSETPVF;
8953 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8957 =for apidoc sv_setpvf_mg
8959 Like C<sv_setpvf>, but also handles 'set' magic.
8965 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
8969 PERL_ARGS_ASSERT_SV_SETPVF_MG;
8971 va_start(args, pat);
8972 sv_vsetpvf_mg(sv, pat, &args);
8977 =for apidoc sv_vsetpvf_mg
8979 Like C<sv_vsetpvf>, but also handles 'set' magic.
8981 Usually used via its frontend C<sv_setpvf_mg>.
8987 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8989 PERL_ARGS_ASSERT_SV_VSETPVF_MG;
8991 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8995 #if defined(PERL_IMPLICIT_CONTEXT)
8997 /* pTHX_ magic can't cope with varargs, so this is a no-context
8998 * version of the main function, (which may itself be aliased to us).
8999 * Don't access this version directly.
9003 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
9008 PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
9010 va_start(args, pat);
9011 sv_vcatpvf(sv, pat, &args);
9015 /* pTHX_ magic can't cope with varargs, so this is a no-context
9016 * version of the main function, (which may itself be aliased to us).
9017 * Don't access this version directly.
9021 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9026 PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9028 va_start(args, pat);
9029 sv_vcatpvf_mg(sv, pat, &args);
9035 =for apidoc sv_catpvf
9037 Processes its arguments like C<sprintf> and appends the formatted
9038 output to an SV. If the appended data contains "wide" characters
9039 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9040 and characters >255 formatted with %c), the original SV might get
9041 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
9042 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9043 valid UTF-8; if the original SV was bytes, the pattern should be too.
9048 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9052 PERL_ARGS_ASSERT_SV_CATPVF;
9054 va_start(args, pat);
9055 sv_vcatpvf(sv, pat, &args);
9060 =for apidoc sv_vcatpvf
9062 Processes its arguments like C<vsprintf> and appends the formatted output
9063 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
9065 Usually used via its frontend C<sv_catpvf>.
9071 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9073 PERL_ARGS_ASSERT_SV_VCATPVF;
9075 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9079 =for apidoc sv_catpvf_mg
9081 Like C<sv_catpvf>, but also handles 'set' magic.
9087 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9091 PERL_ARGS_ASSERT_SV_CATPVF_MG;
9093 va_start(args, pat);
9094 sv_vcatpvf_mg(sv, pat, &args);
9099 =for apidoc sv_vcatpvf_mg
9101 Like C<sv_vcatpvf>, but also handles 'set' magic.
9103 Usually used via its frontend C<sv_catpvf_mg>.
9109 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9111 PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9113 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9118 =for apidoc sv_vsetpvfn
9120 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9123 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9129 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9130 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9132 PERL_ARGS_ASSERT_SV_VSETPVFN;
9135 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9139 S_expect_number(pTHX_ char **const pattern)
9144 PERL_ARGS_ASSERT_EXPECT_NUMBER;
9146 switch (**pattern) {
9147 case '1': case '2': case '3':
9148 case '4': case '5': case '6':
9149 case '7': case '8': case '9':
9150 var = *(*pattern)++ - '0';
9151 while (isDIGIT(**pattern)) {
9152 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
9154 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn"));
9162 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
9164 const int neg = nv < 0;
9167 PERL_ARGS_ASSERT_F0CONVERT;
9175 if (uv & 1 && uv == nv)
9176 uv--; /* Round to even */
9178 const unsigned dig = uv % 10;
9191 =for apidoc sv_vcatpvfn
9193 Processes its arguments like C<vsprintf> and appends the formatted output
9194 to an SV. Uses an array of SVs if the C style variable argument list is
9195 missing (NULL). When running with taint checks enabled, indicates via
9196 C<maybe_tainted> if results are untrustworthy (often due to the use of
9199 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9205 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
9206 vecstr = (U8*)SvPV_const(vecsv,veclen);\
9207 vec_utf8 = DO_UTF8(vecsv);
9209 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9212 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9213 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9221 static const char nullstr[] = "(null)";
9223 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
9224 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9226 /* Times 4: a decimal digit takes more than 3 binary digits.
9227 * NV_DIG: mantissa takes than many decimal digits.
9228 * Plus 32: Playing safe. */
9229 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9230 /* large enough for "%#.#f" --chip */
9231 /* what about long double NVs? --jhi */
9233 PERL_ARGS_ASSERT_SV_VCATPVFN;
9234 PERL_UNUSED_ARG(maybe_tainted);
9236 /* no matter what, this is a string now */
9237 (void)SvPV_force(sv, origlen);
9239 /* special-case "", "%s", and "%-p" (SVf - see below) */
9242 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9244 const char * const s = va_arg(*args, char*);
9245 sv_catpv(sv, s ? s : nullstr);
9247 else if (svix < svmax) {
9248 sv_catsv(sv, *svargs);
9252 if (args && patlen == 3 && pat[0] == '%' &&
9253 pat[1] == '-' && pat[2] == 'p') {
9254 argsv = MUTABLE_SV(va_arg(*args, void*));
9255 sv_catsv(sv, argsv);
9259 #ifndef USE_LONG_DOUBLE
9260 /* special-case "%.<number>[gf]" */
9261 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9262 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9263 unsigned digits = 0;
9267 while (*pp >= '0' && *pp <= '9')
9268 digits = 10 * digits + (*pp++ - '0');
9269 if (pp - pat == (int)patlen - 1) {
9277 /* Add check for digits != 0 because it seems that some
9278 gconverts are buggy in this case, and we don't yet have
9279 a Configure test for this. */
9280 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9281 /* 0, point, slack */
9282 Gconvert(nv, (int)digits, 0, ebuf);
9284 if (*ebuf) /* May return an empty string for digits==0 */
9287 } else if (!digits) {
9290 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9291 sv_catpvn(sv, p, l);
9297 #endif /* !USE_LONG_DOUBLE */
9299 if (!args && svix < svmax && DO_UTF8(*svargs))
9302 patend = (char*)pat + patlen;
9303 for (p = (char*)pat; p < patend; p = q) {
9306 bool vectorize = FALSE;
9307 bool vectorarg = FALSE;
9308 bool vec_utf8 = FALSE;
9314 bool has_precis = FALSE;
9316 const I32 osvix = svix;
9317 bool is_utf8 = FALSE; /* is this item utf8? */
9318 #ifdef HAS_LDBL_SPRINTF_BUG
9319 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9320 with sfio - Allen <allens@cpan.org> */
9321 bool fix_ldbl_sprintf_bug = FALSE;
9325 U8 utf8buf[UTF8_MAXBYTES+1];
9326 STRLEN esignlen = 0;
9328 const char *eptr = NULL;
9329 const char *fmtstart;
9332 const U8 *vecstr = NULL;
9339 /* we need a long double target in case HAS_LONG_DOUBLE but
9342 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9350 const char *dotstr = ".";
9351 STRLEN dotstrlen = 1;
9352 I32 efix = 0; /* explicit format parameter index */
9353 I32 ewix = 0; /* explicit width index */
9354 I32 epix = 0; /* explicit precision index */
9355 I32 evix = 0; /* explicit vector index */
9356 bool asterisk = FALSE;
9358 /* echo everything up to the next format specification */
9359 for (q = p; q < patend && *q != '%'; ++q) ;
9361 if (has_utf8 && !pat_utf8)
9362 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9364 sv_catpvn(sv, p, q - p);
9373 We allow format specification elements in this order:
9374 \d+\$ explicit format parameter index
9376 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9377 0 flag (as above): repeated to allow "v02"
9378 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9379 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9381 [%bcdefginopsuxDFOUX] format (mandatory)
9386 As of perl5.9.3, printf format checking is on by default.
9387 Internally, perl uses %p formats to provide an escape to
9388 some extended formatting. This block deals with those
9389 extensions: if it does not match, (char*)q is reset and
9390 the normal format processing code is used.
9392 Currently defined extensions are:
9393 %p include pointer address (standard)
9394 %-p (SVf) include an SV (previously %_)
9395 %-<num>p include an SV with precision <num>
9396 %<num>p reserved for future extensions
9398 Robin Barker 2005-07-14
9400 %1p (VDf) removed. RMB 2007-10-19
9407 n = expect_number(&q);
9414 argsv = MUTABLE_SV(va_arg(*args, void*));
9415 eptr = SvPV_const(argsv, elen);
9421 if (ckWARN_d(WARN_INTERNAL))
9422 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9423 "internal %%<num>p might conflict with future printf extensions");
9429 if ( (width = expect_number(&q)) ) {
9444 if (plus == '+' && *q == ' ') /* '+' over ' ' */
9473 if ( (ewix = expect_number(&q)) )
9482 if ((vectorarg = asterisk)) {
9495 width = expect_number(&q);
9501 vecsv = va_arg(*args, SV*);
9503 vecsv = (evix > 0 && evix <= svmax)
9504 ? svargs[evix-1] : &PL_sv_undef;
9506 vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
9508 dotstr = SvPV_const(vecsv, dotstrlen);
9509 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
9510 bad with tied or overloaded values that return UTF8. */
9513 else if (has_utf8) {
9514 vecsv = sv_mortalcopy(vecsv);
9515 sv_utf8_upgrade(vecsv);
9516 dotstr = SvPV_const(vecsv, dotstrlen);
9523 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
9524 vecsv = svargs[efix ? efix-1 : svix++];
9525 vecstr = (U8*)SvPV_const(vecsv,veclen);
9526 vec_utf8 = DO_UTF8(vecsv);
9528 /* if this is a version object, we need to convert
9529 * back into v-string notation and then let the
9530 * vectorize happen normally
9532 if (sv_derived_from(vecsv, "version")) {
9533 char *version = savesvpv(vecsv);
9534 if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
9535 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9536 "vector argument not supported with alpha versions");
9539 vecsv = sv_newmortal();
9540 scan_vstring(version, version + veclen, vecsv);
9541 vecstr = (U8*)SvPV_const(vecsv, veclen);
9542 vec_utf8 = DO_UTF8(vecsv);
9554 i = va_arg(*args, int);
9556 i = (ewix ? ewix <= svmax : svix < svmax) ?
9557 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9559 width = (i < 0) ? -i : i;
9569 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
9571 /* XXX: todo, support specified precision parameter */
9575 i = va_arg(*args, int);
9577 i = (ewix ? ewix <= svmax : svix < svmax)
9578 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9580 has_precis = !(i < 0);
9585 precis = precis * 10 + (*q++ - '0');
9594 case 'I': /* Ix, I32x, and I64x */
9596 if (q[1] == '6' && q[2] == '4') {
9602 if (q[1] == '3' && q[2] == '2') {
9612 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9623 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9624 if (*(q + 1) == 'l') { /* lld, llf */
9650 if (!vectorize && !args) {
9652 const I32 i = efix-1;
9653 argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
9655 argsv = (svix >= 0 && svix < svmax)
9656 ? svargs[svix++] : &PL_sv_undef;
9667 uv = (args) ? va_arg(*args, int) : SvIV(argsv);
9669 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9671 eptr = (char*)utf8buf;
9672 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9686 eptr = va_arg(*args, char*);
9688 #ifdef MACOS_TRADITIONAL
9689 /* On MacOS, %#s format is used for Pascal strings */
9694 elen = strlen(eptr);
9696 eptr = (char *)nullstr;
9697 elen = sizeof nullstr - 1;
9701 eptr = SvPV_const(argsv, elen);
9702 if (DO_UTF8(argsv)) {
9703 I32 old_precis = precis;
9704 if (has_precis && precis < elen) {
9706 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9709 if (width) { /* fudge width (can't fudge elen) */
9710 if (has_precis && precis < elen)
9711 width += precis - old_precis;
9713 width += elen - sv_len_utf8(argsv);
9720 if (has_precis && elen > precis)
9727 if (alt || vectorize)
9729 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9750 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9759 esignbuf[esignlen++] = plus;
9763 case 'h': iv = (short)va_arg(*args, int); break;
9764 case 'l': iv = va_arg(*args, long); break;
9765 case 'V': iv = va_arg(*args, IV); break;
9766 default: iv = va_arg(*args, int); break;
9769 iv = va_arg(*args, Quad_t); break;
9776 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
9778 case 'h': iv = (short)tiv; break;
9779 case 'l': iv = (long)tiv; break;
9781 default: iv = tiv; break;
9784 iv = (Quad_t)tiv; break;
9790 if ( !vectorize ) /* we already set uv above */
9795 esignbuf[esignlen++] = plus;
9799 esignbuf[esignlen++] = '-';
9843 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9854 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9855 case 'l': uv = va_arg(*args, unsigned long); break;
9856 case 'V': uv = va_arg(*args, UV); break;
9857 default: uv = va_arg(*args, unsigned); break;
9860 uv = va_arg(*args, Uquad_t); break;
9867 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
9869 case 'h': uv = (unsigned short)tuv; break;
9870 case 'l': uv = (unsigned long)tuv; break;
9872 default: uv = tuv; break;
9875 uv = (Uquad_t)tuv; break;
9884 char *ptr = ebuf + sizeof ebuf;
9885 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
9891 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
9897 esignbuf[esignlen++] = '0';
9898 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9906 if (alt && *ptr != '0')
9915 esignbuf[esignlen++] = '0';
9916 esignbuf[esignlen++] = c;
9919 default: /* it had better be ten or less */
9923 } while (uv /= base);
9926 elen = (ebuf + sizeof ebuf) - ptr;
9930 zeros = precis - elen;
9931 else if (precis == 0 && elen == 1 && *eptr == '0'
9932 && !(base == 8 && alt)) /* "%#.0o" prints "0" */
9935 /* a precision nullifies the 0 flag. */
9942 /* FLOATING POINT */
9945 c = 'f'; /* maybe %F isn't supported here */
9953 /* This is evil, but floating point is even more evil */
9955 /* for SV-style calling, we can only get NV
9956 for C-style calling, we assume %f is double;
9957 for simplicity we allow any of %Lf, %llf, %qf for long double
9961 #if defined(USE_LONG_DOUBLE)
9965 /* [perl #20339] - we should accept and ignore %lf rather than die */
9969 #if defined(USE_LONG_DOUBLE)
9970 intsize = args ? 0 : 'q';
9974 #if defined(HAS_LONG_DOUBLE)
9983 /* now we need (long double) if intsize == 'q', else (double) */
9985 #if LONG_DOUBLESIZE > DOUBLESIZE
9987 va_arg(*args, long double) :
9988 va_arg(*args, double)
9990 va_arg(*args, double)
9995 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
9996 else. frexp() has some unspecified behaviour for those three */
9997 if (c != 'e' && c != 'E' && (nv * 0) == 0) {
9999 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
10000 will cast our (long double) to (double) */
10001 (void)Perl_frexp(nv, &i);
10002 if (i == PERL_INT_MIN)
10003 Perl_die(aTHX_ "panic: frexp");
10005 need = BIT_DIGITS(i);
10007 need += has_precis ? precis : 6; /* known default */
10012 #ifdef HAS_LDBL_SPRINTF_BUG
10013 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10014 with sfio - Allen <allens@cpan.org> */
10017 # define MY_DBL_MAX DBL_MAX
10018 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
10019 # if DOUBLESIZE >= 8
10020 # define MY_DBL_MAX 1.7976931348623157E+308L
10022 # define MY_DBL_MAX 3.40282347E+38L
10026 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10027 # define MY_DBL_MAX_BUG 1L
10029 # define MY_DBL_MAX_BUG MY_DBL_MAX
10033 # define MY_DBL_MIN DBL_MIN
10034 # else /* XXX guessing! -Allen */
10035 # if DOUBLESIZE >= 8
10036 # define MY_DBL_MIN 2.2250738585072014E-308L
10038 # define MY_DBL_MIN 1.17549435E-38L
10042 if ((intsize == 'q') && (c == 'f') &&
10043 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10044 (need < DBL_DIG)) {
10045 /* it's going to be short enough that
10046 * long double precision is not needed */
10048 if ((nv <= 0L) && (nv >= -0L))
10049 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10051 /* would use Perl_fp_class as a double-check but not
10052 * functional on IRIX - see perl.h comments */
10054 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10055 /* It's within the range that a double can represent */
10056 #if defined(DBL_MAX) && !defined(DBL_MIN)
10057 if ((nv >= ((long double)1/DBL_MAX)) ||
10058 (nv <= (-(long double)1/DBL_MAX)))
10060 fix_ldbl_sprintf_bug = TRUE;
10063 if (fix_ldbl_sprintf_bug == TRUE) {
10073 # undef MY_DBL_MAX_BUG
10076 #endif /* HAS_LDBL_SPRINTF_BUG */
10078 need += 20; /* fudge factor */
10079 if (PL_efloatsize < need) {
10080 Safefree(PL_efloatbuf);
10081 PL_efloatsize = need + 20; /* more fudge */
10082 Newx(PL_efloatbuf, PL_efloatsize, char);
10083 PL_efloatbuf[0] = '\0';
10086 if ( !(width || left || plus || alt) && fill != '0'
10087 && has_precis && intsize != 'q' ) { /* Shortcuts */
10088 /* See earlier comment about buggy Gconvert when digits,
10090 if ( c == 'g' && precis) {
10091 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10092 /* May return an empty string for digits==0 */
10093 if (*PL_efloatbuf) {
10094 elen = strlen(PL_efloatbuf);
10095 goto float_converted;
10097 } else if ( c == 'f' && !precis) {
10098 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10103 char *ptr = ebuf + sizeof ebuf;
10106 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10107 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10108 if (intsize == 'q') {
10109 /* Copy the one or more characters in a long double
10110 * format before the 'base' ([efgEFG]) character to
10111 * the format string. */
10112 static char const prifldbl[] = PERL_PRIfldbl;
10113 char const *p = prifldbl + sizeof(prifldbl) - 3;
10114 while (p >= prifldbl) { *--ptr = *p--; }
10119 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10124 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10136 /* No taint. Otherwise we are in the strange situation
10137 * where printf() taints but print($float) doesn't.
10139 #if defined(HAS_LONG_DOUBLE)
10140 elen = ((intsize == 'q')
10141 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
10142 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
10144 elen = my_sprintf(PL_efloatbuf, ptr, nv);
10148 eptr = PL_efloatbuf;
10156 i = SvCUR(sv) - origlen;
10159 case 'h': *(va_arg(*args, short*)) = i; break;
10160 default: *(va_arg(*args, int*)) = i; break;
10161 case 'l': *(va_arg(*args, long*)) = i; break;
10162 case 'V': *(va_arg(*args, IV*)) = i; break;
10165 *(va_arg(*args, Quad_t*)) = i; break;
10172 sv_setuv_mg(argsv, (UV)i);
10173 continue; /* not "break" */
10180 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
10181 && ckWARN(WARN_PRINTF))
10183 SV * const msg = sv_newmortal();
10184 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10185 (PL_op->op_type == OP_PRTF) ? "" : "s");
10186 if (fmtstart < patend) {
10187 const char * const fmtend = q < patend ? q : patend;
10189 sv_catpvs(msg, "\"%");
10190 for (f = fmtstart; f < fmtend; f++) {
10192 sv_catpvn(msg, f, 1);
10194 Perl_sv_catpvf(aTHX_ msg,
10195 "\\%03"UVof, (UV)*f & 0xFF);
10198 sv_catpvs(msg, "\"");
10200 sv_catpvs(msg, "end of string");
10202 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
10205 /* output mangled stuff ... */
10211 /* ... right here, because formatting flags should not apply */
10212 SvGROW(sv, SvCUR(sv) + elen + 1);
10214 Copy(eptr, p, elen, char);
10217 SvCUR_set(sv, p - SvPVX_const(sv));
10219 continue; /* not "break" */
10222 if (is_utf8 != has_utf8) {
10225 sv_utf8_upgrade(sv);
10228 const STRLEN old_elen = elen;
10229 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
10230 sv_utf8_upgrade(nsv);
10231 eptr = SvPVX_const(nsv);
10234 if (width) { /* fudge width (can't fudge elen) */
10235 width += elen - old_elen;
10241 have = esignlen + zeros + elen;
10243 Perl_croak_nocontext("%s", PL_memory_wrap);
10245 need = (have > width ? have : width);
10248 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
10249 Perl_croak_nocontext("%s", PL_memory_wrap);
10250 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10252 if (esignlen && fill == '0') {
10254 for (i = 0; i < (int)esignlen; i++)
10255 *p++ = esignbuf[i];
10257 if (gap && !left) {
10258 memset(p, fill, gap);
10261 if (esignlen && fill != '0') {
10263 for (i = 0; i < (int)esignlen; i++)
10264 *p++ = esignbuf[i];
10268 for (i = zeros; i; i--)
10272 Copy(eptr, p, elen, char);
10276 memset(p, ' ', gap);
10281 Copy(dotstr, p, dotstrlen, char);
10285 vectorize = FALSE; /* done iterating over vecstr */
10292 SvCUR_set(sv, p - SvPVX_const(sv));
10300 /* =========================================================================
10302 =head1 Cloning an interpreter
10304 All the macros and functions in this section are for the private use of
10305 the main function, perl_clone().
10307 The foo_dup() functions make an exact copy of an existing foo thingy.
10308 During the course of a cloning, a hash table is used to map old addresses
10309 to new addresses. The table is created and manipulated with the
10310 ptr_table_* functions.
10314 ============================================================================*/
10317 #if defined(USE_ITHREADS)
10319 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
10320 #ifndef GpREFCNT_inc
10321 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10325 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
10326 that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
10327 If this changes, please unmerge ss_dup. */
10328 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10329 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t))
10330 #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
10331 #define av_dup_inc(s,t) MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10332 #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
10333 #define hv_dup_inc(s,t) MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10334 #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
10335 #define cv_dup_inc(s,t) MUTABLE_CV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10336 #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
10337 #define io_dup_inc(s,t) MUTABLE_IO(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10338 #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
10339 #define gv_dup_inc(s,t) MUTABLE_GV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10340 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
10341 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
10343 /* clone a parser */
10346 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
10350 PERL_ARGS_ASSERT_PARSER_DUP;
10355 /* look for it in the table first */
10356 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
10360 /* create anew and remember what it is */
10361 Newxz(parser, 1, yy_parser);
10362 ptr_table_store(PL_ptr_table, proto, parser);
10364 parser->yyerrstatus = 0;
10365 parser->yychar = YYEMPTY; /* Cause a token to be read. */
10367 /* XXX these not yet duped */
10368 parser->old_parser = NULL;
10369 parser->stack = NULL;
10371 parser->stack_size = 0;
10372 /* XXX parser->stack->state = 0; */
10374 /* XXX eventually, just Copy() most of the parser struct ? */
10376 parser->lex_brackets = proto->lex_brackets;
10377 parser->lex_casemods = proto->lex_casemods;
10378 parser->lex_brackstack = savepvn(proto->lex_brackstack,
10379 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
10380 parser->lex_casestack = savepvn(proto->lex_casestack,
10381 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
10382 parser->lex_defer = proto->lex_defer;
10383 parser->lex_dojoin = proto->lex_dojoin;
10384 parser->lex_expect = proto->lex_expect;
10385 parser->lex_formbrack = proto->lex_formbrack;
10386 parser->lex_inpat = proto->lex_inpat;
10387 parser->lex_inwhat = proto->lex_inwhat;
10388 parser->lex_op = proto->lex_op;
10389 parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
10390 parser->lex_starts = proto->lex_starts;
10391 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
10392 parser->multi_close = proto->multi_close;
10393 parser->multi_open = proto->multi_open;
10394 parser->multi_start = proto->multi_start;
10395 parser->multi_end = proto->multi_end;
10396 parser->pending_ident = proto->pending_ident;
10397 parser->preambled = proto->preambled;
10398 parser->sublex_info = proto->sublex_info; /* XXX not quite right */
10399 parser->linestr = sv_dup_inc(proto->linestr, param);
10400 parser->expect = proto->expect;
10401 parser->copline = proto->copline;
10402 parser->last_lop_op = proto->last_lop_op;
10403 parser->lex_state = proto->lex_state;
10404 parser->rsfp = fp_dup(proto->rsfp, '<', param);
10405 /* rsfp_filters entries have fake IoDIRP() */
10406 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
10407 parser->in_my = proto->in_my;
10408 parser->in_my_stash = hv_dup(proto->in_my_stash, param);
10409 parser->error_count = proto->error_count;
10412 parser->linestr = sv_dup_inc(proto->linestr, param);
10415 char * const ols = SvPVX(proto->linestr);
10416 char * const ls = SvPVX(parser->linestr);
10418 parser->bufptr = ls + (proto->bufptr >= ols ?
10419 proto->bufptr - ols : 0);
10420 parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
10421 proto->oldbufptr - ols : 0);
10422 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
10423 proto->oldoldbufptr - ols : 0);
10424 parser->linestart = ls + (proto->linestart >= ols ?
10425 proto->linestart - ols : 0);
10426 parser->last_uni = ls + (proto->last_uni >= ols ?
10427 proto->last_uni - ols : 0);
10428 parser->last_lop = ls + (proto->last_lop >= ols ?
10429 proto->last_lop - ols : 0);
10431 parser->bufend = ls + SvCUR(parser->linestr);
10434 Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
10438 parser->endwhite = proto->endwhite;
10439 parser->faketokens = proto->faketokens;
10440 parser->lasttoke = proto->lasttoke;
10441 parser->nextwhite = proto->nextwhite;
10442 parser->realtokenstart = proto->realtokenstart;
10443 parser->skipwhite = proto->skipwhite;
10444 parser->thisclose = proto->thisclose;
10445 parser->thismad = proto->thismad;
10446 parser->thisopen = proto->thisopen;
10447 parser->thisstuff = proto->thisstuff;
10448 parser->thistoken = proto->thistoken;
10449 parser->thiswhite = proto->thiswhite;
10451 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
10452 parser->curforce = proto->curforce;
10454 Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
10455 Copy(proto->nexttype, parser->nexttype, 5, I32);
10456 parser->nexttoke = proto->nexttoke;
10462 /* duplicate a file handle */
10465 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
10469 PERL_ARGS_ASSERT_FP_DUP;
10470 PERL_UNUSED_ARG(type);
10473 return (PerlIO*)NULL;
10475 /* look for it in the table first */
10476 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10480 /* create anew and remember what it is */
10481 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10482 ptr_table_store(PL_ptr_table, fp, ret);
10486 /* duplicate a directory handle */
10489 Perl_dirp_dup(pTHX_ DIR *const dp)
10491 PERL_UNUSED_CONTEXT;
10498 /* duplicate a typeglob */
10501 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
10505 PERL_ARGS_ASSERT_GP_DUP;
10509 /* look for it in the table first */
10510 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10514 /* create anew and remember what it is */
10516 ptr_table_store(PL_ptr_table, gp, ret);
10519 ret->gp_refcnt = 0; /* must be before any other dups! */
10520 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10521 ret->gp_io = io_dup_inc(gp->gp_io, param);
10522 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10523 ret->gp_av = av_dup_inc(gp->gp_av, param);
10524 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10525 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10526 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10527 ret->gp_cvgen = gp->gp_cvgen;
10528 ret->gp_line = gp->gp_line;
10529 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
10533 /* duplicate a chain of magic */
10536 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
10538 MAGIC *mgprev = (MAGIC*)NULL;
10541 PERL_ARGS_ASSERT_MG_DUP;
10544 return (MAGIC*)NULL;
10545 /* look for it in the table first */
10546 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10550 for (; mg; mg = mg->mg_moremagic) {
10552 Newxz(nmg, 1, MAGIC);
10554 mgprev->mg_moremagic = nmg;
10557 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
10558 nmg->mg_private = mg->mg_private;
10559 nmg->mg_type = mg->mg_type;
10560 nmg->mg_flags = mg->mg_flags;
10561 /* FIXME for plugins
10562 if (mg->mg_type == PERL_MAGIC_qr) {
10563 nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)mg->mg_obj, param));
10567 if(mg->mg_type == PERL_MAGIC_backref) {
10568 /* The backref AV has its reference count deliberately bumped by
10571 = SvREFCNT_inc(av_dup_inc((const AV *) mg->mg_obj, param));
10574 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10575 ? sv_dup_inc(mg->mg_obj, param)
10576 : sv_dup(mg->mg_obj, param);
10578 nmg->mg_len = mg->mg_len;
10579 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
10580 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10581 if (mg->mg_len > 0) {
10582 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
10583 if (mg->mg_type == PERL_MAGIC_overload_table &&
10584 AMT_AMAGIC((AMT*)mg->mg_ptr))
10586 const AMT * const amtp = (AMT*)mg->mg_ptr;
10587 AMT * const namtp = (AMT*)nmg->mg_ptr;
10589 for (i = 1; i < NofAMmeth; i++) {
10590 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10594 else if (mg->mg_len == HEf_SVKEY)
10595 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)mg->mg_ptr, param);
10597 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10598 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10605 #endif /* USE_ITHREADS */
10607 /* create a new pointer-mapping table */
10610 Perl_ptr_table_new(pTHX)
10613 PERL_UNUSED_CONTEXT;
10615 Newxz(tbl, 1, PTR_TBL_t);
10616 tbl->tbl_max = 511;
10617 tbl->tbl_items = 0;
10618 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10622 #define PTR_TABLE_HASH(ptr) \
10623 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
10626 we use the PTE_SVSLOT 'reservation' made above, both here (in the
10627 following define) and at call to new_body_inline made below in
10628 Perl_ptr_table_store()
10631 #define del_pte(p) del_body_type(p, PTE_SVSLOT)
10633 /* map an existing pointer using a table */
10635 STATIC PTR_TBL_ENT_t *
10636 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
10638 PTR_TBL_ENT_t *tblent;
10639 const UV hash = PTR_TABLE_HASH(sv);
10641 PERL_ARGS_ASSERT_PTR_TABLE_FIND;
10643 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10644 for (; tblent; tblent = tblent->next) {
10645 if (tblent->oldval == sv)
10652 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
10654 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
10656 PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
10657 PERL_UNUSED_CONTEXT;
10659 return tblent ? tblent->newval : NULL;
10662 /* add a new entry to a pointer-mapping table */
10665 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
10667 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
10669 PERL_ARGS_ASSERT_PTR_TABLE_STORE;
10670 PERL_UNUSED_CONTEXT;
10673 tblent->newval = newsv;
10675 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
10677 new_body_inline(tblent, PTE_SVSLOT);
10679 tblent->oldval = oldsv;
10680 tblent->newval = newsv;
10681 tblent->next = tbl->tbl_ary[entry];
10682 tbl->tbl_ary[entry] = tblent;
10684 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
10685 ptr_table_split(tbl);
10689 /* double the hash bucket size of an existing ptr table */
10692 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
10694 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10695 const UV oldsize = tbl->tbl_max + 1;
10696 UV newsize = oldsize * 2;
10699 PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
10700 PERL_UNUSED_CONTEXT;
10702 Renew(ary, newsize, PTR_TBL_ENT_t*);
10703 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10704 tbl->tbl_max = --newsize;
10705 tbl->tbl_ary = ary;
10706 for (i=0; i < oldsize; i++, ary++) {
10707 PTR_TBL_ENT_t **curentp, **entp, *ent;
10710 curentp = ary + oldsize;
10711 for (entp = ary, ent = *ary; ent; ent = *entp) {
10712 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10714 ent->next = *curentp;
10724 /* remove all the entries from a ptr table */
10727 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
10729 if (tbl && tbl->tbl_items) {
10730 register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary;
10731 UV riter = tbl->tbl_max;
10734 PTR_TBL_ENT_t *entry = array[riter];
10737 PTR_TBL_ENT_t * const oentry = entry;
10738 entry = entry->next;
10743 tbl->tbl_items = 0;
10747 /* clear and free a ptr table */
10750 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
10755 ptr_table_clear(tbl);
10756 Safefree(tbl->tbl_ary);
10760 #if defined(USE_ITHREADS)
10763 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
10765 PERL_ARGS_ASSERT_RVPV_DUP;
10768 SvRV_set(dstr, SvWEAKREF(sstr)
10769 ? sv_dup(SvRV_const(sstr), param)
10770 : sv_dup_inc(SvRV_const(sstr), param));
10773 else if (SvPVX_const(sstr)) {
10774 /* Has something there */
10776 /* Normal PV - clone whole allocated space */
10777 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10778 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10779 /* Not that normal - actually sstr is copy on write.
10780 But we are a true, independant SV, so: */
10781 SvREADONLY_off(dstr);
10786 /* Special case - not normally malloced for some reason */
10787 if (isGV_with_GP(sstr)) {
10788 /* Don't need to do anything here. */
10790 else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10791 /* A "shared" PV - clone it as "shared" PV */
10793 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10797 /* Some other special case - random pointer */
10798 SvPV_set(dstr, (char *) SvPVX_const(sstr));
10803 /* Copy the NULL */
10804 SvPV_set(dstr, NULL);
10808 /* duplicate an SV of any type (including AV, HV etc) */
10811 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
10816 PERL_ARGS_ASSERT_SV_DUP;
10820 if (SvTYPE(sstr) == SVTYPEMASK) {
10821 #ifdef DEBUG_LEAKING_SCALARS_ABORT
10826 /* look for it in the table first */
10827 dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
10831 if(param->flags & CLONEf_JOIN_IN) {
10832 /** We are joining here so we don't want do clone
10833 something that is bad **/
10834 if (SvTYPE(sstr) == SVt_PVHV) {
10835 const HEK * const hvname = HvNAME_HEK(sstr);
10837 /** don't clone stashes if they already exist **/
10838 return MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
10842 /* create anew and remember what it is */
10845 #ifdef DEBUG_LEAKING_SCALARS
10846 dstr->sv_debug_optype = sstr->sv_debug_optype;
10847 dstr->sv_debug_line = sstr->sv_debug_line;
10848 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10849 dstr->sv_debug_cloned = 1;
10850 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10853 ptr_table_store(PL_ptr_table, sstr, dstr);
10856 SvFLAGS(dstr) = SvFLAGS(sstr);
10857 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10858 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10861 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10862 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10863 (void*)PL_watch_pvx, SvPVX_const(sstr));
10866 /* don't clone objects whose class has asked us not to */
10867 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10872 switch (SvTYPE(sstr)) {
10874 SvANY(dstr) = NULL;
10877 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10879 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10881 SvIV_set(dstr, SvIVX(sstr));
10885 SvANY(dstr) = new_XNV();
10886 SvNV_set(dstr, SvNVX(sstr));
10888 /* case SVt_BIND: */
10891 /* These are all the types that need complex bodies allocating. */
10893 const svtype sv_type = SvTYPE(sstr);
10894 const struct body_details *const sv_type_details
10895 = bodies_by_type + sv_type;
10899 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
10903 if (GvUNIQUE((const GV *)sstr)) {
10904 NOOP; /* Do sharing here, and fall through */
10917 assert(sv_type_details->body_size);
10918 if (sv_type_details->arena) {
10919 new_body_inline(new_body, sv_type);
10921 = (void*)((char*)new_body - sv_type_details->offset);
10923 new_body = new_NOARENA(sv_type_details);
10927 SvANY(dstr) = new_body;
10930 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
10931 ((char*)SvANY(dstr)) + sv_type_details->offset,
10932 sv_type_details->copy, char);
10934 Copy(((char*)SvANY(sstr)),
10935 ((char*)SvANY(dstr)),
10936 sv_type_details->body_size + sv_type_details->offset, char);
10939 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
10940 && !isGV_with_GP(dstr))
10941 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10943 /* The Copy above means that all the source (unduplicated) pointers
10944 are now in the destination. We can check the flags and the
10945 pointers in either, but it's possible that there's less cache
10946 missing by always going for the destination.
10947 FIXME - instrument and check that assumption */
10948 if (sv_type >= SVt_PVMG) {
10949 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
10950 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
10951 } else if (SvMAGIC(dstr))
10952 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
10954 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
10957 /* The cast silences a GCC warning about unhandled types. */
10958 switch ((int)sv_type) {
10968 /* FIXME for plugins */
10969 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
10972 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
10973 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
10974 LvTARG(dstr) = dstr;
10975 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
10976 LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
10978 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
10980 if(isGV_with_GP(sstr)) {
10981 if (GvNAME_HEK(dstr))
10982 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
10983 /* Don't call sv_add_backref here as it's going to be
10984 created as part of the magic cloning of the symbol
10986 /* Danger Will Robinson - GvGP(dstr) isn't initialised
10987 at the point of this comment. */
10988 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
10989 GvGP(dstr) = gp_dup(GvGP(sstr), param);
10990 (void)GpREFCNT_inc(GvGP(dstr));
10992 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10995 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
10996 if (IoOFP(dstr) == IoIFP(sstr))
10997 IoOFP(dstr) = IoIFP(dstr);
10999 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
11000 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
11001 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
11002 /* I have no idea why fake dirp (rsfps)
11003 should be treated differently but otherwise
11004 we end up with leaks -- sky*/
11005 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
11006 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
11007 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
11009 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
11010 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
11011 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
11012 if (IoDIRP(dstr)) {
11013 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
11016 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
11019 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
11020 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
11021 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
11024 /* avoid cloning an empty array */
11025 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
11026 SV **dst_ary, **src_ary;
11027 SSize_t items = AvFILLp((const AV *)sstr) + 1;
11029 src_ary = AvARRAY((const AV *)sstr);
11030 Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
11031 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
11032 AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
11033 AvALLOC((const AV *)dstr) = dst_ary;
11034 if (AvREAL((const AV *)sstr)) {
11035 while (items-- > 0)
11036 *dst_ary++ = sv_dup_inc(*src_ary++, param);
11039 while (items-- > 0)
11040 *dst_ary++ = sv_dup(*src_ary++, param);
11042 items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
11043 while (items-- > 0) {
11044 *dst_ary++ = &PL_sv_undef;
11048 AvARRAY(MUTABLE_AV(dstr)) = NULL;
11049 AvALLOC((const AV *)dstr) = (SV**)NULL;
11050 AvMAX( (const AV *)dstr) = -1;
11051 AvFILLp((const AV *)dstr) = -1;
11055 if (HvARRAY((const HV *)sstr)) {
11057 const bool sharekeys = !!HvSHAREKEYS(sstr);
11058 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
11059 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
11061 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
11062 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
11064 HvARRAY(dstr) = (HE**)darray;
11065 while (i <= sxhv->xhv_max) {
11066 const HE * const source = HvARRAY(sstr)[i];
11067 HvARRAY(dstr)[i] = source
11068 ? he_dup(source, sharekeys, param) : 0;
11073 const struct xpvhv_aux * const saux = HvAUX(sstr);
11074 struct xpvhv_aux * const daux = HvAUX(dstr);
11075 /* This flag isn't copied. */
11076 /* SvOOK_on(hv) attacks the IV flags. */
11077 SvFLAGS(dstr) |= SVf_OOK;
11079 hvname = saux->xhv_name;
11080 daux->xhv_name = hvname ? hek_dup(hvname, param) : hvname;
11082 daux->xhv_riter = saux->xhv_riter;
11083 daux->xhv_eiter = saux->xhv_eiter
11084 ? he_dup(saux->xhv_eiter,
11085 (bool)!!HvSHAREKEYS(sstr), param) : 0;
11086 /* backref array needs refcnt=2; see sv_add_backref */
11087 daux->xhv_backreferences =
11088 saux->xhv_backreferences
11089 ? MUTABLE_AV(SvREFCNT_inc(
11090 sv_dup_inc((const SV *)saux->xhv_backreferences, param)))
11093 daux->xhv_mro_meta = saux->xhv_mro_meta
11094 ? mro_meta_dup(saux->xhv_mro_meta, param)
11097 /* Record stashes for possible cloning in Perl_clone(). */
11099 av_push(param->stashes, dstr);
11103 HvARRAY(MUTABLE_HV(dstr)) = NULL;
11106 if (!(param->flags & CLONEf_COPY_STACKS)) {
11110 /* NOTE: not refcounted */
11111 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
11113 if (!CvISXSUB(dstr))
11114 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
11116 if (CvCONST(dstr) && CvISXSUB(dstr)) {
11117 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
11118 SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
11119 sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
11121 /* don't dup if copying back - CvGV isn't refcounted, so the
11122 * duped GV may never be freed. A bit of a hack! DAPM */
11123 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
11124 NULL : gv_dup(CvGV(dstr), param) ;
11125 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
11127 CvWEAKOUTSIDE(sstr)
11128 ? cv_dup( CvOUTSIDE(dstr), param)
11129 : cv_dup_inc(CvOUTSIDE(dstr), param);
11130 if (!CvISXSUB(dstr))
11131 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
11137 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11143 /* duplicate a context */
11146 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11148 PERL_CONTEXT *ncxs;
11150 PERL_ARGS_ASSERT_CX_DUP;
11153 return (PERL_CONTEXT*)NULL;
11155 /* look for it in the table first */
11156 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11160 /* create anew and remember what it is */
11161 Newx(ncxs, max + 1, PERL_CONTEXT);
11162 ptr_table_store(PL_ptr_table, cxs, ncxs);
11163 Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
11166 PERL_CONTEXT * const ncx = &ncxs[ix];
11167 if (CxTYPE(ncx) == CXt_SUBST) {
11168 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11171 switch (CxTYPE(ncx)) {
11173 ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
11174 ? cv_dup_inc(ncx->blk_sub.cv, param)
11175 : cv_dup(ncx->blk_sub.cv,param));
11176 ncx->blk_sub.argarray = (CxHASARGS(ncx)
11177 ? av_dup_inc(ncx->blk_sub.argarray,
11180 ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
11182 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
11183 ncx->blk_sub.oldcomppad);
11186 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
11188 ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
11190 case CXt_LOOP_LAZYSV:
11191 ncx->blk_loop.state_u.lazysv.end
11192 = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
11193 /* We are taking advantage of av_dup_inc and sv_dup_inc
11194 actually being the same function, and order equivalance of
11196 We can assert the later [but only at run time :-(] */
11197 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
11198 (void *) &ncx->blk_loop.state_u.lazysv.cur);
11200 ncx->blk_loop.state_u.ary.ary
11201 = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
11202 case CXt_LOOP_LAZYIV:
11203 case CXt_LOOP_PLAIN:
11204 if (CxPADLOOP(ncx)) {
11205 ncx->blk_loop.oldcomppad
11206 = (PAD*)ptr_table_fetch(PL_ptr_table,
11207 ncx->blk_loop.oldcomppad);
11209 ncx->blk_loop.oldcomppad
11210 = (PAD*)gv_dup((const GV *)ncx->blk_loop.oldcomppad,
11215 ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
11216 ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
11217 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
11230 /* duplicate a stack info structure */
11233 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11237 PERL_ARGS_ASSERT_SI_DUP;
11240 return (PERL_SI*)NULL;
11242 /* look for it in the table first */
11243 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11247 /* create anew and remember what it is */
11248 Newxz(nsi, 1, PERL_SI);
11249 ptr_table_store(PL_ptr_table, si, nsi);
11251 nsi->si_stack = av_dup_inc(si->si_stack, param);
11252 nsi->si_cxix = si->si_cxix;
11253 nsi->si_cxmax = si->si_cxmax;
11254 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11255 nsi->si_type = si->si_type;
11256 nsi->si_prev = si_dup(si->si_prev, param);
11257 nsi->si_next = si_dup(si->si_next, param);
11258 nsi->si_markoff = si->si_markoff;
11263 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
11264 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
11265 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
11266 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
11267 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
11268 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
11269 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
11270 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
11271 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
11272 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
11273 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
11274 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
11275 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11276 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11279 #define pv_dup_inc(p) SAVEPV(p)
11280 #define pv_dup(p) SAVEPV(p)
11281 #define svp_dup_inc(p,pp) any_dup(p,pp)
11283 /* map any object to the new equivent - either something in the
11284 * ptr table, or something in the interpreter structure
11288 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
11292 PERL_ARGS_ASSERT_ANY_DUP;
11295 return (void*)NULL;
11297 /* look for it in the table first */
11298 ret = ptr_table_fetch(PL_ptr_table, v);
11302 /* see if it is part of the interpreter structure */
11303 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11304 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11312 /* duplicate the save stack */
11315 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11318 ANY * const ss = proto_perl->Isavestack;
11319 const I32 max = proto_perl->Isavestack_max;
11320 I32 ix = proto_perl->Isavestack_ix;
11333 void (*dptr) (void*);
11334 void (*dxptr) (pTHX_ void*);
11336 PERL_ARGS_ASSERT_SS_DUP;
11338 Newxz(nss, max, ANY);
11341 const I32 type = POPINT(ss,ix);
11342 TOPINT(nss,ix) = type;
11344 case SAVEt_HELEM: /* hash element */
11345 sv = (const SV *)POPPTR(ss,ix);
11346 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11348 case SAVEt_ITEM: /* normal string */
11349 case SAVEt_SV: /* scalar reference */
11350 sv = (const SV *)POPPTR(ss,ix);
11351 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11354 case SAVEt_MORTALIZESV:
11355 sv = (const SV *)POPPTR(ss,ix);
11356 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11358 case SAVEt_SHARED_PVREF: /* char* in shared space */
11359 c = (char*)POPPTR(ss,ix);
11360 TOPPTR(nss,ix) = savesharedpv(c);
11361 ptr = POPPTR(ss,ix);
11362 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11364 case SAVEt_GENERIC_SVREF: /* generic sv */
11365 case SAVEt_SVREF: /* scalar reference */
11366 sv = (const SV *)POPPTR(ss,ix);
11367 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11368 ptr = POPPTR(ss,ix);
11369 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11371 case SAVEt_HV: /* hash reference */
11372 case SAVEt_AV: /* array reference */
11373 sv = (const SV *) POPPTR(ss,ix);
11374 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11376 case SAVEt_COMPPAD:
11378 sv = (const SV *) POPPTR(ss,ix);
11379 TOPPTR(nss,ix) = sv_dup(sv, param);
11381 case SAVEt_INT: /* int reference */
11382 ptr = POPPTR(ss,ix);
11383 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11384 intval = (int)POPINT(ss,ix);
11385 TOPINT(nss,ix) = intval;
11387 case SAVEt_LONG: /* long reference */
11388 ptr = POPPTR(ss,ix);
11389 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11391 case SAVEt_CLEARSV:
11392 longval = (long)POPLONG(ss,ix);
11393 TOPLONG(nss,ix) = longval;
11395 case SAVEt_I32: /* I32 reference */
11396 case SAVEt_I16: /* I16 reference */
11397 case SAVEt_I8: /* I8 reference */
11398 case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
11399 ptr = POPPTR(ss,ix);
11400 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11402 TOPINT(nss,ix) = i;
11404 case SAVEt_IV: /* IV reference */
11405 ptr = POPPTR(ss,ix);
11406 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11408 TOPIV(nss,ix) = iv;
11410 case SAVEt_HPTR: /* HV* reference */
11411 case SAVEt_APTR: /* AV* reference */
11412 case SAVEt_SPTR: /* SV* reference */
11413 ptr = POPPTR(ss,ix);
11414 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11415 sv = (const SV *)POPPTR(ss,ix);
11416 TOPPTR(nss,ix) = sv_dup(sv, param);
11418 case SAVEt_VPTR: /* random* reference */
11419 ptr = POPPTR(ss,ix);
11420 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11421 ptr = POPPTR(ss,ix);
11422 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11424 case SAVEt_GENERIC_PVREF: /* generic char* */
11425 case SAVEt_PPTR: /* char* reference */
11426 ptr = POPPTR(ss,ix);
11427 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11428 c = (char*)POPPTR(ss,ix);
11429 TOPPTR(nss,ix) = pv_dup(c);
11431 case SAVEt_GP: /* scalar reference */
11432 gp = (GP*)POPPTR(ss,ix);
11433 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11434 (void)GpREFCNT_inc(gp);
11435 gv = (const GV *)POPPTR(ss,ix);
11436 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11439 ptr = POPPTR(ss,ix);
11440 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11441 /* these are assumed to be refcounted properly */
11443 switch (((OP*)ptr)->op_type) {
11445 case OP_LEAVESUBLV:
11449 case OP_LEAVEWRITE:
11450 TOPPTR(nss,ix) = ptr;
11453 (void) OpREFCNT_inc(o);
11457 TOPPTR(nss,ix) = NULL;
11462 TOPPTR(nss,ix) = NULL;
11465 hv = (const HV *)POPPTR(ss,ix);
11466 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11468 TOPINT(nss,ix) = i;
11471 c = (char*)POPPTR(ss,ix);
11472 TOPPTR(nss,ix) = pv_dup_inc(c);
11474 case SAVEt_STACK_POS: /* Position on Perl stack */
11476 TOPINT(nss,ix) = i;
11478 case SAVEt_DESTRUCTOR:
11479 ptr = POPPTR(ss,ix);
11480 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11481 dptr = POPDPTR(ss,ix);
11482 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
11483 any_dup(FPTR2DPTR(void *, dptr),
11486 case SAVEt_DESTRUCTOR_X:
11487 ptr = POPPTR(ss,ix);
11488 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11489 dxptr = POPDXPTR(ss,ix);
11490 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
11491 any_dup(FPTR2DPTR(void *, dxptr),
11494 case SAVEt_REGCONTEXT:
11497 TOPINT(nss,ix) = i;
11500 case SAVEt_AELEM: /* array element */
11501 sv = (const SV *)POPPTR(ss,ix);
11502 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11504 TOPINT(nss,ix) = i;
11505 av = (const AV *)POPPTR(ss,ix);
11506 TOPPTR(nss,ix) = av_dup_inc(av, param);
11509 ptr = POPPTR(ss,ix);
11510 TOPPTR(nss,ix) = ptr;
11513 ptr = POPPTR(ss,ix);
11516 ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
11517 HINTS_REFCNT_UNLOCK;
11519 TOPPTR(nss,ix) = ptr;
11521 TOPINT(nss,ix) = i;
11522 if (i & HINT_LOCALIZE_HH) {
11523 hv = (const HV *)POPPTR(ss,ix);
11524 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11527 case SAVEt_PADSV_AND_MORTALIZE:
11528 longval = (long)POPLONG(ss,ix);
11529 TOPLONG(nss,ix) = longval;
11530 ptr = POPPTR(ss,ix);
11531 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11532 sv = (const SV *)POPPTR(ss,ix);
11533 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11536 ptr = POPPTR(ss,ix);
11537 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11538 longval = (long)POPBOOL(ss,ix);
11539 TOPBOOL(nss,ix) = (bool)longval;
11541 case SAVEt_SET_SVFLAGS:
11543 TOPINT(nss,ix) = i;
11545 TOPINT(nss,ix) = i;
11546 sv = (const SV *)POPPTR(ss,ix);
11547 TOPPTR(nss,ix) = sv_dup(sv, param);
11549 case SAVEt_RE_STATE:
11551 const struct re_save_state *const old_state
11552 = (struct re_save_state *)
11553 (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11554 struct re_save_state *const new_state
11555 = (struct re_save_state *)
11556 (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11558 Copy(old_state, new_state, 1, struct re_save_state);
11559 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11561 new_state->re_state_bostr
11562 = pv_dup(old_state->re_state_bostr);
11563 new_state->re_state_reginput
11564 = pv_dup(old_state->re_state_reginput);
11565 new_state->re_state_regeol
11566 = pv_dup(old_state->re_state_regeol);
11567 new_state->re_state_regoffs
11568 = (regexp_paren_pair*)
11569 any_dup(old_state->re_state_regoffs, proto_perl);
11570 new_state->re_state_reglastparen
11571 = (U32*) any_dup(old_state->re_state_reglastparen,
11573 new_state->re_state_reglastcloseparen
11574 = (U32*)any_dup(old_state->re_state_reglastcloseparen,
11576 /* XXX This just has to be broken. The old save_re_context
11577 code did SAVEGENERICPV(PL_reg_start_tmp);
11578 PL_reg_start_tmp is char **.
11579 Look above to what the dup code does for
11580 SAVEt_GENERIC_PVREF
11581 It can never have worked.
11582 So this is merely a faithful copy of the exiting bug: */
11583 new_state->re_state_reg_start_tmp
11584 = (char **) pv_dup((char *)
11585 old_state->re_state_reg_start_tmp);
11586 /* I assume that it only ever "worked" because no-one called
11587 (pseudo)fork while the regexp engine had re-entered itself.
11589 #ifdef PERL_OLD_COPY_ON_WRITE
11590 new_state->re_state_nrs
11591 = sv_dup(old_state->re_state_nrs, param);
11593 new_state->re_state_reg_magic
11594 = (MAGIC*) any_dup(old_state->re_state_reg_magic,
11596 new_state->re_state_reg_oldcurpm
11597 = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
11599 new_state->re_state_reg_curpm
11600 = (PMOP*) any_dup(old_state->re_state_reg_curpm,
11602 new_state->re_state_reg_oldsaved
11603 = pv_dup(old_state->re_state_reg_oldsaved);
11604 new_state->re_state_reg_poscache
11605 = pv_dup(old_state->re_state_reg_poscache);
11606 new_state->re_state_reg_starttry
11607 = pv_dup(old_state->re_state_reg_starttry);
11610 case SAVEt_COMPILE_WARNINGS:
11611 ptr = POPPTR(ss,ix);
11612 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
11615 ptr = POPPTR(ss,ix);
11616 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
11620 "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
11628 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11629 * flag to the result. This is done for each stash before cloning starts,
11630 * so we know which stashes want their objects cloned */
11633 do_mark_cloneable_stash(pTHX_ SV *const sv)
11635 const HEK * const hvname = HvNAME_HEK((const HV *)sv);
11637 GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
11638 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11639 if (cloner && GvCV(cloner)) {
11646 mXPUSHs(newSVhek(hvname));
11648 call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
11655 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11663 =for apidoc perl_clone
11665 Create and return a new interpreter by cloning the current one.
11667 perl_clone takes these flags as parameters:
11669 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11670 without it we only clone the data and zero the stacks,
11671 with it we copy the stacks and the new perl interpreter is
11672 ready to run at the exact same point as the previous one.
11673 The pseudo-fork code uses COPY_STACKS while the
11674 threads->create doesn't.
11676 CLONEf_KEEP_PTR_TABLE
11677 perl_clone keeps a ptr_table with the pointer of the old
11678 variable as a key and the new variable as a value,
11679 this allows it to check if something has been cloned and not
11680 clone it again but rather just use the value and increase the
11681 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11682 the ptr_table using the function
11683 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11684 reason to keep it around is if you want to dup some of your own
11685 variable who are outside the graph perl scans, example of this
11686 code is in threads.xs create
11689 This is a win32 thing, it is ignored on unix, it tells perls
11690 win32host code (which is c++) to clone itself, this is needed on
11691 win32 if you want to run two threads at the same time,
11692 if you just want to do some stuff in a separate perl interpreter
11693 and then throw it away and return to the original one,
11694 you don't need to do anything.
11699 /* XXX the above needs expanding by someone who actually understands it ! */
11700 EXTERN_C PerlInterpreter *
11701 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11704 perl_clone(PerlInterpreter *proto_perl, UV flags)
11707 #ifdef PERL_IMPLICIT_SYS
11709 PERL_ARGS_ASSERT_PERL_CLONE;
11711 /* perlhost.h so we need to call into it
11712 to clone the host, CPerlHost should have a c interface, sky */
11714 if (flags & CLONEf_CLONE_HOST) {
11715 return perl_clone_host(proto_perl,flags);
11717 return perl_clone_using(proto_perl, flags,
11719 proto_perl->IMemShared,
11720 proto_perl->IMemParse,
11722 proto_perl->IStdIO,
11726 proto_perl->IProc);
11730 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11731 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11732 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11733 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11734 struct IPerlDir* ipD, struct IPerlSock* ipS,
11735 struct IPerlProc* ipP)
11737 /* XXX many of the string copies here can be optimized if they're
11738 * constants; they need to be allocated as common memory and just
11739 * their pointers copied. */
11742 CLONE_PARAMS clone_params;
11743 CLONE_PARAMS* const param = &clone_params;
11745 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11747 PERL_ARGS_ASSERT_PERL_CLONE_USING;
11749 /* for each stash, determine whether its objects should be cloned */
11750 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11751 PERL_SET_THX(my_perl);
11754 PoisonNew(my_perl, 1, PerlInterpreter);
11760 PL_savestack_ix = 0;
11761 PL_savestack_max = -1;
11762 PL_sig_pending = 0;
11764 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11765 # else /* !DEBUGGING */
11766 Zero(my_perl, 1, PerlInterpreter);
11767 # endif /* DEBUGGING */
11769 /* host pointers */
11771 PL_MemShared = ipMS;
11772 PL_MemParse = ipMP;
11779 #else /* !PERL_IMPLICIT_SYS */
11781 CLONE_PARAMS clone_params;
11782 CLONE_PARAMS* param = &clone_params;
11783 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11785 PERL_ARGS_ASSERT_PERL_CLONE;
11787 /* for each stash, determine whether its objects should be cloned */
11788 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11789 PERL_SET_THX(my_perl);
11792 PoisonNew(my_perl, 1, PerlInterpreter);
11798 PL_savestack_ix = 0;
11799 PL_savestack_max = -1;
11800 PL_sig_pending = 0;
11802 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11803 # else /* !DEBUGGING */
11804 Zero(my_perl, 1, PerlInterpreter);
11805 # endif /* DEBUGGING */
11806 #endif /* PERL_IMPLICIT_SYS */
11807 param->flags = flags;
11808 param->proto_perl = proto_perl;
11810 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
11812 PL_body_arenas = NULL;
11813 Zero(&PL_body_roots, 1, PL_body_roots);
11815 PL_nice_chunk = NULL;
11816 PL_nice_chunk_size = 0;
11818 PL_sv_objcount = 0;
11820 PL_sv_arenaroot = NULL;
11822 PL_debug = proto_perl->Idebug;
11824 PL_hash_seed = proto_perl->Ihash_seed;
11825 PL_rehash_seed = proto_perl->Irehash_seed;
11827 #ifdef USE_REENTRANT_API
11828 /* XXX: things like -Dm will segfault here in perlio, but doing
11829 * PERL_SET_CONTEXT(proto_perl);
11830 * breaks too many other things
11832 Perl_reentrant_init(aTHX);
11835 /* create SV map for pointer relocation */
11836 PL_ptr_table = ptr_table_new();
11838 /* initialize these special pointers as early as possible */
11839 SvANY(&PL_sv_undef) = NULL;
11840 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11841 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11842 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11844 SvANY(&PL_sv_no) = new_XPVNV();
11845 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11846 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11847 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11848 SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
11849 SvCUR_set(&PL_sv_no, 0);
11850 SvLEN_set(&PL_sv_no, 1);
11851 SvIV_set(&PL_sv_no, 0);
11852 SvNV_set(&PL_sv_no, 0);
11853 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11855 SvANY(&PL_sv_yes) = new_XPVNV();
11856 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11857 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11858 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11859 SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
11860 SvCUR_set(&PL_sv_yes, 1);
11861 SvLEN_set(&PL_sv_yes, 2);
11862 SvIV_set(&PL_sv_yes, 1);
11863 SvNV_set(&PL_sv_yes, 1);
11864 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11866 /* create (a non-shared!) shared string table */
11867 PL_strtab = newHV();
11868 HvSHAREKEYS_off(PL_strtab);
11869 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
11870 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11872 PL_compiling = proto_perl->Icompiling;
11874 /* These two PVs will be free'd special way so must set them same way op.c does */
11875 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11876 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11878 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11879 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11881 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11882 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
11883 if (PL_compiling.cop_hints_hash) {
11885 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
11886 HINTS_REFCNT_UNLOCK;
11888 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
11889 #ifdef PERL_DEBUG_READONLY_OPS
11894 /* pseudo environmental stuff */
11895 PL_origargc = proto_perl->Iorigargc;
11896 PL_origargv = proto_perl->Iorigargv;
11898 param->stashes = newAV(); /* Setup array of objects to call clone on */
11900 /* Set tainting stuff before PerlIO_debug can possibly get called */
11901 PL_tainting = proto_perl->Itainting;
11902 PL_taint_warn = proto_perl->Itaint_warn;
11904 #ifdef PERLIO_LAYERS
11905 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11906 PerlIO_clone(aTHX_ proto_perl, param);
11909 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11910 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11911 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11912 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11913 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11914 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11917 PL_minus_c = proto_perl->Iminus_c;
11918 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11919 PL_localpatches = proto_perl->Ilocalpatches;
11920 PL_splitstr = proto_perl->Isplitstr;
11921 PL_minus_n = proto_perl->Iminus_n;
11922 PL_minus_p = proto_perl->Iminus_p;
11923 PL_minus_l = proto_perl->Iminus_l;
11924 PL_minus_a = proto_perl->Iminus_a;
11925 PL_minus_E = proto_perl->Iminus_E;
11926 PL_minus_F = proto_perl->Iminus_F;
11927 PL_doswitches = proto_perl->Idoswitches;
11928 PL_dowarn = proto_perl->Idowarn;
11929 PL_doextract = proto_perl->Idoextract;
11930 PL_sawampersand = proto_perl->Isawampersand;
11931 PL_unsafe = proto_perl->Iunsafe;
11932 PL_inplace = SAVEPV(proto_perl->Iinplace);
11933 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11934 PL_perldb = proto_perl->Iperldb;
11935 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11936 PL_exit_flags = proto_perl->Iexit_flags;
11938 /* magical thingies */
11939 /* XXX time(&PL_basetime) when asked for? */
11940 PL_basetime = proto_perl->Ibasetime;
11941 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11943 PL_maxsysfd = proto_perl->Imaxsysfd;
11944 PL_statusvalue = proto_perl->Istatusvalue;
11946 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11948 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
11950 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11952 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
11953 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
11954 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
11957 /* RE engine related */
11958 Zero(&PL_reg_state, 1, struct re_save_state);
11959 PL_reginterp_cnt = 0;
11960 PL_regmatch_slab = NULL;
11962 /* Clone the regex array */
11963 /* ORANGE FIXME for plugins, probably in the SV dup code.
11964 newSViv(PTR2IV(CALLREGDUPE(
11965 INT2PTR(REGEXP *, SvIVX(regex)), param))))
11967 PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
11968 PL_regex_pad = AvARRAY(PL_regex_padav);
11970 /* shortcuts to various I/O objects */
11971 PL_ofsgv = gv_dup(proto_perl->Iofsgv, param);
11972 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11973 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11974 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11975 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11976 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11977 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11979 /* shortcuts to regexp stuff */
11980 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11982 /* shortcuts to misc objects */
11983 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11985 /* shortcuts to debugging objects */
11986 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11987 PL_DBline = gv_dup(proto_perl->IDBline, param);
11988 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11989 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11990 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11991 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11992 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11994 /* symbol tables */
11995 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
11996 PL_curstash = hv_dup(proto_perl->Icurstash, param);
11997 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11998 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11999 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
12001 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
12002 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
12003 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
12004 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
12005 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
12006 PL_endav = av_dup_inc(proto_perl->Iendav, param);
12007 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
12008 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
12010 PL_sub_generation = proto_perl->Isub_generation;
12011 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
12013 /* funky return mechanisms */
12014 PL_forkprocess = proto_perl->Iforkprocess;
12016 /* subprocess state */
12017 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
12019 /* internal state */
12020 PL_maxo = proto_perl->Imaxo;
12021 if (proto_perl->Iop_mask)
12022 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
12025 /* PL_asserting = proto_perl->Iasserting; */
12027 /* current interpreter roots */
12028 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
12030 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
12032 PL_main_start = proto_perl->Imain_start;
12033 PL_eval_root = proto_perl->Ieval_root;
12034 PL_eval_start = proto_perl->Ieval_start;
12036 /* runtime control stuff */
12037 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
12039 PL_filemode = proto_perl->Ifilemode;
12040 PL_lastfd = proto_perl->Ilastfd;
12041 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
12044 PL_gensym = proto_perl->Igensym;
12045 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
12046 PL_laststatval = proto_perl->Ilaststatval;
12047 PL_laststype = proto_perl->Ilaststype;
12050 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
12052 /* interpreter atexit processing */
12053 PL_exitlistlen = proto_perl->Iexitlistlen;
12054 if (PL_exitlistlen) {
12055 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12056 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12059 PL_exitlist = (PerlExitListEntry*)NULL;
12061 PL_my_cxt_size = proto_perl->Imy_cxt_size;
12062 if (PL_my_cxt_size) {
12063 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
12064 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
12065 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12066 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
12067 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
12071 PL_my_cxt_list = (void**)NULL;
12072 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12073 PL_my_cxt_keys = (const char**)NULL;
12076 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
12077 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
12078 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
12080 PL_profiledata = NULL;
12082 PL_compcv = cv_dup(proto_perl->Icompcv, param);
12084 PAD_CLONE_VARS(proto_perl, param);
12086 #ifdef HAVE_INTERP_INTERN
12087 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
12090 /* more statics moved here */
12091 PL_generation = proto_perl->Igeneration;
12092 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
12094 PL_in_clean_objs = proto_perl->Iin_clean_objs;
12095 PL_in_clean_all = proto_perl->Iin_clean_all;
12097 PL_uid = proto_perl->Iuid;
12098 PL_euid = proto_perl->Ieuid;
12099 PL_gid = proto_perl->Igid;
12100 PL_egid = proto_perl->Iegid;
12101 PL_nomemok = proto_perl->Inomemok;
12102 PL_an = proto_perl->Ian;
12103 PL_evalseq = proto_perl->Ievalseq;
12104 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
12105 PL_origalen = proto_perl->Iorigalen;
12106 #ifdef PERL_USES_PL_PIDSTATUS
12107 PL_pidstatus = newHV(); /* XXX flag for cloning? */
12109 PL_osname = SAVEPV(proto_perl->Iosname);
12110 PL_sighandlerp = proto_perl->Isighandlerp;
12112 PL_runops = proto_perl->Irunops;
12114 PL_parser = parser_dup(proto_perl->Iparser, param);
12116 PL_subline = proto_perl->Isubline;
12117 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
12120 PL_cryptseen = proto_perl->Icryptseen;
12123 PL_hints = proto_perl->Ihints;
12125 PL_amagic_generation = proto_perl->Iamagic_generation;
12127 #ifdef USE_LOCALE_COLLATE
12128 PL_collation_ix = proto_perl->Icollation_ix;
12129 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
12130 PL_collation_standard = proto_perl->Icollation_standard;
12131 PL_collxfrm_base = proto_perl->Icollxfrm_base;
12132 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
12133 #endif /* USE_LOCALE_COLLATE */
12135 #ifdef USE_LOCALE_NUMERIC
12136 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
12137 PL_numeric_standard = proto_perl->Inumeric_standard;
12138 PL_numeric_local = proto_perl->Inumeric_local;
12139 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12140 #endif /* !USE_LOCALE_NUMERIC */
12142 /* utf8 character classes */
12143 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12144 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
12145 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12146 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12147 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
12148 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12149 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
12150 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
12151 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
12152 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
12153 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
12154 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
12155 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12156 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
12157 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12158 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12159 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12160 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12161 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12162 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12164 /* Did the locale setup indicate UTF-8? */
12165 PL_utf8locale = proto_perl->Iutf8locale;
12166 /* Unicode features (see perlrun/-C) */
12167 PL_unicode = proto_perl->Iunicode;
12169 /* Pre-5.8 signals control */
12170 PL_signals = proto_perl->Isignals;
12172 /* times() ticks per second */
12173 PL_clocktick = proto_perl->Iclocktick;
12175 /* Recursion stopper for PerlIO_find_layer */
12176 PL_in_load_module = proto_perl->Iin_load_module;
12178 /* sort() routine */
12179 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
12181 /* Not really needed/useful since the reenrant_retint is "volatile",
12182 * but do it for consistency's sake. */
12183 PL_reentrant_retint = proto_perl->Ireentrant_retint;
12185 /* Hooks to shared SVs and locks. */
12186 PL_sharehook = proto_perl->Isharehook;
12187 PL_lockhook = proto_perl->Ilockhook;
12188 PL_unlockhook = proto_perl->Iunlockhook;
12189 PL_threadhook = proto_perl->Ithreadhook;
12190 PL_destroyhook = proto_perl->Idestroyhook;
12192 #ifdef THREADS_HAVE_PIDS
12193 PL_ppid = proto_perl->Ippid;
12197 PL_last_swash_hv = NULL; /* reinits on demand */
12198 PL_last_swash_klen = 0;
12199 PL_last_swash_key[0]= '\0';
12200 PL_last_swash_tmps = (U8*)NULL;
12201 PL_last_swash_slen = 0;
12203 PL_glob_index = proto_perl->Iglob_index;
12204 PL_srand_called = proto_perl->Isrand_called;
12205 PL_bitcount = NULL; /* reinits on demand */
12207 if (proto_perl->Ipsig_pend) {
12208 Newxz(PL_psig_pend, SIG_SIZE, int);
12211 PL_psig_pend = (int*)NULL;
12214 if (proto_perl->Ipsig_ptr) {
12215 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
12216 Newxz(PL_psig_name, SIG_SIZE, SV*);
12217 for (i = 1; i < SIG_SIZE; i++) {
12218 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
12219 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
12223 PL_psig_ptr = (SV**)NULL;
12224 PL_psig_name = (SV**)NULL;
12227 /* intrpvar.h stuff */
12229 if (flags & CLONEf_COPY_STACKS) {
12230 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12231 PL_tmps_ix = proto_perl->Itmps_ix;
12232 PL_tmps_max = proto_perl->Itmps_max;
12233 PL_tmps_floor = proto_perl->Itmps_floor;
12234 Newxz(PL_tmps_stack, PL_tmps_max, SV*);
12236 while (i <= PL_tmps_ix) {
12237 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Itmps_stack[i], param);
12241 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12242 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
12243 Newxz(PL_markstack, i, I32);
12244 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
12245 - proto_perl->Imarkstack);
12246 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
12247 - proto_perl->Imarkstack);
12248 Copy(proto_perl->Imarkstack, PL_markstack,
12249 PL_markstack_ptr - PL_markstack + 1, I32);
12251 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12252 * NOTE: unlike the others! */
12253 PL_scopestack_ix = proto_perl->Iscopestack_ix;
12254 PL_scopestack_max = proto_perl->Iscopestack_max;
12255 Newxz(PL_scopestack, PL_scopestack_max, I32);
12256 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
12258 /* NOTE: si_dup() looks at PL_markstack */
12259 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
12261 /* PL_curstack = PL_curstackinfo->si_stack; */
12262 PL_curstack = av_dup(proto_perl->Icurstack, param);
12263 PL_mainstack = av_dup(proto_perl->Imainstack, param);
12265 /* next PUSHs() etc. set *(PL_stack_sp+1) */
12266 PL_stack_base = AvARRAY(PL_curstack);
12267 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
12268 - proto_perl->Istack_base);
12269 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
12271 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12272 * NOTE: unlike the others! */
12273 PL_savestack_ix = proto_perl->Isavestack_ix;
12274 PL_savestack_max = proto_perl->Isavestack_max;
12275 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
12276 PL_savestack = ss_dup(proto_perl, param);
12280 ENTER; /* perl_destruct() wants to LEAVE; */
12282 /* although we're not duplicating the tmps stack, we should still
12283 * add entries for any SVs on the tmps stack that got cloned by a
12284 * non-refcount means (eg a temp in @_); otherwise they will be
12287 for (i = 0; i<= proto_perl->Itmps_ix; i++) {
12288 SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table,
12289 proto_perl->Itmps_stack[i]));
12290 if (nsv && !SvREFCNT(nsv)) {
12292 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv);
12297 PL_start_env = proto_perl->Istart_env; /* XXXXXX */
12298 PL_top_env = &PL_start_env;
12300 PL_op = proto_perl->Iop;
12303 PL_Xpv = (XPV*)NULL;
12304 my_perl->Ina = proto_perl->Ina;
12306 PL_statbuf = proto_perl->Istatbuf;
12307 PL_statcache = proto_perl->Istatcache;
12308 PL_statgv = gv_dup(proto_perl->Istatgv, param);
12309 PL_statname = sv_dup_inc(proto_perl->Istatname, param);
12311 PL_timesbuf = proto_perl->Itimesbuf;
12314 PL_tainted = proto_perl->Itainted;
12315 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
12316 PL_rs = sv_dup_inc(proto_perl->Irs, param);
12317 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
12318 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
12319 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
12320 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
12321 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
12322 PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
12324 PL_restartop = proto_perl->Irestartop;
12325 PL_in_eval = proto_perl->Iin_eval;
12326 PL_delaymagic = proto_perl->Idelaymagic;
12327 PL_dirty = proto_perl->Idirty;
12328 PL_localizing = proto_perl->Ilocalizing;
12330 PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
12331 PL_hv_fetch_ent_mh = NULL;
12332 PL_modcount = proto_perl->Imodcount;
12333 PL_lastgotoprobe = NULL;
12334 PL_dumpindent = proto_perl->Idumpindent;
12336 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
12337 PL_sortstash = hv_dup(proto_perl->Isortstash, param);
12338 PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
12339 PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
12340 PL_efloatbuf = NULL; /* reinits on demand */
12341 PL_efloatsize = 0; /* reinits on demand */
12345 PL_screamfirst = NULL;
12346 PL_screamnext = NULL;
12347 PL_maxscream = -1; /* reinits on demand */
12348 PL_lastscream = NULL;
12351 PL_regdummy = proto_perl->Iregdummy;
12352 PL_colorset = 0; /* reinits PL_colors[] */
12353 /*PL_colors[6] = {0,0,0,0,0,0};*/
12357 /* Pluggable optimizer */
12358 PL_peepp = proto_perl->Ipeepp;
12360 PL_stashcache = newHV();
12362 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
12363 proto_perl->Iwatchaddr);
12364 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
12365 if (PL_debug && PL_watchaddr) {
12366 PerlIO_printf(Perl_debug_log,
12367 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
12368 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
12369 PTR2UV(PL_watchok));
12372 PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
12374 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12375 ptr_table_free(PL_ptr_table);
12376 PL_ptr_table = NULL;
12379 /* Call the ->CLONE method, if it exists, for each of the stashes
12380 identified by sv_dup() above.
12382 while(av_len(param->stashes) != -1) {
12383 HV* const stash = MUTABLE_HV(av_shift(param->stashes));
12384 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12385 if (cloner && GvCV(cloner)) {
12390 mXPUSHs(newSVhek(HvNAME_HEK(stash)));
12392 call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
12398 SvREFCNT_dec(param->stashes);
12400 /* orphaned? eg threads->new inside BEGIN or use */
12401 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12402 SvREFCNT_inc_simple_void(PL_compcv);
12403 SAVEFREESV(PL_compcv);
12409 #endif /* USE_ITHREADS */
12412 =head1 Unicode Support
12414 =for apidoc sv_recode_to_utf8
12416 The encoding is assumed to be an Encode object, on entry the PV
12417 of the sv is assumed to be octets in that encoding, and the sv
12418 will be converted into Unicode (and UTF-8).
12420 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12421 is not a reference, nothing is done to the sv. If the encoding is not
12422 an C<Encode::XS> Encoding object, bad things will happen.
12423 (See F<lib/encoding.pm> and L<Encode>).
12425 The PV of the sv is returned.
12430 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12434 PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
12436 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12450 Passing sv_yes is wrong - it needs to be or'ed set of constants
12451 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12452 remove converted chars from source.
12454 Both will default the value - let them.
12456 XPUSHs(&PL_sv_yes);
12459 call_method("decode", G_SCALAR);
12463 s = SvPV_const(uni, len);
12464 if (s != SvPVX_const(sv)) {
12465 SvGROW(sv, len + 1);
12466 Move(s, SvPVX(sv), len + 1, char);
12467 SvCUR_set(sv, len);
12474 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12478 =for apidoc sv_cat_decode
12480 The encoding is assumed to be an Encode object, the PV of the ssv is
12481 assumed to be octets in that encoding and decoding the input starts
12482 from the position which (PV + *offset) pointed to. The dsv will be
12483 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12484 when the string tstr appears in decoding output or the input ends on
12485 the PV of the ssv. The value which the offset points will be modified
12486 to the last input position on the ssv.
12488 Returns TRUE if the terminator was found, else returns FALSE.
12493 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12494 SV *ssv, int *offset, char *tstr, int tlen)
12499 PERL_ARGS_ASSERT_SV_CAT_DECODE;
12501 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12512 offsv = newSViv(*offset);
12514 mXPUSHp(tstr, tlen);
12516 call_method("cat_decode", G_SCALAR);
12518 ret = SvTRUE(TOPs);
12519 *offset = SvIV(offsv);
12525 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12530 /* ---------------------------------------------------------------------
12532 * support functions for report_uninit()
12535 /* the maxiumum size of array or hash where we will scan looking
12536 * for the undefined element that triggered the warning */
12538 #define FUV_MAX_SEARCH_SIZE 1000
12540 /* Look for an entry in the hash whose value has the same SV as val;
12541 * If so, return a mortal copy of the key. */
12544 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
12547 register HE **array;
12550 PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
12552 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
12553 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
12556 array = HvARRAY(hv);
12558 for (i=HvMAX(hv); i>0; i--) {
12559 register HE *entry;
12560 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
12561 if (HeVAL(entry) != val)
12563 if ( HeVAL(entry) == &PL_sv_undef ||
12564 HeVAL(entry) == &PL_sv_placeholder)
12568 if (HeKLEN(entry) == HEf_SVKEY)
12569 return sv_mortalcopy(HeKEY_sv(entry));
12570 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
12576 /* Look for an entry in the array whose value has the same SV as val;
12577 * If so, return the index, otherwise return -1. */
12580 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
12584 PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
12586 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
12587 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
12590 if (val != &PL_sv_undef) {
12591 SV ** const svp = AvARRAY(av);
12594 for (i=AvFILLp(av); i>=0; i--)
12601 /* S_varname(): return the name of a variable, optionally with a subscript.
12602 * If gv is non-zero, use the name of that global, along with gvtype (one
12603 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
12604 * targ. Depending on the value of the subscript_type flag, return:
12607 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
12608 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
12609 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
12610 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
12613 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
12614 const SV *const keyname, I32 aindex, int subscript_type)
12617 SV * const name = sv_newmortal();
12620 buffer[0] = gvtype;
12623 /* as gv_fullname4(), but add literal '^' for $^FOO names */
12625 gv_fullname4(name, gv, buffer, 0);
12627 if ((unsigned int)SvPVX(name)[1] <= 26) {
12629 buffer[1] = SvPVX(name)[1] + 'A' - 1;
12631 /* Swap the 1 unprintable control character for the 2 byte pretty
12632 version - ie substr($name, 1, 1) = $buffer; */
12633 sv_insert(name, 1, 1, buffer, 2);
12637 CV * const cv = find_runcv(NULL);
12641 if (!cv || !CvPADLIST(cv))
12643 av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
12644 sv = *av_fetch(av, targ, FALSE);
12645 sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
12648 if (subscript_type == FUV_SUBSCRIPT_HASH) {
12649 SV * const sv = newSV(0);
12650 *SvPVX(name) = '$';
12651 Perl_sv_catpvf(aTHX_ name, "{%s}",
12652 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
12655 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
12656 *SvPVX(name) = '$';
12657 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
12659 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
12660 /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
12661 Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
12669 =for apidoc find_uninit_var
12671 Find the name of the undefined variable (if any) that caused the operator o
12672 to issue a "Use of uninitialized value" warning.
12673 If match is true, only return a name if it's value matches uninit_sv.
12674 So roughly speaking, if a unary operator (such as OP_COS) generates a
12675 warning, then following the direct child of the op may yield an
12676 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
12677 other hand, with OP_ADD there are two branches to follow, so we only print
12678 the variable name if we get an exact match.
12680 The name is returned as a mortal SV.
12682 Assumes that PL_op is the op that originally triggered the error, and that
12683 PL_comppad/PL_curpad points to the currently executing pad.
12689 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
12695 const OP *o, *o2, *kid;
12697 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
12698 uninit_sv == &PL_sv_placeholder)))
12701 switch (obase->op_type) {
12708 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
12709 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
12712 int subscript_type = FUV_SUBSCRIPT_WITHIN;
12714 if (pad) { /* @lex, %lex */
12715 sv = PAD_SVl(obase->op_targ);
12719 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
12720 /* @global, %global */
12721 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
12724 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
12726 else /* @{expr}, %{expr} */
12727 return find_uninit_var(cUNOPx(obase)->op_first,
12731 /* attempt to find a match within the aggregate */
12733 keysv = find_hash_subscript((const HV*)sv, uninit_sv);
12735 subscript_type = FUV_SUBSCRIPT_HASH;
12738 index = find_array_subscript((const AV *)sv, uninit_sv);
12740 subscript_type = FUV_SUBSCRIPT_ARRAY;
12743 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
12746 return varname(gv, hash ? '%' : '@', obase->op_targ,
12747 keysv, index, subscript_type);
12751 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
12753 return varname(NULL, '$', obase->op_targ,
12754 NULL, 0, FUV_SUBSCRIPT_NONE);
12757 gv = cGVOPx_gv(obase);
12758 if (!gv || (match && GvSV(gv) != uninit_sv))
12760 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
12763 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
12766 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
12767 if (!av || SvRMAGICAL(av))
12769 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12770 if (!svp || *svp != uninit_sv)
12773 return varname(NULL, '$', obase->op_targ,
12774 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12777 gv = cGVOPx_gv(obase);
12782 AV *const av = GvAV(gv);
12783 if (!av || SvRMAGICAL(av))
12785 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12786 if (!svp || *svp != uninit_sv)
12789 return varname(gv, '$', 0,
12790 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12795 o = cUNOPx(obase)->op_first;
12796 if (!o || o->op_type != OP_NULL ||
12797 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
12799 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
12803 if (PL_op == obase)
12804 /* $a[uninit_expr] or $h{uninit_expr} */
12805 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
12808 o = cBINOPx(obase)->op_first;
12809 kid = cBINOPx(obase)->op_last;
12811 /* get the av or hv, and optionally the gv */
12813 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
12814 sv = PAD_SV(o->op_targ);
12816 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
12817 && cUNOPo->op_first->op_type == OP_GV)
12819 gv = cGVOPx_gv(cUNOPo->op_first);
12823 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
12828 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
12829 /* index is constant */
12833 if (obase->op_type == OP_HELEM) {
12834 HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
12835 if (!he || HeVAL(he) != uninit_sv)
12839 SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
12840 if (!svp || *svp != uninit_sv)
12844 if (obase->op_type == OP_HELEM)
12845 return varname(gv, '%', o->op_targ,
12846 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
12848 return varname(gv, '@', o->op_targ, NULL,
12849 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
12852 /* index is an expression;
12853 * attempt to find a match within the aggregate */
12854 if (obase->op_type == OP_HELEM) {
12855 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
12857 return varname(gv, '%', o->op_targ,
12858 keysv, 0, FUV_SUBSCRIPT_HASH);
12862 = find_array_subscript((const AV *)sv, uninit_sv);
12864 return varname(gv, '@', o->op_targ,
12865 NULL, index, FUV_SUBSCRIPT_ARRAY);
12870 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
12872 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
12877 /* only examine RHS */
12878 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
12881 o = cUNOPx(obase)->op_first;
12882 if (o->op_type == OP_PUSHMARK)
12885 if (!o->op_sibling) {
12886 /* one-arg version of open is highly magical */
12888 if (o->op_type == OP_GV) { /* open FOO; */
12890 if (match && GvSV(gv) != uninit_sv)
12892 return varname(gv, '$', 0,
12893 NULL, 0, FUV_SUBSCRIPT_NONE);
12895 /* other possibilities not handled are:
12896 * open $x; or open my $x; should return '${*$x}'
12897 * open expr; should return '$'.expr ideally
12903 /* ops where $_ may be an implicit arg */
12907 if ( !(obase->op_flags & OPf_STACKED)) {
12908 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
12909 ? PAD_SVl(obase->op_targ)
12912 sv = sv_newmortal();
12913 sv_setpvs(sv, "$_");
12922 match = 1; /* print etc can return undef on defined args */
12923 /* skip filehandle as it can't produce 'undef' warning */
12924 o = cUNOPx(obase)->op_first;
12925 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
12926 o = o->op_sibling->op_sibling;
12930 case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
12932 case OP_CUSTOM: /* XS or custom code could trigger random warnings */
12934 /* the following ops are capable of returning PL_sv_undef even for
12935 * defined arg(s) */
12954 case OP_GETPEERNAME:
13002 case OP_SMARTMATCH:
13011 /* XXX tmp hack: these two may call an XS sub, and currently
13012 XS subs don't have a SUB entry on the context stack, so CV and
13013 pad determination goes wrong, and BAD things happen. So, just
13014 don't try to determine the value under those circumstances.
13015 Need a better fix at dome point. DAPM 11/2007 */
13020 /* def-ness of rval pos() is independent of the def-ness of its arg */
13021 if ( !(obase->op_flags & OPf_MOD))
13026 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
13027 return newSVpvs_flags("${$/}", SVs_TEMP);
13032 if (!(obase->op_flags & OPf_KIDS))
13034 o = cUNOPx(obase)->op_first;
13040 /* if all except one arg are constant, or have no side-effects,
13041 * or are optimized away, then it's unambiguous */
13043 for (kid=o; kid; kid = kid->op_sibling) {
13045 const OPCODE type = kid->op_type;
13046 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
13047 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
13048 || (type == OP_PUSHMARK)
13052 if (o2) { /* more than one found */
13059 return find_uninit_var(o2, uninit_sv, match);
13061 /* scan all args */
13063 sv = find_uninit_var(o, uninit_sv, 1);
13075 =for apidoc report_uninit
13077 Print appropriate "Use of uninitialized variable" warning
13083 Perl_report_uninit(pTHX_ const SV *uninit_sv)
13087 SV* varname = NULL;
13089 varname = find_uninit_var(PL_op, uninit_sv,0);
13091 sv_insert(varname, 0, 0, " ", 1);
13093 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13094 varname ? SvPV_nolen_const(varname) : "",
13095 " in ", OP_DESC(PL_op));
13098 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13104 * c-indentation-style: bsd
13105 * c-basic-offset: 4
13106 * indent-tabs-mode: t
13109 * ex: set ts=8 sts=4 sw=4 noet: