3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'I wonder what the Entish is for "yes" and "no",' he thought.
16 * [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
22 * This file contains the code that creates, manipulates and destroys
23 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
24 * structure of an SV, so their creation and destruction is handled
25 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
26 * level functions (eg. substr, split, join) for each of the types are
38 /* Missing proto on LynxOS */
39 char *gconvert(double, int, int, char *);
42 #ifdef PERL_UTF8_CACHE_ASSERT
43 /* if adding more checks watch out for the following tests:
44 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
45 * lib/utf8.t lib/Unicode/Collate/t/index.t
48 # define ASSERT_UTF8_CACHE(cache) \
49 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
50 assert((cache)[2] <= (cache)[3]); \
51 assert((cache)[3] <= (cache)[1]);} \
54 # define ASSERT_UTF8_CACHE(cache) NOOP
57 #ifdef PERL_OLD_COPY_ON_WRITE
58 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
59 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
60 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
64 /* ============================================================================
66 =head1 Allocation and deallocation of SVs.
68 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
69 sv, av, hv...) contains type and reference count information, and for
70 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
71 contains fields specific to each type. Some types store all they need
72 in the head, so don't have a body.
74 In all but the most memory-paranoid configuations (ex: PURIFY), heads
75 and bodies are allocated out of arenas, which by default are
76 approximately 4K chunks of memory parcelled up into N heads or bodies.
77 Sv-bodies are allocated by their sv-type, guaranteeing size
78 consistency needed to allocate safely from arrays.
80 For SV-heads, the first slot in each arena is reserved, and holds a
81 link to the next arena, some flags, and a note of the number of slots.
82 Snaked through each arena chain is a linked list of free items; when
83 this becomes empty, an extra arena is allocated and divided up into N
84 items which are threaded into the free list.
86 SV-bodies are similar, but they use arena-sets by default, which
87 separate the link and info from the arena itself, and reclaim the 1st
88 slot in the arena. SV-bodies are further described later.
90 The following global variables are associated with arenas:
92 PL_sv_arenaroot pointer to list of SV arenas
93 PL_sv_root pointer to list of free SV structures
95 PL_body_arenas head of linked-list of body arenas
96 PL_body_roots[] array of pointers to list of free bodies of svtype
97 arrays are indexed by the svtype needed
99 A few special SV heads are not allocated from an arena, but are
100 instead directly created in the interpreter structure, eg PL_sv_undef.
101 The size of arenas can be changed from the default by setting
102 PERL_ARENA_SIZE appropriately at compile time.
104 The SV arena serves the secondary purpose of allowing still-live SVs
105 to be located and destroyed during final cleanup.
107 At the lowest level, the macros new_SV() and del_SV() grab and free
108 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
109 to return the SV to the free list with error checking.) new_SV() calls
110 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
111 SVs in the free list have their SvTYPE field set to all ones.
113 At the time of very final cleanup, sv_free_arenas() is called from
114 perl_destruct() to physically free all the arenas allocated since the
115 start of the interpreter.
117 The function visit() scans the SV arenas list, and calls a specified
118 function for each SV it finds which is still live - ie which has an SvTYPE
119 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
120 following functions (specified as [function that calls visit()] / [function
121 called by visit() for each SV]):
123 sv_report_used() / do_report_used()
124 dump all remaining SVs (debugging aid)
126 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
127 Attempt to free all objects pointed to by RVs,
128 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
129 try to do the same for all objects indirectly
130 referenced by typeglobs too. Called once from
131 perl_destruct(), prior to calling sv_clean_all()
134 sv_clean_all() / do_clean_all()
135 SvREFCNT_dec(sv) each remaining SV, possibly
136 triggering an sv_free(). It also sets the
137 SVf_BREAK flag on the SV to indicate that the
138 refcnt has been artificially lowered, and thus
139 stopping sv_free() from giving spurious warnings
140 about SVs which unexpectedly have a refcnt
141 of zero. called repeatedly from perl_destruct()
142 until there are no SVs left.
144 =head2 Arena allocator API Summary
146 Private API to rest of sv.c
150 new_XIV(), del_XIV(),
151 new_XNV(), del_XNV(),
156 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
160 * ========================================================================= */
163 * "A time to plant, and a time to uproot what was planted..."
167 Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size)
173 PERL_ARGS_ASSERT_OFFER_NICE_CHUNK;
175 new_chunk = (void *)(chunk);
176 new_chunk_size = (chunk_size);
177 if (new_chunk_size > PL_nice_chunk_size) {
178 Safefree(PL_nice_chunk);
179 PL_nice_chunk = (char *) new_chunk;
180 PL_nice_chunk_size = new_chunk_size;
187 # define MEM_LOG_NEW_SV(sv, file, line, func) \
188 Perl_mem_log_new_sv(sv, file, line, func)
189 # define MEM_LOG_DEL_SV(sv, file, line, func) \
190 Perl_mem_log_del_sv(sv, file, line, func)
192 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
193 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
196 #ifdef DEBUG_LEAKING_SCALARS
197 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
198 # define DEBUG_SV_SERIAL(sv) \
199 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
200 PTR2UV(sv), (long)(sv)->sv_debug_serial))
202 # define FREE_SV_DEBUG_FILE(sv)
203 # define DEBUG_SV_SERIAL(sv) NOOP
207 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
208 # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
209 /* Whilst I'd love to do this, it seems that things like to check on
211 # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
213 # define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
214 PoisonNew(&SvREFCNT(sv), 1, U32)
216 # define SvARENA_CHAIN(sv) SvANY(sv)
217 # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
218 # define POSION_SV_HEAD(sv)
221 /* Mark an SV head as unused, and add to free list.
223 * If SVf_BREAK is set, skip adding it to the free list, as this SV had
224 * its refcount artificially decremented during global destruction, so
225 * there may be dangling pointers to it. The last thing we want in that
226 * case is for it to be reused. */
228 #define plant_SV(p) \
230 const U32 old_flags = SvFLAGS(p); \
231 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
232 DEBUG_SV_SERIAL(p); \
233 FREE_SV_DEBUG_FILE(p); \
235 SvFLAGS(p) = SVTYPEMASK; \
236 if (!(old_flags & SVf_BREAK)) { \
237 SvARENA_CHAIN_SET(p, PL_sv_root); \
243 #define uproot_SV(p) \
246 PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
251 /* make some more SVs by adding another arena */
260 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
261 PL_nice_chunk = NULL;
262 PL_nice_chunk_size = 0;
265 char *chunk; /* must use New here to match call to */
266 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
267 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
273 /* new_SV(): return a new, empty SV head */
275 #ifdef DEBUG_LEAKING_SCALARS
276 /* provide a real function for a debugger to play with */
278 S_new_SV(pTHX_ const char *file, int line, const char *func)
285 sv = S_more_sv(aTHX);
289 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
290 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
296 sv->sv_debug_inpad = 0;
297 sv->sv_debug_cloned = 0;
298 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
300 sv->sv_debug_serial = PL_sv_serial++;
302 MEM_LOG_NEW_SV(sv, file, line, func);
303 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
304 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
308 # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
316 (p) = S_more_sv(aTHX); \
320 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
325 /* del_SV(): return an empty SV head to the free list */
338 S_del_sv(pTHX_ SV *p)
342 PERL_ARGS_ASSERT_DEL_SV;
347 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
348 const SV * const sv = sva + 1;
349 const SV * const svend = &sva[SvREFCNT(sva)];
350 if (p >= sv && p < svend) {
356 Perl_ck_warner_d(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 svtype utype; /* bodytype stored in arena */
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
693 Arena types 2 & 3 are chained by body-type off an array of
694 arena-root pointers, which is indexed by svtype. Some of the
695 larger/less used body types are malloced singly, since a large
696 unused block of them is wasteful. Also, several svtypes dont have
697 bodies; the data fits into the sv-head itself. The arena-root
698 pointer thus has a few unused root-pointers (which may be hijacked
699 later for arena types 4,5)
701 3 differs from 2 as an optimization; some body types have several
702 unused fields in the front of the structure (which are kept in-place
703 for consistency). These bodies can be allocated in smaller chunks,
704 because the leading fields arent accessed. Pointers to such bodies
705 are decremented to point at the unused 'ghost' memory, knowing that
706 the pointers are used with offsets to the real memory.
708 HE, HEK arenas are managed separately, with separate code, but may
709 be merge-able later..
712 /* get_arena(size): this creates custom-sized arenas
713 TBD: export properly for hv.c: S_more_he().
716 Perl_get_arena(pTHX_ const size_t arena_size, const svtype bodytype)
719 struct arena_desc* adesc;
720 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
723 /* shouldnt need this
724 if (!arena_size) arena_size = PERL_ARENA_SIZE;
727 /* may need new arena-set to hold new arena */
728 if (!aroot || aroot->curr >= aroot->set_size) {
729 struct arena_set *newroot;
730 Newxz(newroot, 1, struct arena_set);
731 newroot->set_size = ARENAS_PER_SET;
732 newroot->next = aroot;
734 PL_body_arenas = (void *) newroot;
735 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
738 /* ok, now have arena-set with at least 1 empty/available arena-desc */
739 curr = aroot->curr++;
740 adesc = &(aroot->set[curr]);
741 assert(!adesc->arena);
743 Newx(adesc->arena, arena_size, char);
744 adesc->size = arena_size;
745 adesc->utype = bodytype;
746 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
747 curr, (void*)adesc->arena, (UV)arena_size));
753 /* return a thing to the free list */
755 #define del_body(thing, root) \
757 void ** const thing_copy = (void **)thing;\
758 *thing_copy = *root; \
759 *root = (void*)thing_copy; \
764 =head1 SV-Body Allocation
766 Allocation of SV-bodies is similar to SV-heads, differing as follows;
767 the allocation mechanism is used for many body types, so is somewhat
768 more complicated, it uses arena-sets, and has no need for still-live
771 At the outermost level, (new|del)_X*V macros return bodies of the
772 appropriate type. These macros call either (new|del)_body_type or
773 (new|del)_body_allocated macro pairs, depending on specifics of the
774 type. Most body types use the former pair, the latter pair is used to
775 allocate body types with "ghost fields".
777 "ghost fields" are fields that are unused in certain types, and
778 consequently don't need to actually exist. They are declared because
779 they're part of a "base type", which allows use of functions as
780 methods. The simplest examples are AVs and HVs, 2 aggregate types
781 which don't use the fields which support SCALAR semantics.
783 For these types, the arenas are carved up into appropriately sized
784 chunks, we thus avoid wasted memory for those unaccessed members.
785 When bodies are allocated, we adjust the pointer back in memory by the
786 size of the part not allocated, so it's as if we allocated the full
787 structure. (But things will all go boom if you write to the part that
788 is "not there", because you'll be overwriting the last members of the
789 preceding structure in memory.)
791 We calculate the correction using the STRUCT_OFFSET macro on the first
792 member present. If the allocated structure is smaller (no initial NV
793 actually allocated) then the net effect is to subtract the size of the NV
794 from the pointer, to return a new pointer as if an initial NV were actually
795 allocated. (We were using structures named *_allocated for this, but
796 this turned out to be a subtle bug, because a structure without an NV
797 could have a lower alignment constraint, but the compiler is allowed to
798 optimised accesses based on the alignment constraint of the actual pointer
799 to the full structure, for example, using a single 64 bit load instruction
800 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
802 This is the same trick as was used for NV and IV bodies. Ironically it
803 doesn't need to be used for NV bodies any more, because NV is now at
804 the start of the structure. IV bodies don't need it either, because
805 they are no longer allocated.
807 In turn, the new_body_* allocators call S_new_body(), which invokes
808 new_body_inline macro, which takes a lock, and takes a body off the
809 linked list at PL_body_roots[sv_type], calling S_more_bodies() if
810 necessary to refresh an empty list. Then the lock is released, and
811 the body is returned.
813 S_more_bodies calls get_arena(), and carves it up into an array of N
814 bodies, which it strings into a linked list. It looks up arena-size
815 and body-size from the body_details table described below, thus
816 supporting the multiple body-types.
818 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
819 the (new|del)_X*V macros are mapped directly to malloc/free.
825 For each sv-type, struct body_details bodies_by_type[] carries
826 parameters which control these aspects of SV handling:
828 Arena_size determines whether arenas are used for this body type, and if
829 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
830 zero, forcing individual mallocs and frees.
832 Body_size determines how big a body is, and therefore how many fit into
833 each arena. Offset carries the body-pointer adjustment needed for
834 "ghost fields", and is used in *_allocated macros.
836 But its main purpose is to parameterize info needed in
837 Perl_sv_upgrade(). The info here dramatically simplifies the function
838 vs the implementation in 5.8.8, making it table-driven. All fields
839 are used for this, except for arena_size.
841 For the sv-types that have no bodies, arenas are not used, so those
842 PL_body_roots[sv_type] are unused, and can be overloaded. In
843 something of a special case, SVt_NULL is borrowed for HE arenas;
844 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
845 bodies_by_type[SVt_NULL] slot is not used, as the table is not
850 struct body_details {
851 U8 body_size; /* Size to allocate */
852 U8 copy; /* Size of structure to copy (may be shorter) */
854 unsigned int type : 4; /* We have space for a sanity check. */
855 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
856 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
857 unsigned int arena : 1; /* Allocated from an arena */
858 size_t arena_size; /* Size of arena to allocate */
866 /* With -DPURFIY we allocate everything directly, and don't use arenas.
867 This seems a rather elegant way to simplify some of the code below. */
868 #define HASARENA FALSE
870 #define HASARENA TRUE
872 #define NOARENA FALSE
874 /* Size the arenas to exactly fit a given number of bodies. A count
875 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
876 simplifying the default. If count > 0, the arena is sized to fit
877 only that many bodies, allowing arenas to be used for large, rare
878 bodies (XPVFM, XPVIO) without undue waste. The arena size is
879 limited by PERL_ARENA_SIZE, so we can safely oversize the
882 #define FIT_ARENA0(body_size) \
883 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
884 #define FIT_ARENAn(count,body_size) \
885 ( count * body_size <= PERL_ARENA_SIZE) \
886 ? count * body_size \
887 : FIT_ARENA0 (body_size)
888 #define FIT_ARENA(count,body_size) \
890 ? FIT_ARENAn (count, body_size) \
891 : FIT_ARENA0 (body_size)
893 /* Calculate the length to copy. Specifically work out the length less any
894 final padding the compiler needed to add. See the comment in sv_upgrade
895 for why copying the padding proved to be a bug. */
897 #define copy_length(type, last_member) \
898 STRUCT_OFFSET(type, last_member) \
899 + sizeof (((type*)SvANY((const SV *)0))->last_member)
901 static const struct body_details bodies_by_type[] = {
902 { sizeof(HE), 0, 0, SVt_NULL,
903 FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
905 /* The bind placeholder pretends to be an RV for now.
906 Also it's marked as "can't upgrade" to stop anyone using it before it's
908 { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
910 /* IVs are in the head, so the allocation size is 0. */
912 sizeof(IV), /* This is used to copy out the IV body. */
913 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
914 NOARENA /* IVS don't need an arena */, 0
917 /* 8 bytes on most ILP32 with IEEE doubles */
918 { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA,
919 FIT_ARENA(0, sizeof(NV)) },
921 /* 8 bytes on most ILP32 with IEEE doubles */
922 { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
923 copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
924 + STRUCT_OFFSET(XPV, xpv_cur),
925 SVt_PV, FALSE, NONV, HASARENA,
926 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
929 { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
930 copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
931 + STRUCT_OFFSET(XPVIV, xpv_cur),
932 SVt_PVIV, FALSE, NONV, HASARENA,
933 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
936 { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV,
937 HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
940 { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
941 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
944 { sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur),
945 sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur),
946 + STRUCT_OFFSET(regexp, xpv_cur),
947 SVt_REGEXP, FALSE, NONV, HASARENA,
948 FIT_ARENA(0, sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur))
952 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
953 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
956 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
957 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
959 { sizeof(XPVAV) - STRUCT_OFFSET(XPVAV, xav_fill),
960 copy_length(XPVAV, xmg_stash) - STRUCT_OFFSET(XPVAV, xav_fill),
961 + STRUCT_OFFSET(XPVAV, xav_fill),
962 SVt_PVAV, TRUE, NONV, HASARENA,
963 FIT_ARENA(0, sizeof(XPVAV) - STRUCT_OFFSET(XPVAV, xav_fill)) },
965 { sizeof(XPVHV) - STRUCT_OFFSET(XPVHV, xhv_fill),
966 copy_length(XPVHV, xmg_stash) - STRUCT_OFFSET(XPVHV, xhv_fill),
967 + STRUCT_OFFSET(XPVHV, xhv_fill),
968 SVt_PVHV, TRUE, NONV, HASARENA,
969 FIT_ARENA(0, sizeof(XPVHV) - STRUCT_OFFSET(XPVHV, xhv_fill)) },
972 { sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur),
973 sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur),
974 + STRUCT_OFFSET(XPVCV, xpv_cur),
975 SVt_PVCV, TRUE, NONV, HASARENA,
976 FIT_ARENA(0, sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur)) },
978 { sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur),
979 sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur),
980 + STRUCT_OFFSET(XPVFM, xpv_cur),
981 SVt_PVFM, TRUE, NONV, NOARENA,
982 FIT_ARENA(20, sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur)) },
984 /* XPVIO is 84 bytes, fits 48x */
985 { sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur),
986 sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur),
987 + STRUCT_OFFSET(XPVIO, xpv_cur),
988 SVt_PVIO, TRUE, NONV, HASARENA,
989 FIT_ARENA(24, sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur)) },
992 #define new_body_type(sv_type) \
993 (void *)((char *)S_new_body(aTHX_ sv_type))
995 #define del_body_type(p, sv_type) \
996 del_body(p, &PL_body_roots[sv_type])
999 #define new_body_allocated(sv_type) \
1000 (void *)((char *)S_new_body(aTHX_ sv_type) \
1001 - bodies_by_type[sv_type].offset)
1003 #define del_body_allocated(p, sv_type) \
1004 del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
1007 #define my_safemalloc(s) (void*)safemalloc(s)
1008 #define my_safecalloc(s) (void*)safecalloc(s, 1)
1009 #define my_safefree(p) safefree((char*)p)
1013 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1014 #define del_XNV(p) my_safefree(p)
1016 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1017 #define del_XPVNV(p) my_safefree(p)
1019 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1020 #define del_XPVAV(p) my_safefree(p)
1022 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1023 #define del_XPVHV(p) my_safefree(p)
1025 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1026 #define del_XPVMG(p) my_safefree(p)
1028 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1029 #define del_XPVGV(p) my_safefree(p)
1033 #define new_XNV() new_body_type(SVt_NV)
1034 #define del_XNV(p) del_body_type(p, SVt_NV)
1036 #define new_XPVNV() new_body_type(SVt_PVNV)
1037 #define del_XPVNV(p) del_body_type(p, SVt_PVNV)
1039 #define new_XPVAV() new_body_allocated(SVt_PVAV)
1040 #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
1042 #define new_XPVHV() new_body_allocated(SVt_PVHV)
1043 #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
1045 #define new_XPVMG() new_body_type(SVt_PVMG)
1046 #define del_XPVMG(p) del_body_type(p, SVt_PVMG)
1048 #define new_XPVGV() new_body_type(SVt_PVGV)
1049 #define del_XPVGV(p) del_body_type(p, SVt_PVGV)
1053 /* no arena for you! */
1055 #define new_NOARENA(details) \
1056 my_safemalloc((details)->body_size + (details)->offset)
1057 #define new_NOARENAZ(details) \
1058 my_safecalloc((details)->body_size + (details)->offset)
1061 S_more_bodies (pTHX_ const svtype sv_type)
1064 void ** const root = &PL_body_roots[sv_type];
1065 const struct body_details * const bdp = &bodies_by_type[sv_type];
1066 const size_t body_size = bdp->body_size;
1069 const size_t arena_size = Perl_malloc_good_size(bdp->arena_size);
1070 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1071 static bool done_sanity_check;
1073 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1074 * variables like done_sanity_check. */
1075 if (!done_sanity_check) {
1076 unsigned int i = SVt_LAST;
1078 done_sanity_check = TRUE;
1081 assert (bodies_by_type[i].type == i);
1085 assert(bdp->arena_size);
1087 start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type);
1089 end = start + arena_size - 2 * body_size;
1091 /* computed count doesnt reflect the 1st slot reservation */
1092 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1093 DEBUG_m(PerlIO_printf(Perl_debug_log,
1094 "arena %p end %p arena-size %d (from %d) type %d "
1096 (void*)start, (void*)end, (int)arena_size,
1097 (int)bdp->arena_size, sv_type, (int)body_size,
1098 (int)arena_size / (int)body_size));
1100 DEBUG_m(PerlIO_printf(Perl_debug_log,
1101 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1102 (void*)start, (void*)end,
1103 (int)bdp->arena_size, sv_type, (int)body_size,
1104 (int)bdp->arena_size / (int)body_size));
1106 *root = (void *)start;
1108 while (start <= end) {
1109 char * const next = start + body_size;
1110 *(void**) start = (void *)next;
1113 *(void **)start = 0;
1118 /* grab a new thing from the free list, allocating more if necessary.
1119 The inline version is used for speed in hot routines, and the
1120 function using it serves the rest (unless PURIFY).
1122 #define new_body_inline(xpv, sv_type) \
1124 void ** const r3wt = &PL_body_roots[sv_type]; \
1125 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1126 ? *((void **)(r3wt)) : more_bodies(sv_type)); \
1127 *(r3wt) = *(void**)(xpv); \
1133 S_new_body(pTHX_ const svtype sv_type)
1137 new_body_inline(xpv, sv_type);
1143 static const struct body_details fake_rv =
1144 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1147 =for apidoc sv_upgrade
1149 Upgrade an SV to a more complex form. Generally adds a new body type to the
1150 SV, then copies across as much information as possible from the old body.
1151 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1157 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1162 const svtype old_type = SvTYPE(sv);
1163 const struct body_details *new_type_details;
1164 const struct body_details *old_type_details
1165 = bodies_by_type + old_type;
1166 SV *referant = NULL;
1168 PERL_ARGS_ASSERT_SV_UPGRADE;
1170 if (old_type == new_type)
1173 /* This clause was purposefully added ahead of the early return above to
1174 the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1175 inference by Nick I-S that it would fix other troublesome cases. See
1176 changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1178 Given that shared hash key scalars are no longer PVIV, but PV, there is
1179 no longer need to unshare so as to free up the IVX slot for its proper
1180 purpose. So it's safe to move the early return earlier. */
1182 if (new_type != SVt_PV && SvIsCOW(sv)) {
1183 sv_force_normal_flags(sv, 0);
1186 old_body = SvANY(sv);
1188 /* Copying structures onto other structures that have been neatly zeroed
1189 has a subtle gotcha. Consider XPVMG
1191 +------+------+------+------+------+-------+-------+
1192 | NV | CUR | LEN | IV | MAGIC | STASH |
1193 +------+------+------+------+------+-------+-------+
1194 0 4 8 12 16 20 24 28
1196 where NVs are aligned to 8 bytes, so that sizeof that structure is
1197 actually 32 bytes long, with 4 bytes of padding at the end:
1199 +------+------+------+------+------+-------+-------+------+
1200 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1201 +------+------+------+------+------+-------+-------+------+
1202 0 4 8 12 16 20 24 28 32
1204 so what happens if you allocate memory for this structure:
1206 +------+------+------+------+------+-------+-------+------+------+...
1207 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1208 +------+------+------+------+------+-------+-------+------+------+...
1209 0 4 8 12 16 20 24 28 32 36
1211 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1212 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1213 started out as zero once, but it's quite possible that it isn't. So now,
1214 rather than a nicely zeroed GP, you have it pointing somewhere random.
1217 (In fact, GP ends up pointing at a previous GP structure, because the
1218 principle cause of the padding in XPVMG getting garbage is a copy of
1219 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1220 this happens to be moot because XPVGV has been re-ordered, with GP
1221 no longer after STASH)
1223 So we are careful and work out the size of used parts of all the
1231 referant = SvRV(sv);
1232 old_type_details = &fake_rv;
1233 if (new_type == SVt_NV)
1234 new_type = SVt_PVNV;
1236 if (new_type < SVt_PVIV) {
1237 new_type = (new_type == SVt_NV)
1238 ? SVt_PVNV : SVt_PVIV;
1243 if (new_type < SVt_PVNV) {
1244 new_type = SVt_PVNV;
1248 assert(new_type > SVt_PV);
1249 assert(SVt_IV < SVt_PV);
1250 assert(SVt_NV < SVt_PV);
1257 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1258 there's no way that it can be safely upgraded, because perl.c
1259 expects to Safefree(SvANY(PL_mess_sv)) */
1260 assert(sv != PL_mess_sv);
1261 /* This flag bit is used to mean other things in other scalar types.
1262 Given that it only has meaning inside the pad, it shouldn't be set
1263 on anything that can get upgraded. */
1264 assert(!SvPAD_TYPED(sv));
1267 if (old_type_details->cant_upgrade)
1268 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1269 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1272 if (old_type > new_type)
1273 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1274 (int)old_type, (int)new_type);
1276 new_type_details = bodies_by_type + new_type;
1278 SvFLAGS(sv) &= ~SVTYPEMASK;
1279 SvFLAGS(sv) |= new_type;
1281 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1282 the return statements above will have triggered. */
1283 assert (new_type != SVt_NULL);
1286 assert(old_type == SVt_NULL);
1287 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1291 assert(old_type == SVt_NULL);
1292 SvANY(sv) = new_XNV();
1297 assert(new_type_details->body_size);
1300 assert(new_type_details->arena);
1301 assert(new_type_details->arena_size);
1302 /* This points to the start of the allocated area. */
1303 new_body_inline(new_body, new_type);
1304 Zero(new_body, new_type_details->body_size, char);
1305 new_body = ((char *)new_body) - new_type_details->offset;
1307 /* We always allocated the full length item with PURIFY. To do this
1308 we fake things so that arena is false for all 16 types.. */
1309 new_body = new_NOARENAZ(new_type_details);
1311 SvANY(sv) = new_body;
1312 if (new_type == SVt_PVAV) {
1316 if (old_type_details->body_size) {
1319 /* It will have been zeroed when the new body was allocated.
1320 Lets not write to it, in case it confuses a write-back
1326 #ifndef NODEFAULT_SHAREKEYS
1327 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1329 HvMAX(sv) = 7; /* (start with 8 buckets) */
1330 if (old_type_details->body_size) {
1333 /* It will have been zeroed when the new body was allocated.
1334 Lets not write to it, in case it confuses a write-back
1339 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1340 The target created by newSVrv also is, and it can have magic.
1341 However, it never has SvPVX set.
1343 if (old_type == SVt_IV) {
1345 } else if (old_type >= SVt_PV) {
1346 assert(SvPVX_const(sv) == 0);
1349 if (old_type >= SVt_PVMG) {
1350 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1351 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1353 sv->sv_u.svu_array = NULL; /* or svu_hash */
1359 /* This ensures that SvTHINKFIRST(sv) is true, and hence that
1360 sv_force_normal_flags(sv) is called. */
1363 /* XXX Is this still needed? Was it ever needed? Surely as there is
1364 no route from NV to PVIV, NOK can never be true */
1365 assert(!SvNOKp(sv));
1376 assert(new_type_details->body_size);
1377 /* We always allocated the full length item with PURIFY. To do this
1378 we fake things so that arena is false for all 16 types.. */
1379 if(new_type_details->arena) {
1380 /* This points to the start of the allocated area. */
1381 new_body_inline(new_body, new_type);
1382 Zero(new_body, new_type_details->body_size, char);
1383 new_body = ((char *)new_body) - new_type_details->offset;
1385 new_body = new_NOARENAZ(new_type_details);
1387 SvANY(sv) = new_body;
1389 if (old_type_details->copy) {
1390 /* There is now the potential for an upgrade from something without
1391 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1392 int offset = old_type_details->offset;
1393 int length = old_type_details->copy;
1395 if (new_type_details->offset > old_type_details->offset) {
1396 const int difference
1397 = new_type_details->offset - old_type_details->offset;
1398 offset += difference;
1399 length -= difference;
1401 assert (length >= 0);
1403 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1407 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1408 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1409 * correct 0.0 for us. Otherwise, if the old body didn't have an
1410 * NV slot, but the new one does, then we need to initialise the
1411 * freshly created NV slot with whatever the correct bit pattern is
1413 if (old_type_details->zero_nv && !new_type_details->zero_nv
1414 && !isGV_with_GP(sv))
1418 if (new_type == SVt_PVIO) {
1419 IO * const io = MUTABLE_IO(sv);
1420 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1423 /* Clear the stashcache because a new IO could overrule a package
1425 hv_clear(PL_stashcache);
1427 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1428 IoPAGE_LEN(sv) = 60;
1430 if (old_type < SVt_PV) {
1431 /* referant will be NULL unless the old type was SVt_IV emulating
1433 sv->sv_u.svu_rv = referant;
1437 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1438 (unsigned long)new_type);
1441 if (old_type > SVt_IV) {
1443 my_safefree(old_body);
1445 /* Note that there is an assumption that all bodies of types that
1446 can be upgraded came from arenas. Only the more complex non-
1447 upgradable types are allowed to be directly malloc()ed. */
1448 assert(old_type_details->arena);
1449 del_body((void*)((char*)old_body + old_type_details->offset),
1450 &PL_body_roots[old_type]);
1456 =for apidoc sv_backoff
1458 Remove any string offset. You should normally use the C<SvOOK_off> macro
1465 Perl_sv_backoff(pTHX_ register SV *const sv)
1468 const char * const s = SvPVX_const(sv);
1470 PERL_ARGS_ASSERT_SV_BACKOFF;
1471 PERL_UNUSED_CONTEXT;
1474 assert(SvTYPE(sv) != SVt_PVHV);
1475 assert(SvTYPE(sv) != SVt_PVAV);
1477 SvOOK_offset(sv, delta);
1479 SvLEN_set(sv, SvLEN(sv) + delta);
1480 SvPV_set(sv, SvPVX(sv) - delta);
1481 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1482 SvFLAGS(sv) &= ~SVf_OOK;
1489 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1490 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1491 Use the C<SvGROW> wrapper instead.
1497 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1501 PERL_ARGS_ASSERT_SV_GROW;
1503 if (PL_madskills && newlen >= 0x100000) {
1504 PerlIO_printf(Perl_debug_log,
1505 "Allocation too large: %"UVxf"\n", (UV)newlen);
1507 #ifdef HAS_64K_LIMIT
1508 if (newlen >= 0x10000) {
1509 PerlIO_printf(Perl_debug_log,
1510 "Allocation too large: %"UVxf"\n", (UV)newlen);
1513 #endif /* HAS_64K_LIMIT */
1516 if (SvTYPE(sv) < SVt_PV) {
1517 sv_upgrade(sv, SVt_PV);
1518 s = SvPVX_mutable(sv);
1520 else if (SvOOK(sv)) { /* pv is offset? */
1522 s = SvPVX_mutable(sv);
1523 if (newlen > SvLEN(sv))
1524 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1525 #ifdef HAS_64K_LIMIT
1526 if (newlen >= 0x10000)
1531 s = SvPVX_mutable(sv);
1533 if (newlen > SvLEN(sv)) { /* need more room? */
1534 #ifndef Perl_safesysmalloc_size
1535 newlen = PERL_STRLEN_ROUNDUP(newlen);
1537 if (SvLEN(sv) && s) {
1538 s = (char*)saferealloc(s, newlen);
1541 s = (char*)safemalloc(newlen);
1542 if (SvPVX_const(sv) && SvCUR(sv)) {
1543 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1547 #ifdef Perl_safesysmalloc_size
1548 /* Do this here, do it once, do it right, and then we will never get
1549 called back into sv_grow() unless there really is some growing
1551 SvLEN_set(sv, Perl_safesysmalloc_size(s));
1553 SvLEN_set(sv, newlen);
1560 =for apidoc sv_setiv
1562 Copies an integer into the given SV, upgrading first if necessary.
1563 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1569 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1573 PERL_ARGS_ASSERT_SV_SETIV;
1575 SV_CHECK_THINKFIRST_COW_DROP(sv);
1576 switch (SvTYPE(sv)) {
1579 sv_upgrade(sv, SVt_IV);
1582 sv_upgrade(sv, SVt_PVIV);
1586 if (!isGV_with_GP(sv))
1593 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1597 (void)SvIOK_only(sv); /* validate number */
1603 =for apidoc sv_setiv_mg
1605 Like C<sv_setiv>, but also handles 'set' magic.
1611 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1613 PERL_ARGS_ASSERT_SV_SETIV_MG;
1620 =for apidoc sv_setuv
1622 Copies an unsigned integer into the given SV, upgrading first if necessary.
1623 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1629 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1631 PERL_ARGS_ASSERT_SV_SETUV;
1633 /* With these two if statements:
1634 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1637 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1639 If you wish to remove them, please benchmark to see what the effect is
1641 if (u <= (UV)IV_MAX) {
1642 sv_setiv(sv, (IV)u);
1651 =for apidoc sv_setuv_mg
1653 Like C<sv_setuv>, but also handles 'set' magic.
1659 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1661 PERL_ARGS_ASSERT_SV_SETUV_MG;
1668 =for apidoc sv_setnv
1670 Copies a double into the given SV, upgrading first if necessary.
1671 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1677 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1681 PERL_ARGS_ASSERT_SV_SETNV;
1683 SV_CHECK_THINKFIRST_COW_DROP(sv);
1684 switch (SvTYPE(sv)) {
1687 sv_upgrade(sv, SVt_NV);
1691 sv_upgrade(sv, SVt_PVNV);
1695 if (!isGV_with_GP(sv))
1702 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1707 (void)SvNOK_only(sv); /* validate number */
1712 =for apidoc sv_setnv_mg
1714 Like C<sv_setnv>, but also handles 'set' magic.
1720 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1722 PERL_ARGS_ASSERT_SV_SETNV_MG;
1728 /* Print an "isn't numeric" warning, using a cleaned-up,
1729 * printable version of the offending string
1733 S_not_a_number(pTHX_ SV *const sv)
1740 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1743 dsv = newSVpvs_flags("", SVs_TEMP);
1744 pv = sv_uni_display(dsv, sv, 10, 0);
1747 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1748 /* each *s can expand to 4 chars + "...\0",
1749 i.e. need room for 8 chars */
1751 const char *s = SvPVX_const(sv);
1752 const char * const end = s + SvCUR(sv);
1753 for ( ; s < end && d < limit; s++ ) {
1755 if (ch & 128 && !isPRINT_LC(ch)) {
1764 else if (ch == '\r') {
1768 else if (ch == '\f') {
1772 else if (ch == '\\') {
1776 else if (ch == '\0') {
1780 else if (isPRINT_LC(ch))
1797 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1798 "Argument \"%s\" isn't numeric in %s", pv,
1801 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1802 "Argument \"%s\" isn't numeric", pv);
1806 =for apidoc looks_like_number
1808 Test if the content of an SV looks like a number (or is a number).
1809 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1810 non-numeric warning), even if your atof() doesn't grok them.
1816 Perl_looks_like_number(pTHX_ SV *const sv)
1818 register const char *sbegin;
1821 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1824 sbegin = SvPVX_const(sv);
1827 else if (SvPOKp(sv))
1828 sbegin = SvPV_const(sv, len);
1830 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1831 return grok_number(sbegin, len, NULL);
1835 S_glob_2number(pTHX_ GV * const gv)
1837 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1838 SV *const buffer = sv_newmortal();
1840 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1842 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1845 gv_efullname3(buffer, gv, "*");
1846 SvFLAGS(gv) |= wasfake;
1848 /* We know that all GVs stringify to something that is not-a-number,
1849 so no need to test that. */
1850 if (ckWARN(WARN_NUMERIC))
1851 not_a_number(buffer);
1852 /* We just want something true to return, so that S_sv_2iuv_common
1853 can tail call us and return true. */
1857 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1858 until proven guilty, assume that things are not that bad... */
1863 As 64 bit platforms often have an NV that doesn't preserve all bits of
1864 an IV (an assumption perl has been based on to date) it becomes necessary
1865 to remove the assumption that the NV always carries enough precision to
1866 recreate the IV whenever needed, and that the NV is the canonical form.
1867 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1868 precision as a side effect of conversion (which would lead to insanity
1869 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1870 1) to distinguish between IV/UV/NV slots that have cached a valid
1871 conversion where precision was lost and IV/UV/NV slots that have a
1872 valid conversion which has lost no precision
1873 2) to ensure that if a numeric conversion to one form is requested that
1874 would lose precision, the precise conversion (or differently
1875 imprecise conversion) is also performed and cached, to prevent
1876 requests for different numeric formats on the same SV causing
1877 lossy conversion chains. (lossless conversion chains are perfectly
1882 SvIOKp is true if the IV slot contains a valid value
1883 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1884 SvNOKp is true if the NV slot contains a valid value
1885 SvNOK is true only if the NV value is accurate
1888 while converting from PV to NV, check to see if converting that NV to an
1889 IV(or UV) would lose accuracy over a direct conversion from PV to
1890 IV(or UV). If it would, cache both conversions, return NV, but mark
1891 SV as IOK NOKp (ie not NOK).
1893 While converting from PV to IV, check to see if converting that IV to an
1894 NV would lose accuracy over a direct conversion from PV to NV. If it
1895 would, cache both conversions, flag similarly.
1897 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1898 correctly because if IV & NV were set NV *always* overruled.
1899 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1900 changes - now IV and NV together means that the two are interchangeable:
1901 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1903 The benefit of this is that operations such as pp_add know that if
1904 SvIOK is true for both left and right operands, then integer addition
1905 can be used instead of floating point (for cases where the result won't
1906 overflow). Before, floating point was always used, which could lead to
1907 loss of precision compared with integer addition.
1909 * making IV and NV equal status should make maths accurate on 64 bit
1911 * may speed up maths somewhat if pp_add and friends start to use
1912 integers when possible instead of fp. (Hopefully the overhead in
1913 looking for SvIOK and checking for overflow will not outweigh the
1914 fp to integer speedup)
1915 * will slow down integer operations (callers of SvIV) on "inaccurate"
1916 values, as the change from SvIOK to SvIOKp will cause a call into
1917 sv_2iv each time rather than a macro access direct to the IV slot
1918 * should speed up number->string conversion on integers as IV is
1919 favoured when IV and NV are equally accurate
1921 ####################################################################
1922 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1923 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1924 On the other hand, SvUOK is true iff UV.
1925 ####################################################################
1927 Your mileage will vary depending your CPU's relative fp to integer
1931 #ifndef NV_PRESERVES_UV
1932 # define IS_NUMBER_UNDERFLOW_IV 1
1933 # define IS_NUMBER_UNDERFLOW_UV 2
1934 # define IS_NUMBER_IV_AND_UV 2
1935 # define IS_NUMBER_OVERFLOW_IV 4
1936 # define IS_NUMBER_OVERFLOW_UV 5
1938 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1940 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1942 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1950 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1952 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));
1953 if (SvNVX(sv) < (NV)IV_MIN) {
1954 (void)SvIOKp_on(sv);
1956 SvIV_set(sv, IV_MIN);
1957 return IS_NUMBER_UNDERFLOW_IV;
1959 if (SvNVX(sv) > (NV)UV_MAX) {
1960 (void)SvIOKp_on(sv);
1963 SvUV_set(sv, UV_MAX);
1964 return IS_NUMBER_OVERFLOW_UV;
1966 (void)SvIOKp_on(sv);
1968 /* Can't use strtol etc to convert this string. (See truth table in
1970 if (SvNVX(sv) <= (UV)IV_MAX) {
1971 SvIV_set(sv, I_V(SvNVX(sv)));
1972 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1973 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1975 /* Integer is imprecise. NOK, IOKp */
1977 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1980 SvUV_set(sv, U_V(SvNVX(sv)));
1981 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1982 if (SvUVX(sv) == UV_MAX) {
1983 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1984 possibly be preserved by NV. Hence, it must be overflow.
1986 return IS_NUMBER_OVERFLOW_UV;
1988 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1990 /* Integer is imprecise. NOK, IOKp */
1992 return IS_NUMBER_OVERFLOW_IV;
1994 #endif /* !NV_PRESERVES_UV*/
1997 S_sv_2iuv_common(pTHX_ SV *const sv)
2001 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2004 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2005 * without also getting a cached IV/UV from it at the same time
2006 * (ie PV->NV conversion should detect loss of accuracy and cache
2007 * IV or UV at same time to avoid this. */
2008 /* IV-over-UV optimisation - choose to cache IV if possible */
2010 if (SvTYPE(sv) == SVt_NV)
2011 sv_upgrade(sv, SVt_PVNV);
2013 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2014 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2015 certainly cast into the IV range at IV_MAX, whereas the correct
2016 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2018 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2019 if (Perl_isnan(SvNVX(sv))) {
2025 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2026 SvIV_set(sv, I_V(SvNVX(sv)));
2027 if (SvNVX(sv) == (NV) SvIVX(sv)
2028 #ifndef NV_PRESERVES_UV
2029 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2030 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2031 /* Don't flag it as "accurately an integer" if the number
2032 came from a (by definition imprecise) NV operation, and
2033 we're outside the range of NV integer precision */
2037 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2039 /* scalar has trailing garbage, eg "42a" */
2041 DEBUG_c(PerlIO_printf(Perl_debug_log,
2042 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2048 /* IV not precise. No need to convert from PV, as NV
2049 conversion would already have cached IV if it detected
2050 that PV->IV would be better than PV->NV->IV
2051 flags already correct - don't set public IOK. */
2052 DEBUG_c(PerlIO_printf(Perl_debug_log,
2053 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2058 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2059 but the cast (NV)IV_MIN rounds to a the value less (more
2060 negative) than IV_MIN which happens to be equal to SvNVX ??
2061 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2062 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2063 (NV)UVX == NVX are both true, but the values differ. :-(
2064 Hopefully for 2s complement IV_MIN is something like
2065 0x8000000000000000 which will be exact. NWC */
2068 SvUV_set(sv, U_V(SvNVX(sv)));
2070 (SvNVX(sv) == (NV) SvUVX(sv))
2071 #ifndef NV_PRESERVES_UV
2072 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2073 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2074 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2075 /* Don't flag it as "accurately an integer" if the number
2076 came from a (by definition imprecise) NV operation, and
2077 we're outside the range of NV integer precision */
2083 DEBUG_c(PerlIO_printf(Perl_debug_log,
2084 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2090 else if (SvPOKp(sv) && SvLEN(sv)) {
2092 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2093 /* We want to avoid a possible problem when we cache an IV/ a UV which
2094 may be later translated to an NV, and the resulting NV is not
2095 the same as the direct translation of the initial string
2096 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2097 be careful to ensure that the value with the .456 is around if the
2098 NV value is requested in the future).
2100 This means that if we cache such an IV/a UV, we need to cache the
2101 NV as well. Moreover, we trade speed for space, and do not
2102 cache the NV if we are sure it's not needed.
2105 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2106 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2107 == IS_NUMBER_IN_UV) {
2108 /* It's definitely an integer, only upgrade to PVIV */
2109 if (SvTYPE(sv) < SVt_PVIV)
2110 sv_upgrade(sv, SVt_PVIV);
2112 } else if (SvTYPE(sv) < SVt_PVNV)
2113 sv_upgrade(sv, SVt_PVNV);
2115 /* If NVs preserve UVs then we only use the UV value if we know that
2116 we aren't going to call atof() below. If NVs don't preserve UVs
2117 then the value returned may have more precision than atof() will
2118 return, even though value isn't perfectly accurate. */
2119 if ((numtype & (IS_NUMBER_IN_UV
2120 #ifdef NV_PRESERVES_UV
2123 )) == IS_NUMBER_IN_UV) {
2124 /* This won't turn off the public IOK flag if it was set above */
2125 (void)SvIOKp_on(sv);
2127 if (!(numtype & IS_NUMBER_NEG)) {
2129 if (value <= (UV)IV_MAX) {
2130 SvIV_set(sv, (IV)value);
2132 /* it didn't overflow, and it was positive. */
2133 SvUV_set(sv, value);
2137 /* 2s complement assumption */
2138 if (value <= (UV)IV_MIN) {
2139 SvIV_set(sv, -(IV)value);
2141 /* Too negative for an IV. This is a double upgrade, but
2142 I'm assuming it will be rare. */
2143 if (SvTYPE(sv) < SVt_PVNV)
2144 sv_upgrade(sv, SVt_PVNV);
2148 SvNV_set(sv, -(NV)value);
2149 SvIV_set(sv, IV_MIN);
2153 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2154 will be in the previous block to set the IV slot, and the next
2155 block to set the NV slot. So no else here. */
2157 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2158 != IS_NUMBER_IN_UV) {
2159 /* It wasn't an (integer that doesn't overflow the UV). */
2160 SvNV_set(sv, Atof(SvPVX_const(sv)));
2162 if (! numtype && ckWARN(WARN_NUMERIC))
2165 #if defined(USE_LONG_DOUBLE)
2166 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2167 PTR2UV(sv), SvNVX(sv)));
2169 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2170 PTR2UV(sv), SvNVX(sv)));
2173 #ifdef NV_PRESERVES_UV
2174 (void)SvIOKp_on(sv);
2176 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2177 SvIV_set(sv, I_V(SvNVX(sv)));
2178 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2181 NOOP; /* Integer is imprecise. NOK, IOKp */
2183 /* UV will not work better than IV */
2185 if (SvNVX(sv) > (NV)UV_MAX) {
2187 /* Integer is inaccurate. NOK, IOKp, is UV */
2188 SvUV_set(sv, UV_MAX);
2190 SvUV_set(sv, U_V(SvNVX(sv)));
2191 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2192 NV preservse UV so can do correct comparison. */
2193 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2196 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
2201 #else /* NV_PRESERVES_UV */
2202 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2203 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2204 /* The IV/UV slot will have been set from value returned by
2205 grok_number above. The NV slot has just been set using
2208 assert (SvIOKp(sv));
2210 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2211 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2212 /* Small enough to preserve all bits. */
2213 (void)SvIOKp_on(sv);
2215 SvIV_set(sv, I_V(SvNVX(sv)));
2216 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2218 /* Assumption: first non-preserved integer is < IV_MAX,
2219 this NV is in the preserved range, therefore: */
2220 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2222 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);
2226 0 0 already failed to read UV.
2227 0 1 already failed to read UV.
2228 1 0 you won't get here in this case. IV/UV
2229 slot set, public IOK, Atof() unneeded.
2230 1 1 already read UV.
2231 so there's no point in sv_2iuv_non_preserve() attempting
2232 to use atol, strtol, strtoul etc. */
2234 sv_2iuv_non_preserve (sv, numtype);
2236 sv_2iuv_non_preserve (sv);
2240 #endif /* NV_PRESERVES_UV */
2241 /* It might be more code efficient to go through the entire logic above
2242 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2243 gets complex and potentially buggy, so more programmer efficient
2244 to do it this way, by turning off the public flags: */
2246 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2250 if (isGV_with_GP(sv))
2251 return glob_2number(MUTABLE_GV(sv));
2253 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2254 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2257 if (SvTYPE(sv) < SVt_IV)
2258 /* Typically the caller expects that sv_any is not NULL now. */
2259 sv_upgrade(sv, SVt_IV);
2260 /* Return 0 from the caller. */
2267 =for apidoc sv_2iv_flags
2269 Return the integer value of an SV, doing any necessary string
2270 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2271 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2277 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2282 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2283 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2284 cache IVs just in case. In practice it seems that they never
2285 actually anywhere accessible by user Perl code, let alone get used
2286 in anything other than a string context. */
2287 if (flags & SV_GMAGIC)
2292 return I_V(SvNVX(sv));
2294 if (SvPOKp(sv) && SvLEN(sv)) {
2297 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2299 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2300 == IS_NUMBER_IN_UV) {
2301 /* It's definitely an integer */
2302 if (numtype & IS_NUMBER_NEG) {
2303 if (value < (UV)IV_MIN)
2306 if (value < (UV)IV_MAX)
2311 if (ckWARN(WARN_NUMERIC))
2314 return I_V(Atof(SvPVX_const(sv)));
2319 assert(SvTYPE(sv) >= SVt_PVMG);
2320 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2321 } else if (SvTHINKFIRST(sv)) {
2325 SV * const tmpstr=AMG_CALLun(sv,numer);
2326 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2327 return SvIV(tmpstr);
2330 return PTR2IV(SvRV(sv));
2333 sv_force_normal_flags(sv, 0);
2335 if (SvREADONLY(sv) && !SvOK(sv)) {
2336 if (ckWARN(WARN_UNINITIALIZED))
2342 if (S_sv_2iuv_common(aTHX_ sv))
2345 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2346 PTR2UV(sv),SvIVX(sv)));
2347 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2351 =for apidoc sv_2uv_flags
2353 Return the unsigned integer value of an SV, doing any necessary string
2354 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2355 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2361 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2366 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2367 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2368 cache IVs just in case. */
2369 if (flags & SV_GMAGIC)
2374 return U_V(SvNVX(sv));
2375 if (SvPOKp(sv) && SvLEN(sv)) {
2378 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2380 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2381 == IS_NUMBER_IN_UV) {
2382 /* It's definitely an integer */
2383 if (!(numtype & IS_NUMBER_NEG))
2387 if (ckWARN(WARN_NUMERIC))
2390 return U_V(Atof(SvPVX_const(sv)));
2395 assert(SvTYPE(sv) >= SVt_PVMG);
2396 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2397 } else if (SvTHINKFIRST(sv)) {
2401 SV *const tmpstr = AMG_CALLun(sv,numer);
2402 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2403 return SvUV(tmpstr);
2406 return PTR2UV(SvRV(sv));
2409 sv_force_normal_flags(sv, 0);
2411 if (SvREADONLY(sv) && !SvOK(sv)) {
2412 if (ckWARN(WARN_UNINITIALIZED))
2418 if (S_sv_2iuv_common(aTHX_ sv))
2422 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2423 PTR2UV(sv),SvUVX(sv)));
2424 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2430 Return the num value of an SV, doing any necessary string or integer
2431 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2432 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2438 Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
2443 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2444 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2445 cache IVs just in case. */
2446 if (flags & SV_GMAGIC)
2450 if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2451 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2452 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2454 return Atof(SvPVX_const(sv));
2458 return (NV)SvUVX(sv);
2460 return (NV)SvIVX(sv);
2465 assert(SvTYPE(sv) >= SVt_PVMG);
2466 /* This falls through to the report_uninit near the end of the
2468 } else if (SvTHINKFIRST(sv)) {
2472 SV *const tmpstr = AMG_CALLun(sv,numer);
2473 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2474 return SvNV(tmpstr);
2477 return PTR2NV(SvRV(sv));
2480 sv_force_normal_flags(sv, 0);
2482 if (SvREADONLY(sv) && !SvOK(sv)) {
2483 if (ckWARN(WARN_UNINITIALIZED))
2488 if (SvTYPE(sv) < SVt_NV) {
2489 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2490 sv_upgrade(sv, SVt_NV);
2491 #ifdef USE_LONG_DOUBLE
2493 STORE_NUMERIC_LOCAL_SET_STANDARD();
2494 PerlIO_printf(Perl_debug_log,
2495 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2496 PTR2UV(sv), SvNVX(sv));
2497 RESTORE_NUMERIC_LOCAL();
2501 STORE_NUMERIC_LOCAL_SET_STANDARD();
2502 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2503 PTR2UV(sv), SvNVX(sv));
2504 RESTORE_NUMERIC_LOCAL();
2508 else if (SvTYPE(sv) < SVt_PVNV)
2509 sv_upgrade(sv, SVt_PVNV);
2514 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2515 #ifdef NV_PRESERVES_UV
2521 /* Only set the public NV OK flag if this NV preserves the IV */
2522 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2524 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2525 : (SvIVX(sv) == I_V(SvNVX(sv))))
2531 else if (SvPOKp(sv) && SvLEN(sv)) {
2533 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2534 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2536 #ifdef NV_PRESERVES_UV
2537 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2538 == IS_NUMBER_IN_UV) {
2539 /* It's definitely an integer */
2540 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2542 SvNV_set(sv, Atof(SvPVX_const(sv)));
2548 SvNV_set(sv, Atof(SvPVX_const(sv)));
2549 /* Only set the public NV OK flag if this NV preserves the value in
2550 the PV at least as well as an IV/UV would.
2551 Not sure how to do this 100% reliably. */
2552 /* if that shift count is out of range then Configure's test is
2553 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2555 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2556 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2557 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2558 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2559 /* Can't use strtol etc to convert this string, so don't try.
2560 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2563 /* value has been set. It may not be precise. */
2564 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2565 /* 2s complement assumption for (UV)IV_MIN */
2566 SvNOK_on(sv); /* Integer is too negative. */
2571 if (numtype & IS_NUMBER_NEG) {
2572 SvIV_set(sv, -(IV)value);
2573 } else if (value <= (UV)IV_MAX) {
2574 SvIV_set(sv, (IV)value);
2576 SvUV_set(sv, value);
2580 if (numtype & IS_NUMBER_NOT_INT) {
2581 /* I believe that even if the original PV had decimals,
2582 they are lost beyond the limit of the FP precision.
2583 However, neither is canonical, so both only get p
2584 flags. NWC, 2000/11/25 */
2585 /* Both already have p flags, so do nothing */
2587 const NV nv = SvNVX(sv);
2588 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2589 if (SvIVX(sv) == I_V(nv)) {
2592 /* It had no "." so it must be integer. */
2596 /* between IV_MAX and NV(UV_MAX).
2597 Could be slightly > UV_MAX */
2599 if (numtype & IS_NUMBER_NOT_INT) {
2600 /* UV and NV both imprecise. */
2602 const UV nv_as_uv = U_V(nv);
2604 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2613 /* It might be more code efficient to go through the entire logic above
2614 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2615 gets complex and potentially buggy, so more programmer efficient
2616 to do it this way, by turning off the public flags: */
2618 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2619 #endif /* NV_PRESERVES_UV */
2622 if (isGV_with_GP(sv)) {
2623 glob_2number(MUTABLE_GV(sv));
2627 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2629 assert (SvTYPE(sv) >= SVt_NV);
2630 /* Typically the caller expects that sv_any is not NULL now. */
2631 /* XXX Ilya implies that this is a bug in callers that assume this
2632 and ideally should be fixed. */
2635 #if defined(USE_LONG_DOUBLE)
2637 STORE_NUMERIC_LOCAL_SET_STANDARD();
2638 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2639 PTR2UV(sv), SvNVX(sv));
2640 RESTORE_NUMERIC_LOCAL();
2644 STORE_NUMERIC_LOCAL_SET_STANDARD();
2645 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2646 PTR2UV(sv), SvNVX(sv));
2647 RESTORE_NUMERIC_LOCAL();
2656 Return an SV with the numeric value of the source SV, doing any necessary
2657 reference or overload conversion. You must use the C<SvNUM(sv)> macro to
2658 access this function.
2664 Perl_sv_2num(pTHX_ register SV *const sv)
2666 PERL_ARGS_ASSERT_SV_2NUM;
2671 SV * const tmpsv = AMG_CALLun(sv,numer);
2672 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2673 return sv_2num(tmpsv);
2675 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2678 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2679 * UV as a string towards the end of buf, and return pointers to start and
2682 * We assume that buf is at least TYPE_CHARS(UV) long.
2686 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2688 char *ptr = buf + TYPE_CHARS(UV);
2689 char * const ebuf = ptr;
2692 PERL_ARGS_ASSERT_UIV_2BUF;
2704 *--ptr = '0' + (char)(uv % 10);
2713 =for apidoc sv_2pv_flags
2715 Returns a pointer to the string value of an SV, and sets *lp to its length.
2716 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2718 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2719 usually end up here too.
2725 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2735 if (SvGMAGICAL(sv)) {
2736 if (flags & SV_GMAGIC)
2741 if (flags & SV_MUTABLE_RETURN)
2742 return SvPVX_mutable(sv);
2743 if (flags & SV_CONST_RETURN)
2744 return (char *)SvPVX_const(sv);
2747 if (SvIOKp(sv) || SvNOKp(sv)) {
2748 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2753 ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2754 : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2756 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2763 #ifdef FIXNEGATIVEZERO
2764 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2770 SvUPGRADE(sv, SVt_PV);
2773 s = SvGROW_mutable(sv, len + 1);
2776 return (char*)memcpy(s, tbuf, len + 1);
2782 assert(SvTYPE(sv) >= SVt_PVMG);
2783 /* This falls through to the report_uninit near the end of the
2785 } else if (SvTHINKFIRST(sv)) {
2789 SV *const tmpstr = AMG_CALLun(sv,string);
2790 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2792 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2796 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2797 if (flags & SV_CONST_RETURN) {
2798 pv = (char *) SvPVX_const(tmpstr);
2800 pv = (flags & SV_MUTABLE_RETURN)
2801 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2804 *lp = SvCUR(tmpstr);
2806 pv = sv_2pv_flags(tmpstr, lp, flags);
2819 SV *const referent = SvRV(sv);
2823 retval = buffer = savepvn("NULLREF", len);
2824 } else if (SvTYPE(referent) == SVt_REGEXP) {
2825 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2830 /* If the regex is UTF-8 we want the containing scalar to
2831 have an UTF-8 flag too */
2837 if ((seen_evals = RX_SEEN_EVALS(re)))
2838 PL_reginterp_cnt += seen_evals;
2841 *lp = RX_WRAPLEN(re);
2843 return RX_WRAPPED(re);
2845 const char *const typestr = sv_reftype(referent, 0);
2846 const STRLEN typelen = strlen(typestr);
2847 UV addr = PTR2UV(referent);
2848 const char *stashname = NULL;
2849 STRLEN stashnamelen = 0; /* hush, gcc */
2850 const char *buffer_end;
2852 if (SvOBJECT(referent)) {
2853 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2856 stashname = HEK_KEY(name);
2857 stashnamelen = HEK_LEN(name);
2859 if (HEK_UTF8(name)) {
2865 stashname = "__ANON__";
2868 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2869 + 2 * sizeof(UV) + 2 /* )\0 */;
2871 len = typelen + 3 /* (0x */
2872 + 2 * sizeof(UV) + 2 /* )\0 */;
2875 Newx(buffer, len, char);
2876 buffer_end = retval = buffer + len;
2878 /* Working backwards */
2882 *--retval = PL_hexdigit[addr & 15];
2883 } while (addr >>= 4);
2889 memcpy(retval, typestr, typelen);
2893 retval -= stashnamelen;
2894 memcpy(retval, stashname, stashnamelen);
2896 /* retval may not neccesarily have reached the start of the
2898 assert (retval >= buffer);
2900 len = buffer_end - retval - 1; /* -1 for that \0 */
2908 if (SvREADONLY(sv) && !SvOK(sv)) {
2911 if (flags & SV_UNDEF_RETURNS_NULL)
2913 if (ckWARN(WARN_UNINITIALIZED))
2918 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2919 /* I'm assuming that if both IV and NV are equally valid then
2920 converting the IV is going to be more efficient */
2921 const U32 isUIOK = SvIsUV(sv);
2922 char buf[TYPE_CHARS(UV)];
2926 if (SvTYPE(sv) < SVt_PVIV)
2927 sv_upgrade(sv, SVt_PVIV);
2928 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2930 /* inlined from sv_setpvn */
2931 s = SvGROW_mutable(sv, len + 1);
2932 Move(ptr, s, len, char);
2936 else if (SvNOKp(sv)) {
2938 if (SvTYPE(sv) < SVt_PVNV)
2939 sv_upgrade(sv, SVt_PVNV);
2940 /* The +20 is pure guesswork. Configure test needed. --jhi */
2941 s = SvGROW_mutable(sv, NV_DIG + 20);
2942 /* some Xenix systems wipe out errno here */
2944 if (SvNVX(sv) == 0.0)
2945 my_strlcpy(s, "0", SvLEN(sv));
2949 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2952 #ifdef FIXNEGATIVEZERO
2953 if (*s == '-' && s[1] == '0' && !s[2]) {
2965 if (isGV_with_GP(sv)) {
2966 GV *const gv = MUTABLE_GV(sv);
2967 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
2968 SV *const buffer = sv_newmortal();
2970 /* FAKE globs can get coerced, so need to turn this off temporarily
2973 gv_efullname3(buffer, gv, "*");
2974 SvFLAGS(gv) |= wasfake;
2976 if (SvPOK(buffer)) {
2978 *lp = SvCUR(buffer);
2980 return SvPVX(buffer);
2991 if (flags & SV_UNDEF_RETURNS_NULL)
2993 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2995 if (SvTYPE(sv) < SVt_PV)
2996 /* Typically the caller expects that sv_any is not NULL now. */
2997 sv_upgrade(sv, SVt_PV);
3001 const STRLEN len = s - SvPVX_const(sv);
3007 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3008 PTR2UV(sv),SvPVX_const(sv)));
3009 if (flags & SV_CONST_RETURN)
3010 return (char *)SvPVX_const(sv);
3011 if (flags & SV_MUTABLE_RETURN)
3012 return SvPVX_mutable(sv);
3017 =for apidoc sv_copypv
3019 Copies a stringified representation of the source SV into the
3020 destination SV. Automatically performs any necessary mg_get and
3021 coercion of numeric values into strings. Guaranteed to preserve
3022 UTF8 flag even from overloaded objects. Similar in nature to
3023 sv_2pv[_flags] but operates directly on an SV instead of just the
3024 string. Mostly uses sv_2pv_flags to do its work, except when that
3025 would lose the UTF-8'ness of the PV.
3031 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3034 const char * const s = SvPV_const(ssv,len);
3036 PERL_ARGS_ASSERT_SV_COPYPV;
3038 sv_setpvn(dsv,s,len);
3046 =for apidoc sv_2pvbyte
3048 Return a pointer to the byte-encoded representation of the SV, and set *lp
3049 to its length. May cause the SV to be downgraded from UTF-8 as a
3052 Usually accessed via the C<SvPVbyte> macro.
3058 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3060 PERL_ARGS_ASSERT_SV_2PVBYTE;
3062 sv_utf8_downgrade(sv,0);
3063 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3067 =for apidoc sv_2pvutf8
3069 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3070 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3072 Usually accessed via the C<SvPVutf8> macro.
3078 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3080 PERL_ARGS_ASSERT_SV_2PVUTF8;
3082 sv_utf8_upgrade(sv);
3083 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3088 =for apidoc sv_2bool
3090 This function is only called on magical items, and is only used by
3091 sv_true() or its macro equivalent.
3097 Perl_sv_2bool(pTHX_ register SV *const sv)
3101 PERL_ARGS_ASSERT_SV_2BOOL;
3109 SV * const tmpsv = AMG_CALLun(sv,bool_);
3110 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3111 return cBOOL(SvTRUE(tmpsv));
3113 return SvRV(sv) != 0;
3116 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3118 (*sv->sv_u.svu_pv > '0' ||
3119 Xpvtmp->xpv_cur > 1 ||
3120 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3127 return SvIVX(sv) != 0;
3130 return SvNVX(sv) != 0.0;
3132 if (isGV_with_GP(sv))
3142 =for apidoc sv_utf8_upgrade
3144 Converts the PV of an SV to its UTF-8-encoded form.
3145 Forces the SV to string form if it is not already.
3146 Will C<mg_get> on C<sv> if appropriate.
3147 Always sets the SvUTF8 flag to avoid future validity checks even
3148 if the whole string is the same in UTF-8 as not.
3149 Returns the number of bytes in the converted string
3151 This is not as a general purpose byte encoding to Unicode interface:
3152 use the Encode extension for that.
3154 =for apidoc sv_utf8_upgrade_nomg
3156 Like sv_utf8_upgrade, but doesn't do magic on C<sv>
3158 =for apidoc sv_utf8_upgrade_flags
3160 Converts the PV of an SV to its UTF-8-encoded form.
3161 Forces the SV to string form if it is not already.
3162 Always sets the SvUTF8 flag to avoid future validity checks even
3163 if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
3164 will C<mg_get> on C<sv> if appropriate, else not.
3165 Returns the number of bytes in the converted string
3166 C<sv_utf8_upgrade> and
3167 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3169 This is not as a general purpose byte encoding to Unicode interface:
3170 use the Encode extension for that.
3174 The grow version is currently not externally documented. It adds a parameter,
3175 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3176 have free after it upon return. This allows the caller to reserve extra space
3177 that it intends to fill, to avoid extra grows.
3179 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3180 which can be used to tell this function to not first check to see if there are
3181 any characters that are different in UTF-8 (variant characters) which would
3182 force it to allocate a new string to sv, but to assume there are. Typically
3183 this flag is used by a routine that has already parsed the string to find that
3184 there are such characters, and passes this information on so that the work
3185 doesn't have to be repeated.
3187 (One might think that the calling routine could pass in the position of the
3188 first such variant, so it wouldn't have to be found again. But that is not the
3189 case, because typically when the caller is likely to use this flag, it won't be
3190 calling this routine unless it finds something that won't fit into a byte.
3191 Otherwise it tries to not upgrade and just use bytes. But some things that
3192 do fit into a byte are variants in utf8, and the caller may not have been
3193 keeping track of these.)
3195 If the routine itself changes the string, it adds a trailing NUL. Such a NUL
3196 isn't guaranteed due to having other routines do the work in some input cases,
3197 or if the input is already flagged as being in utf8.
3199 The speed of this could perhaps be improved for many cases if someone wanted to
3200 write a fast function that counts the number of variant characters in a string,
3201 especially if it could return the position of the first one.
3206 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
3210 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3212 if (sv == &PL_sv_undef)
3216 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3217 (void) sv_2pv_flags(sv,&len, flags);
3219 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3223 (void) SvPV_force(sv,len);
3228 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3233 sv_force_normal_flags(sv, 0);
3236 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3237 sv_recode_to_utf8(sv, PL_encoding);
3238 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3242 if (SvCUR(sv) == 0) {
3243 if (extra) SvGROW(sv, extra);
3244 } else { /* Assume Latin-1/EBCDIC */
3245 /* This function could be much more efficient if we
3246 * had a FLAG in SVs to signal if there are any variant
3247 * chars in the PV. Given that there isn't such a flag
3248 * make the loop as fast as possible (although there are certainly ways
3249 * to speed this up, eg. through vectorization) */
3250 U8 * s = (U8 *) SvPVX_const(sv);
3251 U8 * e = (U8 *) SvEND(sv);
3253 STRLEN two_byte_count = 0;
3255 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3257 /* See if really will need to convert to utf8. We mustn't rely on our
3258 * incoming SV being well formed and having a trailing '\0', as certain
3259 * code in pp_formline can send us partially built SVs. */
3263 if (NATIVE_IS_INVARIANT(ch)) continue;
3265 t--; /* t already incremented; re-point to first variant */
3270 /* utf8 conversion not needed because all are invariants. Mark as
3271 * UTF-8 even if no variant - saves scanning loop */
3277 /* Here, the string should be converted to utf8, either because of an
3278 * input flag (two_byte_count = 0), or because a character that
3279 * requires 2 bytes was found (two_byte_count = 1). t points either to
3280 * the beginning of the string (if we didn't examine anything), or to
3281 * the first variant. In either case, everything from s to t - 1 will
3282 * occupy only 1 byte each on output.
3284 * There are two main ways to convert. One is to create a new string
3285 * and go through the input starting from the beginning, appending each
3286 * converted value onto the new string as we go along. It's probably
3287 * best to allocate enough space in the string for the worst possible
3288 * case rather than possibly running out of space and having to
3289 * reallocate and then copy what we've done so far. Since everything
3290 * from s to t - 1 is invariant, the destination can be initialized
3291 * with these using a fast memory copy
3293 * The other way is to figure out exactly how big the string should be
3294 * by parsing the entire input. Then you don't have to make it big
3295 * enough to handle the worst possible case, and more importantly, if
3296 * the string you already have is large enough, you don't have to
3297 * allocate a new string, you can copy the last character in the input
3298 * string to the final position(s) that will be occupied by the
3299 * converted string and go backwards, stopping at t, since everything
3300 * before that is invariant.
3302 * There are advantages and disadvantages to each method.
3304 * In the first method, we can allocate a new string, do the memory
3305 * copy from the s to t - 1, and then proceed through the rest of the
3306 * string byte-by-byte.
3308 * In the second method, we proceed through the rest of the input
3309 * string just calculating how big the converted string will be. Then
3310 * there are two cases:
3311 * 1) if the string has enough extra space to handle the converted
3312 * value. We go backwards through the string, converting until we
3313 * get to the position we are at now, and then stop. If this
3314 * position is far enough along in the string, this method is
3315 * faster than the other method. If the memory copy were the same
3316 * speed as the byte-by-byte loop, that position would be about
3317 * half-way, as at the half-way mark, parsing to the end and back
3318 * is one complete string's parse, the same amount as starting
3319 * over and going all the way through. Actually, it would be
3320 * somewhat less than half-way, as it's faster to just count bytes
3321 * than to also copy, and we don't have the overhead of allocating
3322 * a new string, changing the scalar to use it, and freeing the
3323 * existing one. But if the memory copy is fast, the break-even
3324 * point is somewhere after half way. The counting loop could be
3325 * sped up by vectorization, etc, to move the break-even point
3326 * further towards the beginning.
3327 * 2) if the string doesn't have enough space to handle the converted
3328 * value. A new string will have to be allocated, and one might
3329 * as well, given that, start from the beginning doing the first
3330 * method. We've spent extra time parsing the string and in
3331 * exchange all we've gotten is that we know precisely how big to
3332 * make the new one. Perl is more optimized for time than space,
3333 * so this case is a loser.
3334 * So what I've decided to do is not use the 2nd method unless it is
3335 * guaranteed that a new string won't have to be allocated, assuming
3336 * the worst case. I also decided not to put any more conditions on it
3337 * than this, for now. It seems likely that, since the worst case is
3338 * twice as big as the unknown portion of the string (plus 1), we won't
3339 * be guaranteed enough space, causing us to go to the first method,
3340 * unless the string is short, or the first variant character is near
3341 * the end of it. In either of these cases, it seems best to use the
3342 * 2nd method. The only circumstance I can think of where this would
3343 * be really slower is if the string had once had much more data in it
3344 * than it does now, but there is still a substantial amount in it */
3347 STRLEN invariant_head = t - s;
3348 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3349 if (SvLEN(sv) < size) {
3351 /* Here, have decided to allocate a new string */
3356 Newx(dst, size, U8);
3358 /* If no known invariants at the beginning of the input string,
3359 * set so starts from there. Otherwise, can use memory copy to
3360 * get up to where we are now, and then start from here */
3362 if (invariant_head <= 0) {
3365 Copy(s, dst, invariant_head, char);
3366 d = dst + invariant_head;
3370 const UV uv = NATIVE8_TO_UNI(*t++);
3371 if (UNI_IS_INVARIANT(uv))
3372 *d++ = (U8)UNI_TO_NATIVE(uv);
3374 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3375 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3379 SvPV_free(sv); /* No longer using pre-existing string */
3380 SvPV_set(sv, (char*)dst);
3381 SvCUR_set(sv, d - dst);
3382 SvLEN_set(sv, size);
3385 /* Here, have decided to get the exact size of the string.
3386 * Currently this happens only when we know that there is
3387 * guaranteed enough space to fit the converted string, so
3388 * don't have to worry about growing. If two_byte_count is 0,
3389 * then t points to the first byte of the string which hasn't
3390 * been examined yet. Otherwise two_byte_count is 1, and t
3391 * points to the first byte in the string that will expand to
3392 * two. Depending on this, start examining at t or 1 after t.
3395 U8 *d = t + two_byte_count;
3398 /* Count up the remaining bytes that expand to two */
3401 const U8 chr = *d++;
3402 if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3405 /* The string will expand by just the number of bytes that
3406 * occupy two positions. But we are one afterwards because of
3407 * the increment just above. This is the place to put the
3408 * trailing NUL, and to set the length before we decrement */
3410 d += two_byte_count;
3411 SvCUR_set(sv, d - s);
3415 /* Having decremented d, it points to the position to put the
3416 * very last byte of the expanded string. Go backwards through
3417 * the string, copying and expanding as we go, stopping when we
3418 * get to the part that is invariant the rest of the way down */
3422 const U8 ch = NATIVE8_TO_UNI(*e--);
3423 if (UNI_IS_INVARIANT(ch)) {
3424 *d-- = UNI_TO_NATIVE(ch);
3426 *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3427 *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3434 /* Mark as UTF-8 even if no variant - saves scanning loop */
3440 =for apidoc sv_utf8_downgrade
3442 Attempts to convert the PV of an SV from characters to bytes.
3443 If the PV contains a character that cannot fit
3444 in a byte, this conversion will fail;
3445 in this case, either returns false or, if C<fail_ok> is not
3448 This is not as a general purpose Unicode to byte encoding interface:
3449 use the Encode extension for that.
3455 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3459 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3461 if (SvPOKp(sv) && SvUTF8(sv)) {
3467 sv_force_normal_flags(sv, 0);
3469 s = (U8 *) SvPV(sv, len);
3470 if (!utf8_to_bytes(s, &len)) {
3475 Perl_croak(aTHX_ "Wide character in %s",
3478 Perl_croak(aTHX_ "Wide character");
3489 =for apidoc sv_utf8_encode
3491 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3492 flag off so that it looks like octets again.
3498 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3500 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3503 sv_force_normal_flags(sv, 0);
3505 if (SvREADONLY(sv)) {
3506 Perl_croak(aTHX_ "%s", PL_no_modify);
3508 (void) sv_utf8_upgrade(sv);
3513 =for apidoc sv_utf8_decode
3515 If the PV of the SV is an octet sequence in UTF-8
3516 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3517 so that it looks like a character. If the PV contains only single-byte
3518 characters, the C<SvUTF8> flag stays being off.
3519 Scans PV for validity and returns false if the PV is invalid UTF-8.
3525 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3527 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3533 /* The octets may have got themselves encoded - get them back as
3536 if (!sv_utf8_downgrade(sv, TRUE))
3539 /* it is actually just a matter of turning the utf8 flag on, but
3540 * we want to make sure everything inside is valid utf8 first.
3542 c = (const U8 *) SvPVX_const(sv);
3543 if (!is_utf8_string(c, SvCUR(sv)+1))
3545 e = (const U8 *) SvEND(sv);
3548 if (!UTF8_IS_INVARIANT(ch)) {
3558 =for apidoc sv_setsv
3560 Copies the contents of the source SV C<ssv> into the destination SV
3561 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3562 function if the source SV needs to be reused. Does not handle 'set' magic.
3563 Loosely speaking, it performs a copy-by-value, obliterating any previous
3564 content of the destination.
3566 You probably want to use one of the assortment of wrappers, such as
3567 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3568 C<SvSetMagicSV_nosteal>.
3570 =for apidoc sv_setsv_flags
3572 Copies the contents of the source SV C<ssv> into the destination SV
3573 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3574 function if the source SV needs to be reused. Does not handle 'set' magic.
3575 Loosely speaking, it performs a copy-by-value, obliterating any previous
3576 content of the destination.
3577 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3578 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3579 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3580 and C<sv_setsv_nomg> are implemented in terms of this function.
3582 You probably want to use one of the assortment of wrappers, such as
3583 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3584 C<SvSetMagicSV_nosteal>.
3586 This is the primary function for copying scalars, and most other
3587 copy-ish functions and macros use this underneath.
3593 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3595 I32 mro_changes = 0; /* 1 = method, 2 = isa */
3597 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3599 if (dtype != SVt_PVGV) {
3600 const char * const name = GvNAME(sstr);
3601 const STRLEN len = GvNAMELEN(sstr);
3603 if (dtype >= SVt_PV) {
3609 SvUPGRADE(dstr, SVt_PVGV);
3610 (void)SvOK_off(dstr);
3611 /* FIXME - why are we doing this, then turning it off and on again
3613 isGV_with_GP_on(dstr);
3615 GvSTASH(dstr) = GvSTASH(sstr);
3617 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3618 gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
3619 SvFAKE_on(dstr); /* can coerce to non-glob */
3622 if(GvGP(MUTABLE_GV(sstr))) {
3623 /* If source has method cache entry, clear it */
3625 SvREFCNT_dec(GvCV(sstr));
3629 /* If source has a real method, then a method is
3631 else if(GvCV((const GV *)sstr)) {
3636 /* If dest already had a real method, that's a change as well */
3637 if(!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)) {
3641 if(strEQ(GvNAME((const GV *)dstr),"ISA"))
3644 gp_free(MUTABLE_GV(dstr));
3645 isGV_with_GP_off(dstr);
3646 (void)SvOK_off(dstr);
3647 isGV_with_GP_on(dstr);
3648 GvINTRO_off(dstr); /* one-shot flag */
3649 GvGP(dstr) = gp_ref(GvGP(sstr));
3650 if (SvTAINTED(sstr))
3652 if (GvIMPORTED(dstr) != GVf_IMPORTED
3653 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3655 GvIMPORTED_on(dstr);
3658 if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
3659 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3664 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3666 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3668 const int intro = GvINTRO(dstr);
3671 const U32 stype = SvTYPE(sref);
3673 PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3676 GvINTRO_off(dstr); /* one-shot flag */
3677 GvLINE(dstr) = CopLINE(PL_curcop);
3678 GvEGV(dstr) = MUTABLE_GV(dstr);
3683 location = (SV **) &GvCV(dstr);
3684 import_flag = GVf_IMPORTED_CV;
3687 location = (SV **) &GvHV(dstr);
3688 import_flag = GVf_IMPORTED_HV;
3691 location = (SV **) &GvAV(dstr);
3692 import_flag = GVf_IMPORTED_AV;
3695 location = (SV **) &GvIOp(dstr);
3698 location = (SV **) &GvFORM(dstr);
3701 location = &GvSV(dstr);
3702 import_flag = GVf_IMPORTED_SV;
3705 if (stype == SVt_PVCV) {
3706 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3707 if (GvCVGEN(dstr)) {
3708 SvREFCNT_dec(GvCV(dstr));
3710 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3713 SAVEGENERICSV(*location);
3717 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3718 CV* const cv = MUTABLE_CV(*location);
3720 if (!GvCVGEN((const GV *)dstr) &&
3721 (CvROOT(cv) || CvXSUB(cv)))
3723 /* Redefining a sub - warning is mandatory if
3724 it was a const and its value changed. */
3725 if (CvCONST(cv) && CvCONST((const CV *)sref)
3727 == cv_const_sv((const CV *)sref)) {
3729 /* They are 2 constant subroutines generated from
3730 the same constant. This probably means that
3731 they are really the "same" proxy subroutine
3732 instantiated in 2 places. Most likely this is
3733 when a constant is exported twice. Don't warn.
3736 else if (ckWARN(WARN_REDEFINE)
3738 && (!CvCONST((const CV *)sref)
3739 || sv_cmp(cv_const_sv(cv),
3740 cv_const_sv((const CV *)
3742 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3745 ? "Constant subroutine %s::%s redefined"
3746 : "Subroutine %s::%s redefined"),
3747 HvNAME_get(GvSTASH((const GV *)dstr)),
3748 GvENAME(MUTABLE_GV(dstr)));
3752 cv_ckproto_len(cv, (const GV *)dstr,
3753 SvPOK(sref) ? SvPVX_const(sref) : NULL,
3754 SvPOK(sref) ? SvCUR(sref) : 0);
3756 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3757 GvASSUMECV_on(dstr);
3758 if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3761 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3762 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3763 GvFLAGS(dstr) |= import_flag;
3765 if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
3766 sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3767 mro_isa_changed_in(GvSTASH(dstr));
3772 if (SvTAINTED(sstr))
3778 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3781 register U32 sflags;
3783 register svtype stype;
3785 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3790 if (SvIS_FREED(dstr)) {
3791 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3792 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3794 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3796 sstr = &PL_sv_undef;
3797 if (SvIS_FREED(sstr)) {
3798 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3799 (void*)sstr, (void*)dstr);
3801 stype = SvTYPE(sstr);
3802 dtype = SvTYPE(dstr);
3804 (void)SvAMAGIC_off(dstr);
3807 /* need to nuke the magic */
3811 /* There's a lot of redundancy below but we're going for speed here */
3816 if (dtype != SVt_PVGV) {
3817 (void)SvOK_off(dstr);
3825 sv_upgrade(dstr, SVt_IV);
3829 sv_upgrade(dstr, SVt_PVIV);
3832 goto end_of_first_switch;
3834 (void)SvIOK_only(dstr);
3835 SvIV_set(dstr, SvIVX(sstr));
3838 /* SvTAINTED can only be true if the SV has taint magic, which in
3839 turn means that the SV type is PVMG (or greater). This is the
3840 case statement for SVt_IV, so this cannot be true (whatever gcov
3842 assert(!SvTAINTED(sstr));
3847 if (dtype < SVt_PV && dtype != SVt_IV)
3848 sv_upgrade(dstr, SVt_IV);
3856 sv_upgrade(dstr, SVt_NV);
3860 sv_upgrade(dstr, SVt_PVNV);
3863 goto end_of_first_switch;
3865 SvNV_set(dstr, SvNVX(sstr));
3866 (void)SvNOK_only(dstr);
3867 /* SvTAINTED can only be true if the SV has taint magic, which in
3868 turn means that the SV type is PVMG (or greater). This is the
3869 case statement for SVt_NV, so this cannot be true (whatever gcov
3871 assert(!SvTAINTED(sstr));
3877 #ifdef PERL_OLD_COPY_ON_WRITE
3878 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3879 if (dtype < SVt_PVIV)
3880 sv_upgrade(dstr, SVt_PVIV);
3887 sv_upgrade(dstr, SVt_PV);
3890 if (dtype < SVt_PVIV)
3891 sv_upgrade(dstr, SVt_PVIV);
3894 if (dtype < SVt_PVNV)
3895 sv_upgrade(dstr, SVt_PVNV);
3899 const char * const type = sv_reftype(sstr,0);
3901 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
3903 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3908 if (dtype < SVt_REGEXP)
3909 sv_upgrade(dstr, SVt_REGEXP);
3912 /* case SVt_BIND: */
3915 if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
3916 glob_assign_glob(dstr, sstr, dtype);
3919 /* SvVALID means that this PVGV is playing at being an FBM. */
3923 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3925 if (SvTYPE(sstr) != stype) {
3926 stype = SvTYPE(sstr);
3927 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
3928 glob_assign_glob(dstr, sstr, dtype);
3933 if (stype == SVt_PVLV)
3934 SvUPGRADE(dstr, SVt_PVNV);
3936 SvUPGRADE(dstr, (svtype)stype);
3938 end_of_first_switch:
3940 /* dstr may have been upgraded. */
3941 dtype = SvTYPE(dstr);
3942 sflags = SvFLAGS(sstr);
3944 if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
3945 /* Assigning to a subroutine sets the prototype. */
3948 const char *const ptr = SvPV_const(sstr, len);
3950 SvGROW(dstr, len + 1);
3951 Copy(ptr, SvPVX(dstr), len + 1, char);
3952 SvCUR_set(dstr, len);
3954 SvFLAGS(dstr) |= sflags & SVf_UTF8;
3958 } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3959 const char * const type = sv_reftype(dstr,0);
3961 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
3963 Perl_croak(aTHX_ "Cannot copy to %s", type);
3964 } else if (sflags & SVf_ROK) {
3965 if (isGV_with_GP(dstr) && dtype == SVt_PVGV
3966 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
3969 if (GvIMPORTED(dstr) != GVf_IMPORTED
3970 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3972 GvIMPORTED_on(dstr);
3977 glob_assign_glob(dstr, sstr, dtype);
3981 if (dtype >= SVt_PV) {
3982 if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3983 glob_assign_ref(dstr, sstr);
3986 if (SvPVX_const(dstr)) {
3992 (void)SvOK_off(dstr);
3993 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3994 SvFLAGS(dstr) |= sflags & SVf_ROK;
3995 assert(!(sflags & SVp_NOK));
3996 assert(!(sflags & SVp_IOK));
3997 assert(!(sflags & SVf_NOK));
3998 assert(!(sflags & SVf_IOK));
4000 else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
4001 if (!(sflags & SVf_OK)) {
4002 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4003 "Undefined value assigned to typeglob");
4006 GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
4007 if (dstr != (const SV *)gv) {
4009 gp_free(MUTABLE_GV(dstr));
4010 GvGP(dstr) = gp_ref(GvGP(gv));
4014 else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
4015 reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4017 else if (sflags & SVp_POK) {
4021 * Check to see if we can just swipe the string. If so, it's a
4022 * possible small lose on short strings, but a big win on long ones.
4023 * It might even be a win on short strings if SvPVX_const(dstr)
4024 * has to be allocated and SvPVX_const(sstr) has to be freed.
4025 * Likewise if we can set up COW rather than doing an actual copy, we
4026 * drop to the else clause, as the swipe code and the COW setup code
4027 * have much in common.
4030 /* Whichever path we take through the next code, we want this true,
4031 and doing it now facilitates the COW check. */
4032 (void)SvPOK_only(dstr);
4035 /* If we're already COW then this clause is not true, and if COW
4036 is allowed then we drop down to the else and make dest COW
4037 with us. If caller hasn't said that we're allowed to COW
4038 shared hash keys then we don't do the COW setup, even if the
4039 source scalar is a shared hash key scalar. */
4040 (((flags & SV_COW_SHARED_HASH_KEYS)
4041 ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4042 : 1 /* If making a COW copy is forbidden then the behaviour we
4043 desire is as if the source SV isn't actually already
4044 COW, even if it is. So we act as if the source flags
4045 are not COW, rather than actually testing them. */
4047 #ifndef PERL_OLD_COPY_ON_WRITE
4048 /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4049 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4050 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4051 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4052 but in turn, it's somewhat dead code, never expected to go
4053 live, but more kept as a placeholder on how to do it better
4054 in a newer implementation. */
4055 /* If we are COW and dstr is a suitable target then we drop down
4056 into the else and make dest a COW of us. */
4057 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4062 (sflags & SVs_TEMP) && /* slated for free anyway? */
4063 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4064 (!(flags & SV_NOSTEAL)) &&
4065 /* and we're allowed to steal temps */
4066 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4067 SvLEN(sstr)) /* and really is a string */
4068 #ifdef PERL_OLD_COPY_ON_WRITE
4069 && ((flags & SV_COW_SHARED_HASH_KEYS)
4070 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4071 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4072 && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4076 /* Failed the swipe test, and it's not a shared hash key either.
4077 Have to copy the string. */
4078 STRLEN len = SvCUR(sstr);
4079 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4080 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4081 SvCUR_set(dstr, len);
4082 *SvEND(dstr) = '\0';
4084 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4086 /* Either it's a shared hash key, or it's suitable for
4087 copy-on-write or we can swipe the string. */
4089 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4093 #ifdef PERL_OLD_COPY_ON_WRITE
4095 if ((sflags & (SVf_FAKE | SVf_READONLY))
4096 != (SVf_FAKE | SVf_READONLY)) {
4097 SvREADONLY_on(sstr);
4099 /* Make the source SV into a loop of 1.
4100 (about to become 2) */
4101 SV_COW_NEXT_SV_SET(sstr, sstr);
4105 /* Initial code is common. */
4106 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4111 /* making another shared SV. */
4112 STRLEN cur = SvCUR(sstr);
4113 STRLEN len = SvLEN(sstr);
4114 #ifdef PERL_OLD_COPY_ON_WRITE
4116 assert (SvTYPE(dstr) >= SVt_PVIV);
4117 /* SvIsCOW_normal */
4118 /* splice us in between source and next-after-source. */
4119 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4120 SV_COW_NEXT_SV_SET(sstr, dstr);
4121 SvPV_set(dstr, SvPVX_mutable(sstr));
4125 /* SvIsCOW_shared_hash */
4126 DEBUG_C(PerlIO_printf(Perl_debug_log,
4127 "Copy on write: Sharing hash\n"));
4129 assert (SvTYPE(dstr) >= SVt_PV);
4131 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4133 SvLEN_set(dstr, len);
4134 SvCUR_set(dstr, cur);
4135 SvREADONLY_on(dstr);
4139 { /* Passes the swipe test. */
4140 SvPV_set(dstr, SvPVX_mutable(sstr));
4141 SvLEN_set(dstr, SvLEN(sstr));
4142 SvCUR_set(dstr, SvCUR(sstr));
4145 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4146 SvPV_set(sstr, NULL);
4152 if (sflags & SVp_NOK) {
4153 SvNV_set(dstr, SvNVX(sstr));
4155 if (sflags & SVp_IOK) {
4156 SvIV_set(dstr, SvIVX(sstr));
4157 /* Must do this otherwise some other overloaded use of 0x80000000
4158 gets confused. I guess SVpbm_VALID */
4159 if (sflags & SVf_IVisUV)
4162 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4164 const MAGIC * const smg = SvVSTRING_mg(sstr);
4166 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4167 smg->mg_ptr, smg->mg_len);
4168 SvRMAGICAL_on(dstr);
4172 else if (sflags & (SVp_IOK|SVp_NOK)) {
4173 (void)SvOK_off(dstr);
4174 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4175 if (sflags & SVp_IOK) {
4176 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4177 SvIV_set(dstr, SvIVX(sstr));
4179 if (sflags & SVp_NOK) {
4180 SvNV_set(dstr, SvNVX(sstr));
4184 if (isGV_with_GP(sstr)) {
4185 /* This stringification rule for globs is spread in 3 places.
4186 This feels bad. FIXME. */
4187 const U32 wasfake = sflags & SVf_FAKE;
4189 /* FAKE globs can get coerced, so need to turn this off
4190 temporarily if it is on. */
4192 gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4193 SvFLAGS(sstr) |= wasfake;
4196 (void)SvOK_off(dstr);
4198 if (SvTAINTED(sstr))
4203 =for apidoc sv_setsv_mg
4205 Like C<sv_setsv>, but also handles 'set' magic.
4211 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4213 PERL_ARGS_ASSERT_SV_SETSV_MG;
4215 sv_setsv(dstr,sstr);
4219 #ifdef PERL_OLD_COPY_ON_WRITE
4221 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4223 STRLEN cur = SvCUR(sstr);
4224 STRLEN len = SvLEN(sstr);
4225 register char *new_pv;
4227 PERL_ARGS_ASSERT_SV_SETSV_COW;
4230 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4231 (void*)sstr, (void*)dstr);
4238 if (SvTHINKFIRST(dstr))
4239 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4240 else if (SvPVX_const(dstr))
4241 Safefree(SvPVX_const(dstr));
4245 SvUPGRADE(dstr, SVt_PVIV);
4247 assert (SvPOK(sstr));
4248 assert (SvPOKp(sstr));
4249 assert (!SvIOK(sstr));
4250 assert (!SvIOKp(sstr));
4251 assert (!SvNOK(sstr));
4252 assert (!SvNOKp(sstr));
4254 if (SvIsCOW(sstr)) {
4256 if (SvLEN(sstr) == 0) {
4257 /* source is a COW shared hash key. */
4258 DEBUG_C(PerlIO_printf(Perl_debug_log,
4259 "Fast copy on write: Sharing hash\n"));
4260 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4263 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4265 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4266 SvUPGRADE(sstr, SVt_PVIV);
4267 SvREADONLY_on(sstr);
4269 DEBUG_C(PerlIO_printf(Perl_debug_log,
4270 "Fast copy on write: Converting sstr to COW\n"));
4271 SV_COW_NEXT_SV_SET(dstr, sstr);
4273 SV_COW_NEXT_SV_SET(sstr, dstr);
4274 new_pv = SvPVX_mutable(sstr);
4277 SvPV_set(dstr, new_pv);
4278 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4281 SvLEN_set(dstr, len);
4282 SvCUR_set(dstr, cur);
4291 =for apidoc sv_setpvn
4293 Copies a string into an SV. The C<len> parameter indicates the number of
4294 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4295 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4301 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4304 register char *dptr;
4306 PERL_ARGS_ASSERT_SV_SETPVN;
4308 SV_CHECK_THINKFIRST_COW_DROP(sv);
4314 /* len is STRLEN which is unsigned, need to copy to signed */
4317 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4319 SvUPGRADE(sv, SVt_PV);
4321 dptr = SvGROW(sv, len + 1);
4322 Move(ptr,dptr,len,char);
4325 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4330 =for apidoc sv_setpvn_mg
4332 Like C<sv_setpvn>, but also handles 'set' magic.
4338 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4340 PERL_ARGS_ASSERT_SV_SETPVN_MG;
4342 sv_setpvn(sv,ptr,len);
4347 =for apidoc sv_setpv
4349 Copies a string into an SV. The string must be null-terminated. Does not
4350 handle 'set' magic. See C<sv_setpv_mg>.
4356 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4359 register STRLEN len;
4361 PERL_ARGS_ASSERT_SV_SETPV;
4363 SV_CHECK_THINKFIRST_COW_DROP(sv);
4369 SvUPGRADE(sv, SVt_PV);
4371 SvGROW(sv, len + 1);
4372 Move(ptr,SvPVX(sv),len+1,char);
4374 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4379 =for apidoc sv_setpv_mg
4381 Like C<sv_setpv>, but also handles 'set' magic.
4387 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4389 PERL_ARGS_ASSERT_SV_SETPV_MG;
4396 =for apidoc sv_usepvn_flags
4398 Tells an SV to use C<ptr> to find its string value. Normally the
4399 string is stored inside the SV but sv_usepvn allows the SV to use an
4400 outside string. The C<ptr> should point to memory that was allocated
4401 by C<malloc>. The string length, C<len>, must be supplied. By default
4402 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4403 so that pointer should not be freed or used by the programmer after
4404 giving it to sv_usepvn, and neither should any pointers from "behind"
4405 that pointer (e.g. ptr + 1) be used.
4407 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4408 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4409 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4410 C<len>, and already meets the requirements for storing in C<SvPVX>)
4416 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4421 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4423 SV_CHECK_THINKFIRST_COW_DROP(sv);
4424 SvUPGRADE(sv, SVt_PV);
4427 if (flags & SV_SMAGIC)
4431 if (SvPVX_const(sv))
4435 if (flags & SV_HAS_TRAILING_NUL)
4436 assert(ptr[len] == '\0');
4439 allocate = (flags & SV_HAS_TRAILING_NUL)
4441 #ifdef Perl_safesysmalloc_size
4444 PERL_STRLEN_ROUNDUP(len + 1);
4446 if (flags & SV_HAS_TRAILING_NUL) {
4447 /* It's long enough - do nothing.
4448 Specfically Perl_newCONSTSUB is relying on this. */
4451 /* Force a move to shake out bugs in callers. */
4452 char *new_ptr = (char*)safemalloc(allocate);
4453 Copy(ptr, new_ptr, len, char);
4454 PoisonFree(ptr,len,char);
4458 ptr = (char*) saferealloc (ptr, allocate);
4461 #ifdef Perl_safesysmalloc_size
4462 SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4464 SvLEN_set(sv, allocate);
4468 if (!(flags & SV_HAS_TRAILING_NUL)) {
4471 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4473 if (flags & SV_SMAGIC)
4477 #ifdef PERL_OLD_COPY_ON_WRITE
4478 /* Need to do this *after* making the SV normal, as we need the buffer
4479 pointer to remain valid until after we've copied it. If we let go too early,
4480 another thread could invalidate it by unsharing last of the same hash key
4481 (which it can do by means other than releasing copy-on-write Svs)
4482 or by changing the other copy-on-write SVs in the loop. */
4484 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4486 PERL_ARGS_ASSERT_SV_RELEASE_COW;
4488 { /* this SV was SvIsCOW_normal(sv) */
4489 /* we need to find the SV pointing to us. */
4490 SV *current = SV_COW_NEXT_SV(after);
4492 if (current == sv) {
4493 /* The SV we point to points back to us (there were only two of us
4495 Hence other SV is no longer copy on write either. */
4497 SvREADONLY_off(after);
4499 /* We need to follow the pointers around the loop. */
4501 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4504 /* don't loop forever if the structure is bust, and we have
4505 a pointer into a closed loop. */
4506 assert (current != after);
4507 assert (SvPVX_const(current) == pvx);
4509 /* Make the SV before us point to the SV after us. */
4510 SV_COW_NEXT_SV_SET(current, after);
4516 =for apidoc sv_force_normal_flags
4518 Undo various types of fakery on an SV: if the PV is a shared string, make
4519 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4520 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4521 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4522 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4523 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4524 set to some other value.) In addition, the C<flags> parameter gets passed to
4525 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4526 with flags set to 0.
4532 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4536 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4538 #ifdef PERL_OLD_COPY_ON_WRITE
4539 if (SvREADONLY(sv)) {
4541 const char * const pvx = SvPVX_const(sv);
4542 const STRLEN len = SvLEN(sv);
4543 const STRLEN cur = SvCUR(sv);
4544 /* next COW sv in the loop. If len is 0 then this is a shared-hash
4545 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4546 we'll fail an assertion. */
4547 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4550 PerlIO_printf(Perl_debug_log,
4551 "Copy on write: Force normal %ld\n",
4557 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4560 if (flags & SV_COW_DROP_PV) {
4561 /* OK, so we don't need to copy our buffer. */
4564 SvGROW(sv, cur + 1);
4565 Move(pvx,SvPVX(sv),cur,char);
4570 sv_release_COW(sv, pvx, next);
4572 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4578 else if (IN_PERL_RUNTIME)
4579 Perl_croak(aTHX_ "%s", PL_no_modify);
4582 if (SvREADONLY(sv)) {
4584 const char * const pvx = SvPVX_const(sv);
4585 const STRLEN len = SvCUR(sv);
4590 SvGROW(sv, len + 1);
4591 Move(pvx,SvPVX(sv),len,char);
4593 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4595 else if (IN_PERL_RUNTIME)
4596 Perl_croak(aTHX_ "%s", PL_no_modify);
4600 sv_unref_flags(sv, flags);
4601 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4603 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
4604 /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous
4605 to sv_unglob. We only need it here, so inline it. */
4606 const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
4607 SV *const temp = newSV_type(new_type);
4608 void *const temp_p = SvANY(sv);
4610 if (new_type == SVt_PVMG) {
4611 SvMAGIC_set(temp, SvMAGIC(sv));
4612 SvMAGIC_set(sv, NULL);
4613 SvSTASH_set(temp, SvSTASH(sv));
4614 SvSTASH_set(sv, NULL);
4616 SvCUR_set(temp, SvCUR(sv));
4617 /* Remember that SvPVX is in the head, not the body. */
4619 SvLEN_set(temp, SvLEN(sv));
4620 /* This signals "buffer is owned by someone else" in sv_clear,
4621 which is the least effort way to stop it freeing the buffer.
4623 SvLEN_set(sv, SvLEN(sv)+1);
4625 /* Their buffer is already owned by someone else. */
4626 SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
4627 SvLEN_set(temp, SvCUR(sv)+1);
4630 /* Now swap the rest of the bodies. */
4632 SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
4633 SvFLAGS(sv) |= new_type;
4634 SvANY(sv) = SvANY(temp);
4636 SvFLAGS(temp) &= ~(SVTYPEMASK);
4637 SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
4638 SvANY(temp) = temp_p;
4647 Efficient removal of characters from the beginning of the string buffer.
4648 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4649 the string buffer. The C<ptr> becomes the first character of the adjusted
4650 string. Uses the "OOK hack".
4651 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4652 refer to the same chunk of data.
4658 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4664 const U8 *real_start;
4668 PERL_ARGS_ASSERT_SV_CHOP;
4670 if (!ptr || !SvPOKp(sv))
4672 delta = ptr - SvPVX_const(sv);
4674 /* Nothing to do. */
4677 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4678 nothing uses the value of ptr any more. */
4679 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4680 if (ptr <= SvPVX_const(sv))
4681 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4682 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4683 SV_CHECK_THINKFIRST(sv);
4684 if (delta > max_delta)
4685 Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4686 SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4687 SvPVX_const(sv) + max_delta);
4690 if (!SvLEN(sv)) { /* make copy of shared string */
4691 const char *pvx = SvPVX_const(sv);
4692 const STRLEN len = SvCUR(sv);
4693 SvGROW(sv, len + 1);
4694 Move(pvx,SvPVX(sv),len,char);
4697 SvFLAGS(sv) |= SVf_OOK;
4700 SvOOK_offset(sv, old_delta);
4702 SvLEN_set(sv, SvLEN(sv) - delta);
4703 SvCUR_set(sv, SvCUR(sv) - delta);
4704 SvPV_set(sv, SvPVX(sv) + delta);
4706 p = (U8 *)SvPVX_const(sv);
4711 real_start = p - delta;
4715 if (delta < 0x100) {
4719 p -= sizeof(STRLEN);
4720 Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4724 /* Fill the preceding buffer with sentinals to verify that no-one is
4726 while (p > real_start) {
4734 =for apidoc sv_catpvn
4736 Concatenates the string onto the end of the string which is in the SV. The
4737 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4738 status set, then the bytes appended should be valid UTF-8.
4739 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4741 =for apidoc sv_catpvn_flags
4743 Concatenates the string onto the end of the string which is in the SV. The
4744 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4745 status set, then the bytes appended should be valid UTF-8.
4746 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4747 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4748 in terms of this function.
4754 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4758 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4760 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4762 SvGROW(dsv, dlen + slen + 1);
4764 sstr = SvPVX_const(dsv);
4765 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4766 SvCUR_set(dsv, SvCUR(dsv) + slen);
4768 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4770 if (flags & SV_SMAGIC)
4775 =for apidoc sv_catsv
4777 Concatenates the string from SV C<ssv> onto the end of the string in
4778 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4779 not 'set' magic. See C<sv_catsv_mg>.
4781 =for apidoc sv_catsv_flags
4783 Concatenates the string from SV C<ssv> onto the end of the string in
4784 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4785 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4786 and C<sv_catsv_nomg> are implemented in terms of this function.
4791 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4795 PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4799 const char *spv = SvPV_const(ssv, slen);
4801 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4802 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4803 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4804 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4805 dsv->sv_flags doesn't have that bit set.
4806 Andy Dougherty 12 Oct 2001
4808 const I32 sutf8 = DO_UTF8(ssv);
4811 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4813 dutf8 = DO_UTF8(dsv);
4815 if (dutf8 != sutf8) {
4817 /* Not modifying source SV, so taking a temporary copy. */
4818 SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4820 sv_utf8_upgrade(csv);
4821 spv = SvPV_const(csv, slen);
4824 /* Leave enough space for the cat that's about to happen */
4825 sv_utf8_upgrade_flags_grow(dsv, 0, slen);
4827 sv_catpvn_nomg(dsv, spv, slen);
4830 if (flags & SV_SMAGIC)
4835 =for apidoc sv_catpv
4837 Concatenates the string onto the end of the string which is in the SV.
4838 If the SV has the UTF-8 status set, then the bytes appended should be
4839 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4844 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4847 register STRLEN len;
4851 PERL_ARGS_ASSERT_SV_CATPV;
4855 junk = SvPV_force(sv, tlen);
4857 SvGROW(sv, tlen + len + 1);
4859 ptr = SvPVX_const(sv);
4860 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4861 SvCUR_set(sv, SvCUR(sv) + len);
4862 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4867 =for apidoc sv_catpv_mg
4869 Like C<sv_catpv>, but also handles 'set' magic.
4875 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4877 PERL_ARGS_ASSERT_SV_CATPV_MG;
4886 Creates a new SV. A non-zero C<len> parameter indicates the number of
4887 bytes of preallocated string space the SV should have. An extra byte for a
4888 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
4889 space is allocated.) The reference count for the new SV is set to 1.
4891 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4892 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4893 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4894 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
4895 modules supporting older perls.
4901 Perl_newSV(pTHX_ const STRLEN len)
4908 sv_upgrade(sv, SVt_PV);
4909 SvGROW(sv, len + 1);
4914 =for apidoc sv_magicext
4916 Adds magic to an SV, upgrading it if necessary. Applies the
4917 supplied vtable and returns a pointer to the magic added.
4919 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4920 In particular, you can add magic to SvREADONLY SVs, and add more than
4921 one instance of the same 'how'.
4923 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4924 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4925 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4926 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4928 (This is now used as a subroutine by C<sv_magic>.)
4933 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
4934 const MGVTBL *const vtable, const char *const name, const I32 namlen)
4939 PERL_ARGS_ASSERT_SV_MAGICEXT;
4941 SvUPGRADE(sv, SVt_PVMG);
4942 Newxz(mg, 1, MAGIC);
4943 mg->mg_moremagic = SvMAGIC(sv);
4944 SvMAGIC_set(sv, mg);
4946 /* Sometimes a magic contains a reference loop, where the sv and
4947 object refer to each other. To prevent a reference loop that
4948 would prevent such objects being freed, we look for such loops
4949 and if we find one we avoid incrementing the object refcount.
4951 Note we cannot do this to avoid self-tie loops as intervening RV must
4952 have its REFCNT incremented to keep it in existence.
4955 if (!obj || obj == sv ||
4956 how == PERL_MAGIC_arylen ||
4957 how == PERL_MAGIC_symtab ||
4958 (SvTYPE(obj) == SVt_PVGV &&
4959 (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
4960 || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
4961 || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
4966 mg->mg_obj = SvREFCNT_inc_simple(obj);
4967 mg->mg_flags |= MGf_REFCOUNTED;
4970 /* Normal self-ties simply pass a null object, and instead of
4971 using mg_obj directly, use the SvTIED_obj macro to produce a
4972 new RV as needed. For glob "self-ties", we are tieing the PVIO
4973 with an RV obj pointing to the glob containing the PVIO. In
4974 this case, to avoid a reference loop, we need to weaken the
4978 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4979 obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
4985 mg->mg_len = namlen;
4988 mg->mg_ptr = savepvn(name, namlen);
4989 else if (namlen == HEf_SVKEY) {
4990 /* Yes, this is casting away const. This is only for the case of
4991 HEf_SVKEY. I think we need to document this abberation of the
4992 constness of the API, rather than making name non-const, as
4993 that change propagating outwards a long way. */
4994 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
4996 mg->mg_ptr = (char *) name;
4998 mg->mg_virtual = (MGVTBL *) vtable;
5002 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5007 =for apidoc sv_magic
5009 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5010 then adds a new magic item of type C<how> to the head of the magic list.
5012 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5013 handling of the C<name> and C<namlen> arguments.
5015 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5016 to add more than one instance of the same 'how'.
5022 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
5023 const char *const name, const I32 namlen)
5026 const MGVTBL *vtable;
5029 PERL_ARGS_ASSERT_SV_MAGIC;
5031 #ifdef PERL_OLD_COPY_ON_WRITE
5033 sv_force_normal_flags(sv, 0);
5035 if (SvREADONLY(sv)) {
5037 /* its okay to attach magic to shared strings; the subsequent
5038 * upgrade to PVMG will unshare the string */
5039 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
5042 && how != PERL_MAGIC_regex_global
5043 && how != PERL_MAGIC_bm
5044 && how != PERL_MAGIC_fm
5045 && how != PERL_MAGIC_sv
5046 && how != PERL_MAGIC_backref
5049 Perl_croak(aTHX_ "%s", PL_no_modify);
5052 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5053 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5054 /* sv_magic() refuses to add a magic of the same 'how' as an
5057 if (how == PERL_MAGIC_taint) {
5059 /* Any scalar which already had taint magic on which someone
5060 (erroneously?) did SvIOK_on() or similar will now be
5061 incorrectly sporting public "OK" flags. */
5062 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5070 vtable = &PL_vtbl_sv;
5072 case PERL_MAGIC_overload:
5073 vtable = &PL_vtbl_amagic;
5075 case PERL_MAGIC_overload_elem:
5076 vtable = &PL_vtbl_amagicelem;
5078 case PERL_MAGIC_overload_table:
5079 vtable = &PL_vtbl_ovrld;
5082 vtable = &PL_vtbl_bm;
5084 case PERL_MAGIC_regdata:
5085 vtable = &PL_vtbl_regdata;
5087 case PERL_MAGIC_regdatum:
5088 vtable = &PL_vtbl_regdatum;
5090 case PERL_MAGIC_env:
5091 vtable = &PL_vtbl_env;
5094 vtable = &PL_vtbl_fm;
5096 case PERL_MAGIC_envelem:
5097 vtable = &PL_vtbl_envelem;
5099 case PERL_MAGIC_regex_global:
5100 vtable = &PL_vtbl_mglob;
5102 case PERL_MAGIC_isa:
5103 vtable = &PL_vtbl_isa;
5105 case PERL_MAGIC_isaelem:
5106 vtable = &PL_vtbl_isaelem;
5108 case PERL_MAGIC_nkeys:
5109 vtable = &PL_vtbl_nkeys;
5111 case PERL_MAGIC_dbfile:
5114 case PERL_MAGIC_dbline:
5115 vtable = &PL_vtbl_dbline;
5117 #ifdef USE_LOCALE_COLLATE
5118 case PERL_MAGIC_collxfrm:
5119 vtable = &PL_vtbl_collxfrm;
5121 #endif /* USE_LOCALE_COLLATE */
5122 case PERL_MAGIC_tied:
5123 vtable = &PL_vtbl_pack;
5125 case PERL_MAGIC_tiedelem:
5126 case PERL_MAGIC_tiedscalar:
5127 vtable = &PL_vtbl_packelem;
5130 vtable = &PL_vtbl_regexp;
5132 case PERL_MAGIC_sig:
5133 vtable = &PL_vtbl_sig;
5135 case PERL_MAGIC_sigelem:
5136 vtable = &PL_vtbl_sigelem;
5138 case PERL_MAGIC_taint:
5139 vtable = &PL_vtbl_taint;
5141 case PERL_MAGIC_uvar:
5142 vtable = &PL_vtbl_uvar;
5144 case PERL_MAGIC_vec:
5145 vtable = &PL_vtbl_vec;
5147 case PERL_MAGIC_arylen_p:
5148 case PERL_MAGIC_rhash:
5149 case PERL_MAGIC_symtab:
5150 case PERL_MAGIC_vstring:
5153 case PERL_MAGIC_utf8:
5154 vtable = &PL_vtbl_utf8;
5156 case PERL_MAGIC_substr:
5157 vtable = &PL_vtbl_substr;
5159 case PERL_MAGIC_defelem:
5160 vtable = &PL_vtbl_defelem;
5162 case PERL_MAGIC_arylen:
5163 vtable = &PL_vtbl_arylen;
5165 case PERL_MAGIC_pos:
5166 vtable = &PL_vtbl_pos;
5168 case PERL_MAGIC_backref:
5169 vtable = &PL_vtbl_backref;
5171 case PERL_MAGIC_hintselem:
5172 vtable = &PL_vtbl_hintselem;
5174 case PERL_MAGIC_hints:
5175 vtable = &PL_vtbl_hints;
5177 case PERL_MAGIC_ext:
5178 /* Reserved for use by extensions not perl internals. */
5179 /* Useful for attaching extension internal data to perl vars. */
5180 /* Note that multiple extensions may clash if magical scalars */
5181 /* etc holding private data from one are passed to another. */
5185 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5188 /* Rest of work is done else where */
5189 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5192 case PERL_MAGIC_taint:
5195 case PERL_MAGIC_ext:
5196 case PERL_MAGIC_dbfile:
5203 =for apidoc sv_unmagic
5205 Removes all magic of type C<type> from an SV.
5211 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5216 PERL_ARGS_ASSERT_SV_UNMAGIC;
5218 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5220 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5221 for (mg = *mgp; mg; mg = *mgp) {
5222 if (mg->mg_type == type) {
5223 const MGVTBL* const vtbl = mg->mg_virtual;
5224 *mgp = mg->mg_moremagic;
5225 if (vtbl && vtbl->svt_free)
5226 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5227 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5229 Safefree(mg->mg_ptr);
5230 else if (mg->mg_len == HEf_SVKEY)
5231 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5232 else if (mg->mg_type == PERL_MAGIC_utf8)
5233 Safefree(mg->mg_ptr);
5235 if (mg->mg_flags & MGf_REFCOUNTED)
5236 SvREFCNT_dec(mg->mg_obj);
5240 mgp = &mg->mg_moremagic;
5243 if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
5244 mg_magical(sv); /* else fix the flags now */
5248 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5254 =for apidoc sv_rvweaken
5256 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5257 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5258 push a back-reference to this RV onto the array of backreferences
5259 associated with that magic. If the RV is magical, set magic will be
5260 called after the RV is cleared.
5266 Perl_sv_rvweaken(pTHX_ SV *const sv)
5270 PERL_ARGS_ASSERT_SV_RVWEAKEN;
5272 if (!SvOK(sv)) /* let undefs pass */
5275 Perl_croak(aTHX_ "Can't weaken a nonreference");
5276 else if (SvWEAKREF(sv)) {
5277 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5281 Perl_sv_add_backref(aTHX_ tsv, sv);
5287 /* Give tsv backref magic if it hasn't already got it, then push a
5288 * back-reference to sv onto the array associated with the backref magic.
5291 /* A discussion about the backreferences array and its refcount:
5293 * The AV holding the backreferences is pointed to either as the mg_obj of
5294 * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
5295 * structure, from the xhv_backreferences field. (A HV without hv_aux will
5296 * have the standard magic instead.) The array is created with a refcount
5297 * of 2. This means that if during global destruction the array gets
5298 * picked on first to have its refcount decremented by the random zapper,
5299 * it won't actually be freed, meaning it's still theere for when its
5300 * parent gets freed.
5301 * When the parent SV is freed, in the case of magic, the magic is freed,
5302 * Perl_magic_killbackrefs is called which decrements one refcount, then
5303 * mg_obj is freed which kills the second count.
5304 * In the vase of a HV being freed, one ref is removed by
5305 * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
5310 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5315 PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5317 if (SvTYPE(tsv) == SVt_PVHV) {
5318 AV **const avp = Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5322 /* There is no AV in the offical place - try a fixup. */
5323 MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
5326 /* Aha. They've got it stowed in magic. Bring it back. */
5327 av = MUTABLE_AV(mg->mg_obj);
5328 /* Stop mg_free decreasing the refernce count. */
5330 /* Stop mg_free even calling the destructor, given that
5331 there's no AV to free up. */
5333 sv_unmagic(tsv, PERL_MAGIC_backref);
5337 SvREFCNT_inc_simple_void(av); /* see discussion above */
5342 const MAGIC *const mg
5343 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5345 av = MUTABLE_AV(mg->mg_obj);
5349 sv_magic(tsv, MUTABLE_SV(av), PERL_MAGIC_backref, NULL, 0);
5350 /* av now has a refcnt of 2; see discussion above */
5353 if (AvFILLp(av) >= AvMAX(av)) {
5354 av_extend(av, AvFILLp(av)+1);
5356 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5359 /* delete a back-reference to ourselves from the backref magic associated
5360 * with the SV we point to.
5364 S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5371 PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5373 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5374 av = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5375 /* We mustn't attempt to "fix up" the hash here by moving the
5376 backreference array back to the hv_aux structure, as that is stored
5377 in the main HvARRAY(), and hfreentries assumes that no-one
5378 reallocates HvARRAY() while it is running. */
5381 const MAGIC *const mg
5382 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5384 av = MUTABLE_AV(mg->mg_obj);
5388 Perl_croak(aTHX_ "panic: del_backref");
5390 assert(!SvIS_FREED(av));
5393 /* We shouldn't be in here more than once, but for paranoia reasons lets
5395 for (i = AvFILLp(av); i >= 0; i--) {
5397 const SSize_t fill = AvFILLp(av);
5399 /* We weren't the last entry.
5400 An unordered list has this property that you can take the
5401 last element off the end to fill the hole, and it's still
5402 an unordered list :-)
5407 AvFILLp(av) = fill - 1;
5413 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5415 SV **svp = AvARRAY(av);
5417 PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5418 PERL_UNUSED_ARG(sv);
5420 assert(!svp || !SvIS_FREED(av));
5422 SV *const *const last = svp + AvFILLp(av);
5424 while (svp <= last) {
5426 SV *const referrer = *svp;
5427 if (SvWEAKREF(referrer)) {
5428 /* XXX Should we check that it hasn't changed? */
5429 SvRV_set(referrer, 0);
5431 SvWEAKREF_off(referrer);
5432 SvSETMAGIC(referrer);
5433 } else if (SvTYPE(referrer) == SVt_PVGV ||
5434 SvTYPE(referrer) == SVt_PVLV) {
5435 /* You lookin' at me? */
5436 assert(GvSTASH(referrer));
5437 assert(GvSTASH(referrer) == (const HV *)sv);
5438 GvSTASH(referrer) = 0;
5441 "panic: magic_killbackrefs (flags=%"UVxf")",
5442 (UV)SvFLAGS(referrer));
5450 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5455 =for apidoc sv_insert
5457 Inserts a string at the specified offset/length within the SV. Similar to
5458 the Perl substr() function. Handles get magic.
5460 =for apidoc sv_insert_flags
5462 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5468 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5473 register char *midend;
5474 register char *bigend;
5478 PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5481 Perl_croak(aTHX_ "Can't modify non-existent substring");
5482 SvPV_force_flags(bigstr, curlen, flags);
5483 (void)SvPOK_only_UTF8(bigstr);
5484 if (offset + len > curlen) {
5485 SvGROW(bigstr, offset+len+1);
5486 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5487 SvCUR_set(bigstr, offset+len);
5491 i = littlelen - len;
5492 if (i > 0) { /* string might grow */
5493 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5494 mid = big + offset + len;
5495 midend = bigend = big + SvCUR(bigstr);
5498 while (midend > mid) /* shove everything down */
5499 *--bigend = *--midend;
5500 Move(little,big+offset,littlelen,char);
5501 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5506 Move(little,SvPVX(bigstr)+offset,len,char);
5511 big = SvPVX(bigstr);
5514 bigend = big + SvCUR(bigstr);
5516 if (midend > bigend)
5517 Perl_croak(aTHX_ "panic: sv_insert");
5519 if (mid - big > bigend - midend) { /* faster to shorten from end */
5521 Move(little, mid, littlelen,char);
5524 i = bigend - midend;
5526 Move(midend, mid, i,char);
5530 SvCUR_set(bigstr, mid - big);
5532 else if ((i = mid - big)) { /* faster from front */
5533 midend -= littlelen;
5535 Move(big, midend - i, i, char);
5536 sv_chop(bigstr,midend-i);
5538 Move(little, mid, littlelen,char);
5540 else if (littlelen) {
5541 midend -= littlelen;
5542 sv_chop(bigstr,midend);
5543 Move(little,midend,littlelen,char);
5546 sv_chop(bigstr,midend);
5552 =for apidoc sv_replace
5554 Make the first argument a copy of the second, then delete the original.
5555 The target SV physically takes over ownership of the body of the source SV
5556 and inherits its flags; however, the target keeps any magic it owns,
5557 and any magic in the source is discarded.
5558 Note that this is a rather specialist SV copying operation; most of the
5559 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5565 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5568 const U32 refcnt = SvREFCNT(sv);
5570 PERL_ARGS_ASSERT_SV_REPLACE;
5572 SV_CHECK_THINKFIRST_COW_DROP(sv);
5573 if (SvREFCNT(nsv) != 1) {
5574 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
5575 " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
5577 if (SvMAGICAL(sv)) {
5581 sv_upgrade(nsv, SVt_PVMG);
5582 SvMAGIC_set(nsv, SvMAGIC(sv));
5583 SvFLAGS(nsv) |= SvMAGICAL(sv);
5585 SvMAGIC_set(sv, NULL);
5589 assert(!SvREFCNT(sv));
5590 #ifdef DEBUG_LEAKING_SCALARS
5591 sv->sv_flags = nsv->sv_flags;
5592 sv->sv_any = nsv->sv_any;
5593 sv->sv_refcnt = nsv->sv_refcnt;
5594 sv->sv_u = nsv->sv_u;
5596 StructCopy(nsv,sv,SV);
5598 if(SvTYPE(sv) == SVt_IV) {
5600 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5604 #ifdef PERL_OLD_COPY_ON_WRITE
5605 if (SvIsCOW_normal(nsv)) {
5606 /* We need to follow the pointers around the loop to make the
5607 previous SV point to sv, rather than nsv. */
5610 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5613 assert(SvPVX_const(current) == SvPVX_const(nsv));
5615 /* Make the SV before us point to the SV after us. */
5617 PerlIO_printf(Perl_debug_log, "previous is\n");
5619 PerlIO_printf(Perl_debug_log,
5620 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5621 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5623 SV_COW_NEXT_SV_SET(current, sv);
5626 SvREFCNT(sv) = refcnt;
5627 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5633 =for apidoc sv_clear
5635 Clear an SV: call any destructors, free up any memory used by the body,
5636 and free the body itself. The SV's head is I<not> freed, although
5637 its type is set to all 1's so that it won't inadvertently be assumed
5638 to be live during global destruction etc.
5639 This function should only be called when REFCNT is zero. Most of the time
5640 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5647 Perl_sv_clear(pTHX_ register SV *const sv)
5650 const U32 type = SvTYPE(sv);
5651 const struct body_details *const sv_type_details
5652 = bodies_by_type + type;
5655 PERL_ARGS_ASSERT_SV_CLEAR;
5656 assert(SvREFCNT(sv) == 0);
5657 assert(SvTYPE(sv) != SVTYPEMASK);
5659 if (type <= SVt_IV) {
5660 /* See the comment in sv.h about the collusion between this early
5661 return and the overloading of the NULL slots in the size table. */
5664 SvFLAGS(sv) &= SVf_BREAK;
5665 SvFLAGS(sv) |= SVTYPEMASK;
5670 if (PL_defstash && /* Still have a symbol table? */
5677 stash = SvSTASH(sv);
5678 destructor = StashHANDLER(stash,DESTROY);
5680 /* A constant subroutine can have no side effects, so
5681 don't bother calling it. */
5682 && !CvCONST(destructor)
5683 /* Don't bother calling an empty destructor */
5684 && (CvISXSUB(destructor)
5685 || (CvSTART(destructor)
5686 && (CvSTART(destructor)->op_next->op_type != OP_LEAVESUB))))
5688 SV* const tmpref = newRV(sv);
5689 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5691 PUSHSTACKi(PERLSI_DESTROY);
5696 call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5702 if(SvREFCNT(tmpref) < 2) {
5703 /* tmpref is not kept alive! */
5705 SvRV_set(tmpref, NULL);
5708 SvREFCNT_dec(tmpref);
5710 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5714 if (PL_in_clean_objs)
5715 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5717 /* DESTROY gave object new lease on life */
5723 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5724 SvOBJECT_off(sv); /* Curse the object. */
5725 if (type != SVt_PVIO)
5726 --PL_sv_objcount; /* XXX Might want something more general */
5729 if (type >= SVt_PVMG) {
5730 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
5731 SvREFCNT_dec(SvOURSTASH(sv));
5732 } else if (SvMAGIC(sv))
5734 if (type == SVt_PVMG && SvPAD_TYPED(sv))
5735 SvREFCNT_dec(SvSTASH(sv));
5738 /* case SVt_BIND: */
5741 IoIFP(sv) != PerlIO_stdin() &&
5742 IoIFP(sv) != PerlIO_stdout() &&
5743 IoIFP(sv) != PerlIO_stderr())
5745 io_close(MUTABLE_IO(sv), FALSE);
5747 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5748 PerlDir_close(IoDIRP(sv));
5749 IoDIRP(sv) = (DIR*)NULL;
5750 Safefree(IoTOP_NAME(sv));
5751 Safefree(IoFMT_NAME(sv));
5752 Safefree(IoBOTTOM_NAME(sv));
5755 /* FIXME for plugins */
5756 pregfree2((REGEXP*) sv);
5760 cv_undef(MUTABLE_CV(sv));
5763 if (PL_last_swash_hv == (const HV *)sv) {
5764 PL_last_swash_hv = NULL;
5766 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
5767 hv_undef(MUTABLE_HV(sv));
5770 if (PL_comppad == MUTABLE_AV(sv)) {
5774 av_undef(MUTABLE_AV(sv));
5777 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5778 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5779 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5780 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5782 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5783 SvREFCNT_dec(LvTARG(sv));
5785 if (isGV_with_GP(sv)) {
5786 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
5787 && HvNAME_get(stash))
5788 mro_method_changed_in(stash);
5789 gp_free(MUTABLE_GV(sv));
5791 unshare_hek(GvNAME_HEK(sv));
5792 /* If we're in a stash, we don't own a reference to it. However it does
5793 have a back reference to us, which needs to be cleared. */
5794 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
5795 sv_del_backref(MUTABLE_SV(stash), sv);
5797 /* FIXME. There are probably more unreferenced pointers to SVs in the
5798 interpreter struct that we should check and tidy in a similar
5800 if ((const GV *)sv == PL_last_in_gv)
5801 PL_last_in_gv = NULL;
5807 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5810 SvOOK_offset(sv, offset);
5811 SvPV_set(sv, SvPVX_mutable(sv) - offset);
5812 /* Don't even bother with turning off the OOK flag. */
5817 SV * const target = SvRV(sv);
5819 sv_del_backref(target, sv);
5821 SvREFCNT_dec(target);
5824 #ifdef PERL_OLD_COPY_ON_WRITE
5825 else if (SvPVX_const(sv)) {
5828 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5832 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
5834 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5838 } else if (SvLEN(sv)) {
5839 Safefree(SvPVX_const(sv));
5843 else if (SvPVX_const(sv) && SvLEN(sv))
5844 Safefree(SvPVX_mutable(sv));
5845 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5846 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5855 SvFLAGS(sv) &= SVf_BREAK;
5856 SvFLAGS(sv) |= SVTYPEMASK;
5858 if (sv_type_details->arena) {
5859 del_body(((char *)SvANY(sv) + sv_type_details->offset),
5860 &PL_body_roots[type]);
5862 else if (sv_type_details->body_size) {
5863 my_safefree(SvANY(sv));
5868 =for apidoc sv_newref
5870 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5877 Perl_sv_newref(pTHX_ SV *const sv)
5879 PERL_UNUSED_CONTEXT;
5888 Decrement an SV's reference count, and if it drops to zero, call
5889 C<sv_clear> to invoke destructors and free up any memory used by
5890 the body; finally, deallocate the SV's head itself.
5891 Normally called via a wrapper macro C<SvREFCNT_dec>.
5897 Perl_sv_free(pTHX_ SV *const sv)
5902 if (SvREFCNT(sv) == 0) {
5903 if (SvFLAGS(sv) & SVf_BREAK)
5904 /* this SV's refcnt has been artificially decremented to
5905 * trigger cleanup */
5907 if (PL_in_clean_all) /* All is fair */
5909 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5910 /* make sure SvREFCNT(sv)==0 happens very seldom */
5911 SvREFCNT(sv) = (~(U32)0)/2;
5914 if (ckWARN_d(WARN_INTERNAL)) {
5915 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5916 Perl_dump_sv_child(aTHX_ sv);
5918 #ifdef DEBUG_LEAKING_SCALARS
5921 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5922 if (PL_warnhook == PERL_WARNHOOK_FATAL
5923 || ckDEAD(packWARN(WARN_INTERNAL))) {
5924 /* Don't let Perl_warner cause us to escape our fate: */
5928 /* This may not return: */
5929 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5930 "Attempt to free unreferenced scalar: SV 0x%"UVxf
5931 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5934 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5939 if (--(SvREFCNT(sv)) > 0)
5941 Perl_sv_free2(aTHX_ sv);
5945 Perl_sv_free2(pTHX_ SV *const sv)
5949 PERL_ARGS_ASSERT_SV_FREE2;
5953 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
5954 "Attempt to free temp prematurely: SV 0x%"UVxf
5955 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5959 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5960 /* make sure SvREFCNT(sv)==0 happens very seldom */
5961 SvREFCNT(sv) = (~(U32)0)/2;
5972 Returns the length of the string in the SV. Handles magic and type
5973 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5979 Perl_sv_len(pTHX_ register SV *const sv)
5987 len = mg_length(sv);
5989 (void)SvPV_const(sv, len);
5994 =for apidoc sv_len_utf8
5996 Returns the number of characters in the string in an SV, counting wide
5997 UTF-8 bytes as a single character. Handles magic and type coercion.
6003 * The length is cached in PERL_MAGIC_utf8, in the mg_len field. Also the
6004 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6005 * (Note that the mg_len is not the length of the mg_ptr field.
6006 * This allows the cache to store the character length of the string without
6007 * needing to malloc() extra storage to attach to the mg_ptr.)
6012 Perl_sv_len_utf8(pTHX_ register SV *const sv)
6018 return mg_length(sv);
6022 const U8 *s = (U8*)SvPV_const(sv, len);
6026 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6028 if (mg && mg->mg_len != -1) {
6030 if (PL_utf8cache < 0) {
6031 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6033 /* Need to turn the assertions off otherwise we may
6034 recurse infinitely while printing error messages.
6036 SAVEI8(PL_utf8cache);
6038 Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
6039 " real %"UVuf" for %"SVf,
6040 (UV) ulen, (UV) real, SVfARG(sv));
6045 ulen = Perl_utf8_length(aTHX_ s, s + len);
6046 if (!SvREADONLY(sv)) {
6047 if (!mg && (SvTYPE(sv) < SVt_PVMG ||
6048 !(mg = mg_find(sv, PERL_MAGIC_utf8)))) {
6049 mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
6050 &PL_vtbl_utf8, 0, 0);
6054 /* For now, treat "overflowed" as "still unknown".
6056 if (ulen != (STRLEN) mg->mg_len)
6062 return Perl_utf8_length(aTHX_ s, s + len);
6066 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6069 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6072 const U8 *s = start;
6074 PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6076 while (s < send && uoffset--)
6079 /* This is the existing behaviour. Possibly it should be a croak, as
6080 it's actually a bounds error */
6086 /* Given the length of the string in both bytes and UTF-8 characters, decide
6087 whether to walk forwards or backwards to find the byte corresponding to
6088 the passed in UTF-8 offset. */
6090 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6091 const STRLEN uoffset, const STRLEN uend)
6093 STRLEN backw = uend - uoffset;
6095 PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6097 if (uoffset < 2 * backw) {
6098 /* The assumption is that going forwards is twice the speed of going
6099 forward (that's where the 2 * backw comes from).
6100 (The real figure of course depends on the UTF-8 data.) */
6101 return sv_pos_u2b_forwards(start, send, uoffset);
6106 while (UTF8_IS_CONTINUATION(*send))
6109 return send - start;
6112 /* For the string representation of the given scalar, find the byte
6113 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
6114 give another position in the string, *before* the sought offset, which
6115 (which is always true, as 0, 0 is a valid pair of positions), which should
6116 help reduce the amount of linear searching.
6117 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6118 will be used to reduce the amount of linear searching. The cache will be
6119 created if necessary, and the found value offered to it for update. */
6121 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6122 const U8 *const send, const STRLEN uoffset,
6123 STRLEN uoffset0, STRLEN boffset0)
6125 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
6128 PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6130 assert (uoffset >= uoffset0);
6134 && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
6135 (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
6136 if ((*mgp)->mg_ptr) {
6137 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6138 if (cache[0] == uoffset) {
6139 /* An exact match. */
6142 if (cache[2] == uoffset) {
6143 /* An exact match. */
6147 if (cache[0] < uoffset) {
6148 /* The cache already knows part of the way. */
6149 if (cache[0] > uoffset0) {
6150 /* The cache knows more than the passed in pair */
6151 uoffset0 = cache[0];
6152 boffset0 = cache[1];
6154 if ((*mgp)->mg_len != -1) {
6155 /* And we know the end too. */
6157 + sv_pos_u2b_midway(start + boffset0, send,
6159 (*mgp)->mg_len - uoffset0);
6162 + sv_pos_u2b_forwards(start + boffset0,
6163 send, uoffset - uoffset0);
6166 else if (cache[2] < uoffset) {
6167 /* We're between the two cache entries. */
6168 if (cache[2] > uoffset0) {
6169 /* and the cache knows more than the passed in pair */
6170 uoffset0 = cache[2];
6171 boffset0 = cache[3];
6175 + sv_pos_u2b_midway(start + boffset0,
6178 cache[0] - uoffset0);
6181 + sv_pos_u2b_midway(start + boffset0,
6184 cache[2] - uoffset0);
6188 else if ((*mgp)->mg_len != -1) {
6189 /* If we can take advantage of a passed in offset, do so. */
6190 /* In fact, offset0 is either 0, or less than offset, so don't
6191 need to worry about the other possibility. */
6193 + sv_pos_u2b_midway(start + boffset0, send,
6195 (*mgp)->mg_len - uoffset0);
6200 if (!found || PL_utf8cache < 0) {
6201 const STRLEN real_boffset
6202 = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6203 send, uoffset - uoffset0);
6205 if (found && PL_utf8cache < 0) {
6206 if (real_boffset != boffset) {
6207 /* Need to turn the assertions off otherwise we may recurse
6208 infinitely while printing error messages. */
6209 SAVEI8(PL_utf8cache);
6211 Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
6212 " real %"UVuf" for %"SVf,
6213 (UV) boffset, (UV) real_boffset, SVfARG(sv));
6216 boffset = real_boffset;
6220 utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6226 =for apidoc sv_pos_u2b_flags
6228 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6229 the start of the string, to a count of the equivalent number of bytes; if
6230 lenp is non-zero, it does the same to lenp, but this time starting from
6231 the offset, rather than from the start of the string. Handles type coercion.
6232 I<flags> is passed to C<SvPV_flags>, and usually should be
6233 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
6239 * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
6240 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6241 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6246 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
6253 PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
6255 start = (U8*)SvPV_flags(sv, len, flags);
6257 const U8 * const send = start + len;
6259 boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
6262 /* Convert the relative offset to absolute. */
6263 const STRLEN uoffset2 = uoffset + *lenp;
6264 const STRLEN boffset2
6265 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6266 uoffset, boffset) - boffset;
6280 =for apidoc sv_pos_u2b
6282 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6283 the start of the string, to a count of the equivalent number of bytes; if
6284 lenp is non-zero, it does the same to lenp, but this time starting from
6285 the offset, rather than from the start of the string. Handles magic and
6288 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
6295 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6296 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6297 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6301 /* This function is subject to size and sign problems */
6304 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6306 PERL_ARGS_ASSERT_SV_POS_U2B;
6309 STRLEN ulen = (STRLEN)*lenp;
6310 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
6311 SV_GMAGIC|SV_CONST_RETURN);
6314 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
6315 SV_GMAGIC|SV_CONST_RETURN);
6319 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6320 byte length pairing. The (byte) length of the total SV is passed in too,
6321 as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6322 may not have updated SvCUR, so we can't rely on reading it directly.
6324 The proffered utf8/byte length pairing isn't used if the cache already has
6325 two pairs, and swapping either for the proffered pair would increase the
6326 RMS of the intervals between known byte offsets.
6328 The cache itself consists of 4 STRLEN values
6329 0: larger UTF-8 offset
6330 1: corresponding byte offset
6331 2: smaller UTF-8 offset
6332 3: corresponding byte offset
6334 Unused cache pairs have the value 0, 0.
6335 Keeping the cache "backwards" means that the invariant of
6336 cache[0] >= cache[2] is maintained even with empty slots, which means that
6337 the code that uses it doesn't need to worry if only 1 entry has actually
6338 been set to non-zero. It also makes the "position beyond the end of the
6339 cache" logic much simpler, as the first slot is always the one to start
6343 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6344 const STRLEN utf8, const STRLEN blen)
6348 PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6353 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6354 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6355 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6357 (*mgp)->mg_len = -1;
6361 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6362 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6363 (*mgp)->mg_ptr = (char *) cache;
6367 if (PL_utf8cache < 0 && SvPOKp(sv)) {
6368 /* SvPOKp() because it's possible that sv has string overloading, and
6369 therefore is a reference, hence SvPVX() is actually a pointer.
6370 This cures the (very real) symptoms of RT 69422, but I'm not actually
6371 sure whether we should even be caching the results of UTF-8
6372 operations on overloading, given that nothing stops overloading
6373 returning a different value every time it's called. */
6374 const U8 *start = (const U8 *) SvPVX_const(sv);
6375 const STRLEN realutf8 = utf8_length(start, start + byte);
6377 if (realutf8 != utf8) {
6378 /* Need to turn the assertions off otherwise we may recurse
6379 infinitely while printing error messages. */
6380 SAVEI8(PL_utf8cache);
6382 Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
6383 " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
6387 /* Cache is held with the later position first, to simplify the code
6388 that deals with unbounded ends. */
6390 ASSERT_UTF8_CACHE(cache);
6391 if (cache[1] == 0) {
6392 /* Cache is totally empty */
6395 } else if (cache[3] == 0) {
6396 if (byte > cache[1]) {
6397 /* New one is larger, so goes first. */
6398 cache[2] = cache[0];
6399 cache[3] = cache[1];
6407 #define THREEWAY_SQUARE(a,b,c,d) \
6408 ((float)((d) - (c))) * ((float)((d) - (c))) \
6409 + ((float)((c) - (b))) * ((float)((c) - (b))) \
6410 + ((float)((b) - (a))) * ((float)((b) - (a)))
6412 /* Cache has 2 slots in use, and we know three potential pairs.
6413 Keep the two that give the lowest RMS distance. Do the
6414 calcualation in bytes simply because we always know the byte
6415 length. squareroot has the same ordering as the positive value,
6416 so don't bother with the actual square root. */
6417 const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6418 if (byte > cache[1]) {
6419 /* New position is after the existing pair of pairs. */
6420 const float keep_earlier
6421 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6422 const float keep_later
6423 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6425 if (keep_later < keep_earlier) {
6426 if (keep_later < existing) {
6427 cache[2] = cache[0];
6428 cache[3] = cache[1];
6434 if (keep_earlier < existing) {
6440 else if (byte > cache[3]) {
6441 /* New position is between the existing pair of pairs. */
6442 const float keep_earlier
6443 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6444 const float keep_later
6445 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6447 if (keep_later < keep_earlier) {
6448 if (keep_later < existing) {
6454 if (keep_earlier < existing) {
6461 /* New position is before the existing pair of pairs. */
6462 const float keep_earlier
6463 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6464 const float keep_later
6465 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6467 if (keep_later < keep_earlier) {
6468 if (keep_later < existing) {
6474 if (keep_earlier < existing) {
6475 cache[0] = cache[2];
6476 cache[1] = cache[3];
6483 ASSERT_UTF8_CACHE(cache);
6486 /* We already know all of the way, now we may be able to walk back. The same
6487 assumption is made as in S_sv_pos_u2b_midway(), namely that walking
6488 backward is half the speed of walking forward. */
6490 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
6491 const U8 *end, STRLEN endu)
6493 const STRLEN forw = target - s;
6494 STRLEN backw = end - target;
6496 PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
6498 if (forw < 2 * backw) {
6499 return utf8_length(s, target);
6502 while (end > target) {
6504 while (UTF8_IS_CONTINUATION(*end)) {
6513 =for apidoc sv_pos_b2u
6515 Converts the value pointed to by offsetp from a count of bytes from the
6516 start of the string, to a count of the equivalent number of UTF-8 chars.
6517 Handles magic and type coercion.
6523 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6524 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6529 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
6532 const STRLEN byte = *offsetp;
6533 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
6539 PERL_ARGS_ASSERT_SV_POS_B2U;
6544 s = (const U8*)SvPV_const(sv, blen);
6547 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6553 && SvTYPE(sv) >= SVt_PVMG
6554 && (mg = mg_find(sv, PERL_MAGIC_utf8)))
6557 STRLEN * const cache = (STRLEN *) mg->mg_ptr;
6558 if (cache[1] == byte) {
6559 /* An exact match. */
6560 *offsetp = cache[0];
6563 if (cache[3] == byte) {
6564 /* An exact match. */
6565 *offsetp = cache[2];
6569 if (cache[1] < byte) {
6570 /* We already know part of the way. */
6571 if (mg->mg_len != -1) {
6572 /* Actually, we know the end too. */
6574 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
6575 s + blen, mg->mg_len - cache[0]);
6577 len = cache[0] + utf8_length(s + cache[1], send);
6580 else if (cache[3] < byte) {
6581 /* We're between the two cached pairs, so we do the calculation
6582 offset by the byte/utf-8 positions for the earlier pair,
6583 then add the utf-8 characters from the string start to
6585 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
6586 s + cache[1], cache[0] - cache[2])
6590 else { /* cache[3] > byte */
6591 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
6595 ASSERT_UTF8_CACHE(cache);
6597 } else if (mg->mg_len != -1) {
6598 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
6602 if (!found || PL_utf8cache < 0) {
6603 const STRLEN real_len = utf8_length(s, send);
6605 if (found && PL_utf8cache < 0) {
6606 if (len != real_len) {
6607 /* Need to turn the assertions off otherwise we may recurse
6608 infinitely while printing error messages. */
6609 SAVEI8(PL_utf8cache);
6611 Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
6612 " real %"UVuf" for %"SVf,
6613 (UV) len, (UV) real_len, SVfARG(sv));
6621 utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
6627 Returns a boolean indicating whether the strings in the two SVs are
6628 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6629 coerce its args to strings if necessary.
6635 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6644 SV* svrecode = NULL;
6651 /* if pv1 and pv2 are the same, second SvPV_const call may
6652 * invalidate pv1, so we may need to make a copy */
6653 if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
6654 pv1 = SvPV_const(sv1, cur1);
6655 sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
6657 pv1 = SvPV_const(sv1, cur1);
6665 pv2 = SvPV_const(sv2, cur2);
6667 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6668 /* Differing utf8ness.
6669 * Do not UTF8size the comparands as a side-effect. */
6672 svrecode = newSVpvn(pv2, cur2);
6673 sv_recode_to_utf8(svrecode, PL_encoding);
6674 pv2 = SvPV_const(svrecode, cur2);
6677 svrecode = newSVpvn(pv1, cur1);
6678 sv_recode_to_utf8(svrecode, PL_encoding);
6679 pv1 = SvPV_const(svrecode, cur1);
6681 /* Now both are in UTF-8. */
6683 SvREFCNT_dec(svrecode);
6688 bool is_utf8 = TRUE;
6691 /* sv1 is the UTF-8 one,
6692 * if is equal it must be downgrade-able */
6693 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6699 /* sv2 is the UTF-8 one,
6700 * if is equal it must be downgrade-able */
6701 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6707 /* Downgrade not possible - cannot be eq */
6715 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6717 SvREFCNT_dec(svrecode);
6727 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6728 string in C<sv1> is less than, equal to, or greater than the string in
6729 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6730 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6736 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
6740 const char *pv1, *pv2;
6743 SV *svrecode = NULL;
6750 pv1 = SvPV_const(sv1, cur1);
6757 pv2 = SvPV_const(sv2, cur2);
6759 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6760 /* Differing utf8ness.
6761 * Do not UTF8size the comparands as a side-effect. */
6764 svrecode = newSVpvn(pv2, cur2);
6765 sv_recode_to_utf8(svrecode, PL_encoding);
6766 pv2 = SvPV_const(svrecode, cur2);
6769 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6774 svrecode = newSVpvn(pv1, cur1);
6775 sv_recode_to_utf8(svrecode, PL_encoding);
6776 pv1 = SvPV_const(svrecode, cur1);
6779 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6785 cmp = cur2 ? -1 : 0;
6789 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6792 cmp = retval < 0 ? -1 : 1;
6793 } else if (cur1 == cur2) {
6796 cmp = cur1 < cur2 ? -1 : 1;
6800 SvREFCNT_dec(svrecode);
6808 =for apidoc sv_cmp_locale
6810 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6811 'use bytes' aware, handles get magic, and will coerce its args to strings
6812 if necessary. See also C<sv_cmp>.
6818 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
6821 #ifdef USE_LOCALE_COLLATE
6827 if (PL_collation_standard)
6831 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6833 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6835 if (!pv1 || !len1) {
6846 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6849 return retval < 0 ? -1 : 1;
6852 * When the result of collation is equality, that doesn't mean
6853 * that there are no differences -- some locales exclude some
6854 * characters from consideration. So to avoid false equalities,
6855 * we use the raw string as a tiebreaker.
6861 #endif /* USE_LOCALE_COLLATE */
6863 return sv_cmp(sv1, sv2);
6867 #ifdef USE_LOCALE_COLLATE
6870 =for apidoc sv_collxfrm
6872 Add Collate Transform magic to an SV if it doesn't already have it.
6874 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6875 scalar data of the variable, but transformed to such a format that a normal
6876 memory comparison can be used to compare the data according to the locale
6883 Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
6888 PERL_ARGS_ASSERT_SV_COLLXFRM;
6890 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6891 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6897 Safefree(mg->mg_ptr);
6898 s = SvPV_const(sv, len);
6899 if ((xf = mem_collxfrm(s, len, &xlen))) {
6901 #ifdef PERL_OLD_COPY_ON_WRITE
6903 sv_force_normal_flags(sv, 0);
6905 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
6919 if (mg && mg->mg_ptr) {
6921 return mg->mg_ptr + sizeof(PL_collation_ix);
6929 #endif /* USE_LOCALE_COLLATE */
6934 Get a line from the filehandle and store it into the SV, optionally
6935 appending to the currently-stored string.
6941 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
6946 register STDCHAR rslast;
6947 register STDCHAR *bp;
6952 PERL_ARGS_ASSERT_SV_GETS;
6954 if (SvTHINKFIRST(sv))
6955 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6956 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6958 However, perlbench says it's slower, because the existing swipe code
6959 is faster than copy on write.
6960 Swings and roundabouts. */
6961 SvUPGRADE(sv, SVt_PV);
6966 if (PerlIO_isutf8(fp)) {
6968 sv_utf8_upgrade_nomg(sv);
6969 sv_pos_u2b(sv,&append,0);
6971 } else if (SvUTF8(sv)) {
6972 SV * const tsv = newSV(0);
6973 sv_gets(tsv, fp, 0);
6974 sv_utf8_upgrade_nomg(tsv);
6975 SvCUR_set(sv,append);
6978 goto return_string_or_null;
6983 if (PerlIO_isutf8(fp))
6986 if (IN_PERL_COMPILETIME) {
6987 /* we always read code in line mode */
6991 else if (RsSNARF(PL_rs)) {
6992 /* If it is a regular disk file use size from stat() as estimate
6993 of amount we are going to read -- may result in mallocing
6994 more memory than we really need if the layers below reduce
6995 the size we read (e.g. CRLF or a gzip layer).
6998 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6999 const Off_t offset = PerlIO_tell(fp);
7000 if (offset != (Off_t) -1 && st.st_size + append > offset) {
7001 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7007 else if (RsRECORD(PL_rs)) {
7015 /* Grab the size of the record we're getting */
7016 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7017 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7020 /* VMS wants read instead of fread, because fread doesn't respect */
7021 /* RMS record boundaries. This is not necessarily a good thing to be */
7022 /* doing, but we've got no other real choice - except avoid stdio
7023 as implementation - perhaps write a :vms layer ?
7025 fd = PerlIO_fileno(fp);
7026 if (fd == -1) { /* in-memory file from PerlIO::Scalar */
7027 bytesread = PerlIO_read(fp, buffer, recsize);
7030 bytesread = PerlLIO_read(fd, buffer, recsize);
7033 bytesread = PerlIO_read(fp, buffer, recsize);
7037 SvCUR_set(sv, bytesread + append);
7038 buffer[bytesread] = '\0';
7039 goto return_string_or_null;
7041 else if (RsPARA(PL_rs)) {
7047 /* Get $/ i.e. PL_rs into same encoding as stream wants */
7048 if (PerlIO_isutf8(fp)) {
7049 rsptr = SvPVutf8(PL_rs, rslen);
7052 if (SvUTF8(PL_rs)) {
7053 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7054 Perl_croak(aTHX_ "Wide character in $/");
7057 rsptr = SvPV_const(PL_rs, rslen);
7061 rslast = rslen ? rsptr[rslen - 1] : '\0';
7063 if (rspara) { /* have to do this both before and after */
7064 do { /* to make sure file boundaries work right */
7067 i = PerlIO_getc(fp);
7071 PerlIO_ungetc(fp,i);
7077 /* See if we know enough about I/O mechanism to cheat it ! */
7079 /* This used to be #ifdef test - it is made run-time test for ease
7080 of abstracting out stdio interface. One call should be cheap
7081 enough here - and may even be a macro allowing compile
7085 if (PerlIO_fast_gets(fp)) {
7088 * We're going to steal some values from the stdio struct
7089 * and put EVERYTHING in the innermost loop into registers.
7091 register STDCHAR *ptr;
7095 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7096 /* An ungetc()d char is handled separately from the regular
7097 * buffer, so we getc() it back out and stuff it in the buffer.
7099 i = PerlIO_getc(fp);
7100 if (i == EOF) return 0;
7101 *(--((*fp)->_ptr)) = (unsigned char) i;
7105 /* Here is some breathtakingly efficient cheating */
7107 cnt = PerlIO_get_cnt(fp); /* get count into register */
7108 /* make sure we have the room */
7109 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7110 /* Not room for all of it
7111 if we are looking for a separator and room for some
7113 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7114 /* just process what we have room for */
7115 shortbuffered = cnt - SvLEN(sv) + append + 1;
7116 cnt -= shortbuffered;
7120 /* remember that cnt can be negative */
7121 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7126 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
7127 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7128 DEBUG_P(PerlIO_printf(Perl_debug_log,
7129 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7130 DEBUG_P(PerlIO_printf(Perl_debug_log,
7131 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7132 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7133 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7138 while (cnt > 0) { /* this | eat */
7140 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7141 goto thats_all_folks; /* screams | sed :-) */
7145 Copy(ptr, bp, cnt, char); /* this | eat */
7146 bp += cnt; /* screams | dust */
7147 ptr += cnt; /* louder | sed :-) */
7152 if (shortbuffered) { /* oh well, must extend */
7153 cnt = shortbuffered;
7155 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7157 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7158 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7162 DEBUG_P(PerlIO_printf(Perl_debug_log,
7163 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7164 PTR2UV(ptr),(long)cnt));
7165 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7167 DEBUG_P(PerlIO_printf(Perl_debug_log,
7168 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7169 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7170 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7172 /* This used to call 'filbuf' in stdio form, but as that behaves like
7173 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7174 another abstraction. */
7175 i = PerlIO_getc(fp); /* get more characters */
7177 DEBUG_P(PerlIO_printf(Perl_debug_log,
7178 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7179 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7180 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7182 cnt = PerlIO_get_cnt(fp);
7183 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7184 DEBUG_P(PerlIO_printf(Perl_debug_log,
7185 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7187 if (i == EOF) /* all done for ever? */
7188 goto thats_really_all_folks;
7190 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7192 SvGROW(sv, bpx + cnt + 2);
7193 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7195 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7197 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7198 goto thats_all_folks;
7202 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7203 memNE((char*)bp - rslen, rsptr, rslen))
7204 goto screamer; /* go back to the fray */
7205 thats_really_all_folks:
7207 cnt += shortbuffered;
7208 DEBUG_P(PerlIO_printf(Perl_debug_log,
7209 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7210 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7211 DEBUG_P(PerlIO_printf(Perl_debug_log,
7212 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7213 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7214 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7216 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
7217 DEBUG_P(PerlIO_printf(Perl_debug_log,
7218 "Screamer: done, len=%ld, string=|%.*s|\n",
7219 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7223 /*The big, slow, and stupid way. */
7224 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
7225 STDCHAR *buf = NULL;
7226 Newx(buf, 8192, STDCHAR);
7234 register const STDCHAR * const bpe = buf + sizeof(buf);
7236 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7237 ; /* keep reading */
7241 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7242 /* Accomodate broken VAXC compiler, which applies U8 cast to
7243 * both args of ?: operator, causing EOF to change into 255
7246 i = (U8)buf[cnt - 1];
7252 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7254 sv_catpvn(sv, (char *) buf, cnt);
7256 sv_setpvn(sv, (char *) buf, cnt);
7258 if (i != EOF && /* joy */
7260 SvCUR(sv) < rslen ||
7261 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7265 * If we're reading from a TTY and we get a short read,
7266 * indicating that the user hit his EOF character, we need
7267 * to notice it now, because if we try to read from the TTY
7268 * again, the EOF condition will disappear.
7270 * The comparison of cnt to sizeof(buf) is an optimization
7271 * that prevents unnecessary calls to feof().
7275 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7279 #ifdef USE_HEAP_INSTEAD_OF_STACK
7284 if (rspara) { /* have to do this both before and after */
7285 while (i != EOF) { /* to make sure file boundaries work right */
7286 i = PerlIO_getc(fp);
7288 PerlIO_ungetc(fp,i);
7294 return_string_or_null:
7295 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7301 Auto-increment of the value in the SV, doing string to numeric conversion
7302 if necessary. Handles 'get' magic.
7308 Perl_sv_inc(pTHX_ register SV *const sv)
7317 if (SvTHINKFIRST(sv)) {
7319 sv_force_normal_flags(sv, 0);
7320 if (SvREADONLY(sv)) {
7321 if (IN_PERL_RUNTIME)
7322 Perl_croak(aTHX_ "%s", PL_no_modify);
7326 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7328 i = PTR2IV(SvRV(sv));
7333 flags = SvFLAGS(sv);
7334 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7335 /* It's (privately or publicly) a float, but not tested as an
7336 integer, so test it to see. */
7338 flags = SvFLAGS(sv);
7340 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7341 /* It's publicly an integer, or privately an integer-not-float */
7342 #ifdef PERL_PRESERVE_IVUV
7346 if (SvUVX(sv) == UV_MAX)
7347 sv_setnv(sv, UV_MAX_P1);
7349 (void)SvIOK_only_UV(sv);
7350 SvUV_set(sv, SvUVX(sv) + 1);
7352 if (SvIVX(sv) == IV_MAX)
7353 sv_setuv(sv, (UV)IV_MAX + 1);
7355 (void)SvIOK_only(sv);
7356 SvIV_set(sv, SvIVX(sv) + 1);
7361 if (flags & SVp_NOK) {
7362 const NV was = SvNVX(sv);
7363 if (NV_OVERFLOWS_INTEGERS_AT &&
7364 was >= NV_OVERFLOWS_INTEGERS_AT) {
7365 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7366 "Lost precision when incrementing %" NVff " by 1",
7369 (void)SvNOK_only(sv);
7370 SvNV_set(sv, was + 1.0);
7374 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7375 if ((flags & SVTYPEMASK) < SVt_PVIV)
7376 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
7377 (void)SvIOK_only(sv);
7382 while (isALPHA(*d)) d++;
7383 while (isDIGIT(*d)) d++;
7384 if (d < SvEND(sv)) {
7385 #ifdef PERL_PRESERVE_IVUV
7386 /* Got to punt this as an integer if needs be, but we don't issue
7387 warnings. Probably ought to make the sv_iv_please() that does
7388 the conversion if possible, and silently. */
7389 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7390 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7391 /* Need to try really hard to see if it's an integer.
7392 9.22337203685478e+18 is an integer.
7393 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7394 so $a="9.22337203685478e+18"; $a+0; $a++
7395 needs to be the same as $a="9.22337203685478e+18"; $a++
7402 /* sv_2iv *should* have made this an NV */
7403 if (flags & SVp_NOK) {
7404 (void)SvNOK_only(sv);
7405 SvNV_set(sv, SvNVX(sv) + 1.0);
7408 /* I don't think we can get here. Maybe I should assert this
7409 And if we do get here I suspect that sv_setnv will croak. NWC
7411 #if defined(USE_LONG_DOUBLE)
7412 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",
7413 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7415 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7416 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7419 #endif /* PERL_PRESERVE_IVUV */
7420 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7424 while (d >= SvPVX_const(sv)) {
7432 /* MKS: The original code here died if letters weren't consecutive.
7433 * at least it didn't have to worry about non-C locales. The
7434 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7435 * arranged in order (although not consecutively) and that only
7436 * [A-Za-z] are accepted by isALPHA in the C locale.
7438 if (*d != 'z' && *d != 'Z') {
7439 do { ++*d; } while (!isALPHA(*d));
7442 *(d--) -= 'z' - 'a';
7447 *(d--) -= 'z' - 'a' + 1;
7451 /* oh,oh, the number grew */
7452 SvGROW(sv, SvCUR(sv) + 2);
7453 SvCUR_set(sv, SvCUR(sv) + 1);
7454 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7465 Auto-decrement of the value in the SV, doing string to numeric conversion
7466 if necessary. Handles 'get' magic.
7472 Perl_sv_dec(pTHX_ register SV *const sv)
7480 if (SvTHINKFIRST(sv)) {
7482 sv_force_normal_flags(sv, 0);
7483 if (SvREADONLY(sv)) {
7484 if (IN_PERL_RUNTIME)
7485 Perl_croak(aTHX_ "%s", PL_no_modify);
7489 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7491 i = PTR2IV(SvRV(sv));
7496 /* Unlike sv_inc we don't have to worry about string-never-numbers
7497 and keeping them magic. But we mustn't warn on punting */
7498 flags = SvFLAGS(sv);
7499 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7500 /* It's publicly an integer, or privately an integer-not-float */
7501 #ifdef PERL_PRESERVE_IVUV
7505 if (SvUVX(sv) == 0) {
7506 (void)SvIOK_only(sv);
7510 (void)SvIOK_only_UV(sv);
7511 SvUV_set(sv, SvUVX(sv) - 1);
7514 if (SvIVX(sv) == IV_MIN) {
7515 sv_setnv(sv, (NV)IV_MIN);
7519 (void)SvIOK_only(sv);
7520 SvIV_set(sv, SvIVX(sv) - 1);
7525 if (flags & SVp_NOK) {
7528 const NV was = SvNVX(sv);
7529 if (NV_OVERFLOWS_INTEGERS_AT &&
7530 was <= -NV_OVERFLOWS_INTEGERS_AT) {
7531 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7532 "Lost precision when decrementing %" NVff " by 1",
7535 (void)SvNOK_only(sv);
7536 SvNV_set(sv, was - 1.0);
7540 if (!(flags & SVp_POK)) {
7541 if ((flags & SVTYPEMASK) < SVt_PVIV)
7542 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
7544 (void)SvIOK_only(sv);
7547 #ifdef PERL_PRESERVE_IVUV
7549 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7550 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7551 /* Need to try really hard to see if it's an integer.
7552 9.22337203685478e+18 is an integer.
7553 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7554 so $a="9.22337203685478e+18"; $a+0; $a--
7555 needs to be the same as $a="9.22337203685478e+18"; $a--
7562 /* sv_2iv *should* have made this an NV */
7563 if (flags & SVp_NOK) {
7564 (void)SvNOK_only(sv);
7565 SvNV_set(sv, SvNVX(sv) - 1.0);
7568 /* I don't think we can get here. Maybe I should assert this
7569 And if we do get here I suspect that sv_setnv will croak. NWC
7571 #if defined(USE_LONG_DOUBLE)
7572 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",
7573 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7575 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7576 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7580 #endif /* PERL_PRESERVE_IVUV */
7581 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
7584 /* this define is used to eliminate a chunk of duplicated but shared logic
7585 * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
7586 * used anywhere but here - yves
7588 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
7591 PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
7595 =for apidoc sv_mortalcopy
7597 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7598 The new SV is marked as mortal. It will be destroyed "soon", either by an
7599 explicit call to FREETMPS, or by an implicit call at places such as
7600 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7605 /* Make a string that will exist for the duration of the expression
7606 * evaluation. Actually, it may have to last longer than that, but
7607 * hopefully we won't free it until it has been assigned to a
7608 * permanent location. */
7611 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
7617 sv_setsv(sv,oldstr);
7618 PUSH_EXTEND_MORTAL__SV_C(sv);
7624 =for apidoc sv_newmortal
7626 Creates a new null SV which is mortal. The reference count of the SV is
7627 set to 1. It will be destroyed "soon", either by an explicit call to
7628 FREETMPS, or by an implicit call at places such as statement boundaries.
7629 See also C<sv_mortalcopy> and C<sv_2mortal>.
7635 Perl_sv_newmortal(pTHX)
7641 SvFLAGS(sv) = SVs_TEMP;
7642 PUSH_EXTEND_MORTAL__SV_C(sv);
7648 =for apidoc newSVpvn_flags
7650 Creates a new SV and copies a string into it. The reference count for the
7651 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7652 string. You are responsible for ensuring that the source string is at least
7653 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7654 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
7655 If C<SVs_TEMP> is set, then C<sv2mortal()> is called on the result before
7656 returning. If C<SVf_UTF8> is set, C<s> is considered to be in UTF-8 and the
7657 C<SVf_UTF8> flag will be set on the new SV.
7658 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
7660 #define newSVpvn_utf8(s, len, u) \
7661 newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
7667 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
7672 /* All the flags we don't support must be zero.
7673 And we're new code so I'm going to assert this from the start. */
7674 assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
7676 sv_setpvn(sv,s,len);
7678 /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal()
7679 * and do what it does outselves here.
7680 * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags
7681 * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which
7682 * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we
7683 * eleminate quite a few steps than it looks - Yves (explaining patch by gfx)
7686 SvFLAGS(sv) |= flags;
7688 if(flags & SVs_TEMP){
7689 PUSH_EXTEND_MORTAL__SV_C(sv);
7696 =for apidoc sv_2mortal
7698 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7699 by an explicit call to FREETMPS, or by an implicit call at places such as
7700 statement boundaries. SvTEMP() is turned on which means that the SV's
7701 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7702 and C<sv_mortalcopy>.
7708 Perl_sv_2mortal(pTHX_ register SV *const sv)
7713 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7715 PUSH_EXTEND_MORTAL__SV_C(sv);
7723 Creates a new SV and copies a string into it. The reference count for the
7724 SV is set to 1. If C<len> is zero, Perl will compute the length using
7725 strlen(). For efficiency, consider using C<newSVpvn> instead.
7731 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
7737 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
7742 =for apidoc newSVpvn
7744 Creates a new SV and copies a string into it. The reference count for the
7745 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7746 string. You are responsible for ensuring that the source string is at least
7747 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7753 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
7759 sv_setpvn(sv,s,len);
7764 =for apidoc newSVhek
7766 Creates a new SV from the hash key structure. It will generate scalars that
7767 point to the shared string table where possible. Returns a new (undefined)
7768 SV if the hek is NULL.
7774 Perl_newSVhek(pTHX_ const HEK *const hek)
7784 if (HEK_LEN(hek) == HEf_SVKEY) {
7785 return newSVsv(*(SV**)HEK_KEY(hek));
7787 const int flags = HEK_FLAGS(hek);
7788 if (flags & HVhek_WASUTF8) {
7790 Andreas would like keys he put in as utf8 to come back as utf8
7792 STRLEN utf8_len = HEK_LEN(hek);
7793 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7794 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7797 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7799 } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
7800 /* We don't have a pointer to the hv, so we have to replicate the
7801 flag into every HEK. This hv is using custom a hasing
7802 algorithm. Hence we can't return a shared string scalar, as
7803 that would contain the (wrong) hash value, and might get passed
7804 into an hv routine with a regular hash.
7805 Similarly, a hash that isn't using shared hash keys has to have
7806 the flag in every key so that we know not to try to call
7807 share_hek_kek on it. */
7809 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7814 /* This will be overwhelminly the most common case. */
7816 /* Inline most of newSVpvn_share(), because share_hek_hek() is far
7817 more efficient than sharepvn(). */
7821 sv_upgrade(sv, SVt_PV);
7822 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
7823 SvCUR_set(sv, HEK_LEN(hek));
7836 =for apidoc newSVpvn_share
7838 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7839 table. If the string does not already exist in the table, it is created
7840 first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
7841 value is used; otherwise the hash is computed. The string's hash can be later
7842 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
7843 that as the string table is used for shared hash keys these strings will have
7844 SvPVX_const == HeKEY and hash lookup will avoid string compare.
7850 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7854 bool is_utf8 = FALSE;
7855 const char *const orig_src = src;
7858 STRLEN tmplen = -len;
7860 /* See the note in hv.c:hv_fetch() --jhi */
7861 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7865 PERL_HASH(hash, src, len);
7867 /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
7868 changes here, update it there too. */
7869 sv_upgrade(sv, SVt_PV);
7870 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7878 if (src != orig_src)
7884 #if defined(PERL_IMPLICIT_CONTEXT)
7886 /* pTHX_ magic can't cope with varargs, so this is a no-context
7887 * version of the main function, (which may itself be aliased to us).
7888 * Don't access this version directly.
7892 Perl_newSVpvf_nocontext(const char *const pat, ...)
7898 PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
7900 va_start(args, pat);
7901 sv = vnewSVpvf(pat, &args);
7908 =for apidoc newSVpvf
7910 Creates a new SV and initializes it with the string formatted like
7917 Perl_newSVpvf(pTHX_ const char *const pat, ...)
7922 PERL_ARGS_ASSERT_NEWSVPVF;
7924 va_start(args, pat);
7925 sv = vnewSVpvf(pat, &args);
7930 /* backend for newSVpvf() and newSVpvf_nocontext() */
7933 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
7938 PERL_ARGS_ASSERT_VNEWSVPVF;
7941 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7948 Creates a new SV and copies a floating point value into it.
7949 The reference count for the SV is set to 1.
7955 Perl_newSVnv(pTHX_ const NV n)
7968 Creates a new SV and copies an integer into it. The reference count for the
7975 Perl_newSViv(pTHX_ const IV i)
7988 Creates a new SV and copies an unsigned integer into it.
7989 The reference count for the SV is set to 1.
7995 Perl_newSVuv(pTHX_ const UV u)
8006 =for apidoc newSV_type
8008 Creates a new SV, of the type specified. The reference count for the new SV
8015 Perl_newSV_type(pTHX_ const svtype type)
8020 sv_upgrade(sv, type);
8025 =for apidoc newRV_noinc
8027 Creates an RV wrapper for an SV. The reference count for the original
8028 SV is B<not> incremented.
8034 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
8037 register SV *sv = newSV_type(SVt_IV);
8039 PERL_ARGS_ASSERT_NEWRV_NOINC;
8042 SvRV_set(sv, tmpRef);
8047 /* newRV_inc is the official function name to use now.
8048 * newRV_inc is in fact #defined to newRV in sv.h
8052 Perl_newRV(pTHX_ SV *const sv)
8056 PERL_ARGS_ASSERT_NEWRV;
8058 return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
8064 Creates a new SV which is an exact duplicate of the original SV.
8071 Perl_newSVsv(pTHX_ register SV *const old)
8078 if (SvTYPE(old) == SVTYPEMASK) {
8079 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
8083 /* SV_GMAGIC is the default for sv_setv()
8084 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
8085 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
8086 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
8091 =for apidoc sv_reset
8093 Underlying implementation for the C<reset> Perl function.
8094 Note that the perl-level function is vaguely deprecated.
8100 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
8103 char todo[PERL_UCHAR_MAX+1];
8105 PERL_ARGS_ASSERT_SV_RESET;
8110 if (!*s) { /* reset ?? searches */
8111 MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
8113 const U32 count = mg->mg_len / sizeof(PMOP**);
8114 PMOP **pmp = (PMOP**) mg->mg_ptr;
8115 PMOP *const *const end = pmp + count;
8119 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
8121 (*pmp)->op_pmflags &= ~PMf_USED;
8129 /* reset variables */
8131 if (!HvARRAY(stash))
8134 Zero(todo, 256, char);
8137 I32 i = (unsigned char)*s;
8141 max = (unsigned char)*s++;
8142 for ( ; i <= max; i++) {
8145 for (i = 0; i <= (I32) HvMAX(stash); i++) {
8147 for (entry = HvARRAY(stash)[i];
8149 entry = HeNEXT(entry))
8154 if (!todo[(U8)*HeKEY(entry)])
8156 gv = MUTABLE_GV(HeVAL(entry));
8159 if (SvTHINKFIRST(sv)) {
8160 if (!SvREADONLY(sv) && SvROK(sv))
8162 /* XXX Is this continue a bug? Why should THINKFIRST
8163 exempt us from resetting arrays and hashes? */
8167 if (SvTYPE(sv) >= SVt_PV) {
8169 if (SvPVX_const(sv) != NULL)
8177 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8179 Perl_die(aTHX_ "Can't reset %%ENV on this system");
8182 # if defined(USE_ENVIRON_ARRAY)
8185 # endif /* USE_ENVIRON_ARRAY */
8196 Using various gambits, try to get an IO from an SV: the IO slot if its a
8197 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8198 named after the PV if we're a string.
8204 Perl_sv_2io(pTHX_ SV *const sv)
8209 PERL_ARGS_ASSERT_SV_2IO;
8211 switch (SvTYPE(sv)) {
8213 io = MUTABLE_IO(sv);
8216 if (isGV_with_GP(sv)) {
8217 gv = MUTABLE_GV(sv);
8220 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8226 Perl_croak(aTHX_ PL_no_usym, "filehandle");
8228 return sv_2io(SvRV(sv));
8229 gv = gv_fetchsv(sv, 0, SVt_PVIO);
8235 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
8244 Using various gambits, try to get a CV from an SV; in addition, try if
8245 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8246 The flags in C<lref> are passed to gv_fetchsv.
8252 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8258 PERL_ARGS_ASSERT_SV_2CV;
8265 switch (SvTYPE(sv)) {
8269 return MUTABLE_CV(sv);
8276 if (isGV_with_GP(sv)) {
8277 gv = MUTABLE_GV(sv);
8286 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
8288 tryAMAGICunDEREF(to_cv);
8291 if (SvTYPE(sv) == SVt_PVCV) {
8292 cv = MUTABLE_CV(sv);
8297 else if(isGV_with_GP(sv))
8298 gv = MUTABLE_GV(sv);
8300 Perl_croak(aTHX_ "Not a subroutine reference");
8302 else if (isGV_with_GP(sv)) {
8304 gv = MUTABLE_GV(sv);
8307 gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
8313 /* Some flags to gv_fetchsv mean don't really create the GV */
8314 if (!isGV_with_GP(gv)) {
8320 if (lref && !GvCVu(gv)) {
8324 gv_efullname3(tmpsv, gv, NULL);
8325 /* XXX this is probably not what they think they're getting.
8326 * It has the same effect as "sub name;", i.e. just a forward
8328 newSUB(start_subparse(FALSE, 0),
8329 newSVOP(OP_CONST, 0, tmpsv),
8333 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8334 SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8343 Returns true if the SV has a true value by Perl's rules.
8344 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8345 instead use an in-line version.
8351 Perl_sv_true(pTHX_ register SV *const sv)
8356 register const XPV* const tXpv = (XPV*)SvANY(sv);
8358 (tXpv->xpv_cur > 1 ||
8359 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
8366 return SvIVX(sv) != 0;
8369 return SvNVX(sv) != 0.0;
8371 return sv_2bool(sv);
8377 =for apidoc sv_pvn_force
8379 Get a sensible string out of the SV somehow.
8380 A private implementation of the C<SvPV_force> macro for compilers which
8381 can't cope with complex macro expressions. Always use the macro instead.
8383 =for apidoc sv_pvn_force_flags
8385 Get a sensible string out of the SV somehow.
8386 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8387 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8388 implemented in terms of this function.
8389 You normally want to use the various wrapper macros instead: see
8390 C<SvPV_force> and C<SvPV_force_nomg>
8396 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
8400 PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
8402 if (SvTHINKFIRST(sv) && !SvROK(sv))
8403 sv_force_normal_flags(sv, 0);
8413 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8414 const char * const ref = sv_reftype(sv,0);
8416 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8417 ref, OP_DESC(PL_op));
8419 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
8421 if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
8422 || isGV_with_GP(sv))
8423 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8425 s = sv_2pv_flags(sv, &len, flags);
8429 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
8432 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8433 SvGROW(sv, len + 1);
8434 Move(s,SvPVX(sv),len,char);
8436 SvPVX(sv)[len] = '\0';
8439 SvPOK_on(sv); /* validate pointer */
8441 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8442 PTR2UV(sv),SvPVX_const(sv)));
8445 return SvPVX_mutable(sv);
8449 =for apidoc sv_pvbyten_force
8451 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
8457 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
8459 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
8461 sv_pvn_force(sv,lp);
8462 sv_utf8_downgrade(sv,0);
8468 =for apidoc sv_pvutf8n_force
8470 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
8476 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
8478 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
8480 sv_pvn_force(sv,lp);
8481 sv_utf8_upgrade(sv);
8487 =for apidoc sv_reftype
8489 Returns a string describing what the SV is a reference to.
8495 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
8497 PERL_ARGS_ASSERT_SV_REFTYPE;
8499 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8500 inside return suggests a const propagation bug in g++. */
8501 if (ob && SvOBJECT(sv)) {
8502 char * const name = HvNAME_get(SvSTASH(sv));
8503 return name ? name : (char *) "__ANON__";
8506 switch (SvTYPE(sv)) {
8521 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
8522 /* tied lvalues should appear to be
8523 * scalars for backwards compatitbility */
8524 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8525 ? "SCALAR" : "LVALUE");
8526 case SVt_PVAV: return "ARRAY";
8527 case SVt_PVHV: return "HASH";
8528 case SVt_PVCV: return "CODE";
8529 case SVt_PVGV: return (char *) (isGV_with_GP(sv)
8530 ? "GLOB" : "SCALAR");
8531 case SVt_PVFM: return "FORMAT";
8532 case SVt_PVIO: return "IO";
8533 case SVt_BIND: return "BIND";
8534 case SVt_REGEXP: return "REGEXP";
8535 default: return "UNKNOWN";
8541 =for apidoc sv_isobject
8543 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8544 object. If the SV is not an RV, or if the object is not blessed, then this
8551 Perl_sv_isobject(pTHX_ SV *sv)
8567 Returns a boolean indicating whether the SV is blessed into the specified
8568 class. This does not check for subtypes; use C<sv_derived_from> to verify
8569 an inheritance relationship.
8575 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
8579 PERL_ARGS_ASSERT_SV_ISA;
8589 hvname = HvNAME_get(SvSTASH(sv));
8593 return strEQ(hvname, name);
8599 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8600 it will be upgraded to one. If C<classname> is non-null then the new SV will
8601 be blessed in the specified package. The new SV is returned and its
8602 reference count is 1.
8608 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
8613 PERL_ARGS_ASSERT_NEWSVRV;
8617 SV_CHECK_THINKFIRST_COW_DROP(rv);
8618 (void)SvAMAGIC_off(rv);
8620 if (SvTYPE(rv) >= SVt_PVMG) {
8621 const U32 refcnt = SvREFCNT(rv);
8625 SvREFCNT(rv) = refcnt;
8627 sv_upgrade(rv, SVt_IV);
8628 } else if (SvROK(rv)) {
8629 SvREFCNT_dec(SvRV(rv));
8631 prepare_SV_for_RV(rv);
8639 HV* const stash = gv_stashpv(classname, GV_ADD);
8640 (void)sv_bless(rv, stash);
8646 =for apidoc sv_setref_pv
8648 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8649 argument will be upgraded to an RV. That RV will be modified to point to
8650 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8651 into the SV. The C<classname> argument indicates the package for the
8652 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8653 will have a reference count of 1, and the RV will be returned.
8655 Do not use with other Perl types such as HV, AV, SV, CV, because those
8656 objects will become corrupted by the pointer copy process.
8658 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8664 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
8668 PERL_ARGS_ASSERT_SV_SETREF_PV;
8671 sv_setsv(rv, &PL_sv_undef);
8675 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8680 =for apidoc sv_setref_iv
8682 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8683 argument will be upgraded to an RV. That RV will be modified to point to
8684 the new SV. The C<classname> argument indicates the package for the
8685 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8686 will have a reference count of 1, and the RV will be returned.
8692 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
8694 PERL_ARGS_ASSERT_SV_SETREF_IV;
8696 sv_setiv(newSVrv(rv,classname), iv);
8701 =for apidoc sv_setref_uv
8703 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8704 argument will be upgraded to an RV. That RV will be modified to point to
8705 the new SV. The C<classname> argument indicates the package for the
8706 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8707 will have a reference count of 1, and the RV will be returned.
8713 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
8715 PERL_ARGS_ASSERT_SV_SETREF_UV;
8717 sv_setuv(newSVrv(rv,classname), uv);
8722 =for apidoc sv_setref_nv
8724 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8725 argument will be upgraded to an RV. That RV will be modified to point to
8726 the new SV. The C<classname> argument indicates the package for the
8727 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8728 will have a reference count of 1, and the RV will be returned.
8734 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
8736 PERL_ARGS_ASSERT_SV_SETREF_NV;
8738 sv_setnv(newSVrv(rv,classname), nv);
8743 =for apidoc sv_setref_pvn
8745 Copies a string into a new SV, optionally blessing the SV. The length of the
8746 string must be specified with C<n>. The C<rv> argument will be upgraded to
8747 an RV. That RV will be modified to point to the new SV. The C<classname>
8748 argument indicates the package for the blessing. Set C<classname> to
8749 C<NULL> to avoid the blessing. The new SV will have a reference count
8750 of 1, and the RV will be returned.
8752 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8758 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
8759 const char *const pv, const STRLEN n)
8761 PERL_ARGS_ASSERT_SV_SETREF_PVN;
8763 sv_setpvn(newSVrv(rv,classname), pv, n);
8768 =for apidoc sv_bless
8770 Blesses an SV into a specified package. The SV must be an RV. The package
8771 must be designated by its stash (see C<gv_stashpv()>). The reference count
8772 of the SV is unaffected.
8778 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
8783 PERL_ARGS_ASSERT_SV_BLESS;
8786 Perl_croak(aTHX_ "Can't bless non-reference value");
8788 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8789 if (SvIsCOW(tmpRef))
8790 sv_force_normal_flags(tmpRef, 0);
8791 if (SvREADONLY(tmpRef))
8792 Perl_croak(aTHX_ "%s", PL_no_modify);
8793 if (SvOBJECT(tmpRef)) {
8794 if (SvTYPE(tmpRef) != SVt_PVIO)
8796 SvREFCNT_dec(SvSTASH(tmpRef));
8799 SvOBJECT_on(tmpRef);
8800 if (SvTYPE(tmpRef) != SVt_PVIO)
8802 SvUPGRADE(tmpRef, SVt_PVMG);
8803 SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
8808 (void)SvAMAGIC_off(sv);
8810 if(SvSMAGICAL(tmpRef))
8811 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8819 /* Downgrades a PVGV to a PVMG.
8823 S_sv_unglob(pTHX_ SV *const sv)
8828 SV * const temp = sv_newmortal();
8830 PERL_ARGS_ASSERT_SV_UNGLOB;
8832 assert(SvTYPE(sv) == SVt_PVGV);
8834 gv_efullname3(temp, MUTABLE_GV(sv), "*");
8837 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
8838 && HvNAME_get(stash))
8839 mro_method_changed_in(stash);
8840 gp_free(MUTABLE_GV(sv));
8843 sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
8847 if (GvNAME_HEK(sv)) {
8848 unshare_hek(GvNAME_HEK(sv));
8850 isGV_with_GP_off(sv);
8852 /* need to keep SvANY(sv) in the right arena */
8853 xpvmg = new_XPVMG();
8854 StructCopy(SvANY(sv), xpvmg, XPVMG);
8855 del_XPVGV(SvANY(sv));
8858 SvFLAGS(sv) &= ~SVTYPEMASK;
8859 SvFLAGS(sv) |= SVt_PVMG;
8861 /* Intentionally not calling any local SET magic, as this isn't so much a
8862 set operation as merely an internal storage change. */
8863 sv_setsv_flags(sv, temp, 0);
8867 =for apidoc sv_unref_flags
8869 Unsets the RV status of the SV, and decrements the reference count of
8870 whatever was being referenced by the RV. This can almost be thought of
8871 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8872 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8873 (otherwise the decrementing is conditional on the reference count being
8874 different from one or the reference being a readonly SV).
8881 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
8883 SV* const target = SvRV(ref);
8885 PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
8887 if (SvWEAKREF(ref)) {
8888 sv_del_backref(target, ref);
8890 SvRV_set(ref, NULL);
8893 SvRV_set(ref, NULL);
8895 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8896 assigned to as BEGIN {$a = \"Foo"} will fail. */
8897 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8898 SvREFCNT_dec(target);
8899 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8900 sv_2mortal(target); /* Schedule for freeing later */
8904 =for apidoc sv_untaint
8906 Untaint an SV. Use C<SvTAINTED_off> instead.
8911 Perl_sv_untaint(pTHX_ SV *const sv)
8913 PERL_ARGS_ASSERT_SV_UNTAINT;
8915 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8916 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8923 =for apidoc sv_tainted
8925 Test an SV for taintedness. Use C<SvTAINTED> instead.
8930 Perl_sv_tainted(pTHX_ SV *const sv)
8932 PERL_ARGS_ASSERT_SV_TAINTED;
8934 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8935 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8936 if (mg && (mg->mg_len & 1) )
8943 =for apidoc sv_setpviv
8945 Copies an integer into the given SV, also updating its string value.
8946 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8952 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
8954 char buf[TYPE_CHARS(UV)];
8956 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8958 PERL_ARGS_ASSERT_SV_SETPVIV;
8960 sv_setpvn(sv, ptr, ebuf - ptr);
8964 =for apidoc sv_setpviv_mg
8966 Like C<sv_setpviv>, but also handles 'set' magic.
8972 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
8974 PERL_ARGS_ASSERT_SV_SETPVIV_MG;
8980 #if defined(PERL_IMPLICIT_CONTEXT)
8982 /* pTHX_ magic can't cope with varargs, so this is a no-context
8983 * version of the main function, (which may itself be aliased to us).
8984 * Don't access this version directly.
8988 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
8993 PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
8995 va_start(args, pat);
8996 sv_vsetpvf(sv, pat, &args);
9000 /* pTHX_ magic can't cope with varargs, so this is a no-context
9001 * version of the main function, (which may itself be aliased to us).
9002 * Don't access this version directly.
9006 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9011 PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
9013 va_start(args, pat);
9014 sv_vsetpvf_mg(sv, pat, &args);
9020 =for apidoc sv_setpvf
9022 Works like C<sv_catpvf> but copies the text into the SV instead of
9023 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
9029 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
9033 PERL_ARGS_ASSERT_SV_SETPVF;
9035 va_start(args, pat);
9036 sv_vsetpvf(sv, pat, &args);
9041 =for apidoc sv_vsetpvf
9043 Works like C<sv_vcatpvf> but copies the text into the SV instead of
9044 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
9046 Usually used via its frontend C<sv_setpvf>.
9052 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9054 PERL_ARGS_ASSERT_SV_VSETPVF;
9056 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9060 =for apidoc sv_setpvf_mg
9062 Like C<sv_setpvf>, but also handles 'set' magic.
9068 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9072 PERL_ARGS_ASSERT_SV_SETPVF_MG;
9074 va_start(args, pat);
9075 sv_vsetpvf_mg(sv, pat, &args);
9080 =for apidoc sv_vsetpvf_mg
9082 Like C<sv_vsetpvf>, but also handles 'set' magic.
9084 Usually used via its frontend C<sv_setpvf_mg>.
9090 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9092 PERL_ARGS_ASSERT_SV_VSETPVF_MG;
9094 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9098 #if defined(PERL_IMPLICIT_CONTEXT)
9100 /* pTHX_ magic can't cope with varargs, so this is a no-context
9101 * version of the main function, (which may itself be aliased to us).
9102 * Don't access this version directly.
9106 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
9111 PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
9113 va_start(args, pat);
9114 sv_vcatpvf(sv, pat, &args);
9118 /* pTHX_ magic can't cope with varargs, so this is a no-context
9119 * version of the main function, (which may itself be aliased to us).
9120 * Don't access this version directly.
9124 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9129 PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9131 va_start(args, pat);
9132 sv_vcatpvf_mg(sv, pat, &args);
9138 =for apidoc sv_catpvf
9140 Processes its arguments like C<sprintf> and appends the formatted
9141 output to an SV. If the appended data contains "wide" characters
9142 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9143 and characters >255 formatted with %c), the original SV might get
9144 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
9145 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9146 valid UTF-8; if the original SV was bytes, the pattern should be too.
9151 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9155 PERL_ARGS_ASSERT_SV_CATPVF;
9157 va_start(args, pat);
9158 sv_vcatpvf(sv, pat, &args);
9163 =for apidoc sv_vcatpvf
9165 Processes its arguments like C<vsprintf> and appends the formatted output
9166 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
9168 Usually used via its frontend C<sv_catpvf>.
9174 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9176 PERL_ARGS_ASSERT_SV_VCATPVF;
9178 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9182 =for apidoc sv_catpvf_mg
9184 Like C<sv_catpvf>, but also handles 'set' magic.
9190 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9194 PERL_ARGS_ASSERT_SV_CATPVF_MG;
9196 va_start(args, pat);
9197 sv_vcatpvf_mg(sv, pat, &args);
9202 =for apidoc sv_vcatpvf_mg
9204 Like C<sv_vcatpvf>, but also handles 'set' magic.
9206 Usually used via its frontend C<sv_catpvf_mg>.
9212 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9214 PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9216 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9221 =for apidoc sv_vsetpvfn
9223 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9226 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9232 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9233 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9235 PERL_ARGS_ASSERT_SV_VSETPVFN;
9238 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9243 * Warn of missing argument to sprintf, and then return a defined value
9244 * to avoid inappropriate "use of uninit" warnings [perl #71000].
9246 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
9248 S_vcatpvfn_missing_argument(pTHX) {
9249 if (ckWARN(WARN_MISSING)) {
9250 Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
9251 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
9258 S_expect_number(pTHX_ char **const pattern)
9263 PERL_ARGS_ASSERT_EXPECT_NUMBER;
9265 switch (**pattern) {
9266 case '1': case '2': case '3':
9267 case '4': case '5': case '6':
9268 case '7': case '8': case '9':
9269 var = *(*pattern)++ - '0';
9270 while (isDIGIT(**pattern)) {
9271 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
9273 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
9281 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
9283 const int neg = nv < 0;
9286 PERL_ARGS_ASSERT_F0CONVERT;
9294 if (uv & 1 && uv == nv)
9295 uv--; /* Round to even */
9297 const unsigned dig = uv % 10;
9310 =for apidoc sv_vcatpvfn
9312 Processes its arguments like C<vsprintf> and appends the formatted output
9313 to an SV. Uses an array of SVs if the C style variable argument list is
9314 missing (NULL). When running with taint checks enabled, indicates via
9315 C<maybe_tainted> if results are untrustworthy (often due to the use of
9318 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9324 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
9325 vecstr = (U8*)SvPV_const(vecsv,veclen);\
9326 vec_utf8 = DO_UTF8(vecsv);
9328 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9331 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9332 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9340 static const char nullstr[] = "(null)";
9342 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
9343 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9345 /* Times 4: a decimal digit takes more than 3 binary digits.
9346 * NV_DIG: mantissa takes than many decimal digits.
9347 * Plus 32: Playing safe. */
9348 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9349 /* large enough for "%#.#f" --chip */
9350 /* what about long double NVs? --jhi */
9352 PERL_ARGS_ASSERT_SV_VCATPVFN;
9353 PERL_UNUSED_ARG(maybe_tainted);
9355 /* no matter what, this is a string now */
9356 (void)SvPV_force(sv, origlen);
9358 /* special-case "", "%s", and "%-p" (SVf - see below) */
9361 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9363 const char * const s = va_arg(*args, char*);
9364 sv_catpv(sv, s ? s : nullstr);
9366 else if (svix < svmax) {
9367 sv_catsv(sv, *svargs);
9370 S_vcatpvfn_missing_argument(aTHX);
9373 if (args && patlen == 3 && pat[0] == '%' &&
9374 pat[1] == '-' && pat[2] == 'p') {
9375 argsv = MUTABLE_SV(va_arg(*args, void*));
9376 sv_catsv(sv, argsv);
9380 #ifndef USE_LONG_DOUBLE
9381 /* special-case "%.<number>[gf]" */
9382 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9383 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9384 unsigned digits = 0;
9388 while (*pp >= '0' && *pp <= '9')
9389 digits = 10 * digits + (*pp++ - '0');
9390 if (pp - pat == (int)patlen - 1) {
9396 S_vcatpvfn_missing_argument(aTHX);
9400 /* Add check for digits != 0 because it seems that some
9401 gconverts are buggy in this case, and we don't yet have
9402 a Configure test for this. */
9403 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9404 /* 0, point, slack */
9405 Gconvert(nv, (int)digits, 0, ebuf);
9407 if (*ebuf) /* May return an empty string for digits==0 */
9410 } else if (!digits) {
9413 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9414 sv_catpvn(sv, p, l);
9420 #endif /* !USE_LONG_DOUBLE */
9422 if (!args && svix < svmax && DO_UTF8(*svargs))
9425 patend = (char*)pat + patlen;
9426 for (p = (char*)pat; p < patend; p = q) {
9429 bool vectorize = FALSE;
9430 bool vectorarg = FALSE;
9431 bool vec_utf8 = FALSE;
9437 bool has_precis = FALSE;
9439 const I32 osvix = svix;
9440 bool is_utf8 = FALSE; /* is this item utf8? */
9441 #ifdef HAS_LDBL_SPRINTF_BUG
9442 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9443 with sfio - Allen <allens@cpan.org> */
9444 bool fix_ldbl_sprintf_bug = FALSE;
9448 U8 utf8buf[UTF8_MAXBYTES+1];
9449 STRLEN esignlen = 0;
9451 const char *eptr = NULL;
9452 const char *fmtstart;
9455 const U8 *vecstr = NULL;
9462 /* we need a long double target in case HAS_LONG_DOUBLE but
9465 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9473 const char *dotstr = ".";
9474 STRLEN dotstrlen = 1;
9475 I32 efix = 0; /* explicit format parameter index */
9476 I32 ewix = 0; /* explicit width index */
9477 I32 epix = 0; /* explicit precision index */
9478 I32 evix = 0; /* explicit vector index */
9479 bool asterisk = FALSE;
9481 /* echo everything up to the next format specification */
9482 for (q = p; q < patend && *q != '%'; ++q) ;
9484 if (has_utf8 && !pat_utf8)
9485 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9487 sv_catpvn(sv, p, q - p);
9496 We allow format specification elements in this order:
9497 \d+\$ explicit format parameter index
9499 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9500 0 flag (as above): repeated to allow "v02"
9501 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9502 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9504 [%bcdefginopsuxDFOUX] format (mandatory)
9509 As of perl5.9.3, printf format checking is on by default.
9510 Internally, perl uses %p formats to provide an escape to
9511 some extended formatting. This block deals with those
9512 extensions: if it does not match, (char*)q is reset and
9513 the normal format processing code is used.
9515 Currently defined extensions are:
9516 %p include pointer address (standard)
9517 %-p (SVf) include an SV (previously %_)
9518 %-<num>p include an SV with precision <num>
9519 %<num>p reserved for future extensions
9521 Robin Barker 2005-07-14
9523 %1p (VDf) removed. RMB 2007-10-19
9530 n = expect_number(&q);
9537 argsv = MUTABLE_SV(va_arg(*args, void*));
9538 eptr = SvPV_const(argsv, elen);
9544 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
9545 "internal %%<num>p might conflict with future printf extensions");
9551 if ( (width = expect_number(&q)) ) {
9566 if (plus == '+' && *q == ' ') /* '+' over ' ' */
9595 if ( (ewix = expect_number(&q)) )
9604 if ((vectorarg = asterisk)) {
9617 width = expect_number(&q);
9623 vecsv = va_arg(*args, SV*);
9625 vecsv = (evix > 0 && evix <= svmax)
9626 ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
9628 vecsv = svix < svmax
9629 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
9631 dotstr = SvPV_const(vecsv, dotstrlen);
9632 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
9633 bad with tied or overloaded values that return UTF8. */
9636 else if (has_utf8) {
9637 vecsv = sv_mortalcopy(vecsv);
9638 sv_utf8_upgrade(vecsv);
9639 dotstr = SvPV_const(vecsv, dotstrlen);
9646 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
9647 vecsv = svargs[efix ? efix-1 : svix++];
9648 vecstr = (U8*)SvPV_const(vecsv,veclen);
9649 vec_utf8 = DO_UTF8(vecsv);
9651 /* if this is a version object, we need to convert
9652 * back into v-string notation and then let the
9653 * vectorize happen normally
9655 if (sv_derived_from(vecsv, "version")) {
9656 char *version = savesvpv(vecsv);
9657 if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
9658 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9659 "vector argument not supported with alpha versions");
9662 vecsv = sv_newmortal();
9663 scan_vstring(version, version + veclen, vecsv);
9664 vecstr = (U8*)SvPV_const(vecsv, veclen);
9665 vec_utf8 = DO_UTF8(vecsv);
9677 i = va_arg(*args, int);
9679 i = (ewix ? ewix <= svmax : svix < svmax) ?
9680 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9682 width = (i < 0) ? -i : i;
9692 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
9694 /* XXX: todo, support specified precision parameter */
9698 i = va_arg(*args, int);
9700 i = (ewix ? ewix <= svmax : svix < svmax)
9701 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9703 has_precis = !(i < 0);
9708 precis = precis * 10 + (*q++ - '0');
9717 case 'I': /* Ix, I32x, and I64x */
9719 if (q[1] == '6' && q[2] == '4') {
9725 if (q[1] == '3' && q[2] == '2') {
9735 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9746 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9747 if (*(q + 1) == 'l') { /* lld, llf */
9773 if (!vectorize && !args) {
9775 const I32 i = efix-1;
9776 argsv = (i >= 0 && i < svmax)
9777 ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
9779 argsv = (svix >= 0 && svix < svmax)
9780 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
9791 uv = (args) ? va_arg(*args, int) : SvIV(argsv);
9793 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9795 eptr = (char*)utf8buf;
9796 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9810 eptr = va_arg(*args, char*);
9812 elen = strlen(eptr);
9814 eptr = (char *)nullstr;
9815 elen = sizeof nullstr - 1;
9819 eptr = SvPV_const(argsv, elen);
9820 if (DO_UTF8(argsv)) {
9821 STRLEN old_precis = precis;
9822 if (has_precis && precis < elen) {
9823 STRLEN ulen = sv_len_utf8(argsv);
9824 I32 p = precis > ulen ? ulen : precis;
9825 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9828 if (width) { /* fudge width (can't fudge elen) */
9829 if (has_precis && precis < elen)
9830 width += precis - old_precis;
9832 width += elen - sv_len_utf8(argsv);
9839 if (has_precis && precis < elen)
9846 if (alt || vectorize)
9848 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9869 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9878 esignbuf[esignlen++] = plus;
9882 case 'h': iv = (short)va_arg(*args, int); break;
9883 case 'l': iv = va_arg(*args, long); break;
9884 case 'V': iv = va_arg(*args, IV); break;
9885 default: iv = va_arg(*args, int); break;
9888 iv = va_arg(*args, Quad_t); break;
9895 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
9897 case 'h': iv = (short)tiv; break;
9898 case 'l': iv = (long)tiv; break;
9900 default: iv = tiv; break;
9903 iv = (Quad_t)tiv; break;
9909 if ( !vectorize ) /* we already set uv above */
9914 esignbuf[esignlen++] = plus;
9918 esignbuf[esignlen++] = '-';
9962 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9973 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9974 case 'l': uv = va_arg(*args, unsigned long); break;
9975 case 'V': uv = va_arg(*args, UV); break;
9976 default: uv = va_arg(*args, unsigned); break;
9979 uv = va_arg(*args, Uquad_t); break;
9986 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
9988 case 'h': uv = (unsigned short)tuv; break;
9989 case 'l': uv = (unsigned long)tuv; break;
9991 default: uv = tuv; break;
9994 uv = (Uquad_t)tuv; break;
10003 char *ptr = ebuf + sizeof ebuf;
10004 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
10010 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
10014 } while (uv >>= 4);
10016 esignbuf[esignlen++] = '0';
10017 esignbuf[esignlen++] = c; /* 'x' or 'X' */
10023 *--ptr = '0' + dig;
10024 } while (uv >>= 3);
10025 if (alt && *ptr != '0')
10031 *--ptr = '0' + dig;
10032 } while (uv >>= 1);
10034 esignbuf[esignlen++] = '0';
10035 esignbuf[esignlen++] = c;
10038 default: /* it had better be ten or less */
10041 *--ptr = '0' + dig;
10042 } while (uv /= base);
10045 elen = (ebuf + sizeof ebuf) - ptr;
10049 zeros = precis - elen;
10050 else if (precis == 0 && elen == 1 && *eptr == '0'
10051 && !(base == 8 && alt)) /* "%#.0o" prints "0" */
10054 /* a precision nullifies the 0 flag. */
10061 /* FLOATING POINT */
10064 c = 'f'; /* maybe %F isn't supported here */
10066 case 'e': case 'E':
10068 case 'g': case 'G':
10072 /* This is evil, but floating point is even more evil */
10074 /* for SV-style calling, we can only get NV
10075 for C-style calling, we assume %f is double;
10076 for simplicity we allow any of %Lf, %llf, %qf for long double
10080 #if defined(USE_LONG_DOUBLE)
10084 /* [perl #20339] - we should accept and ignore %lf rather than die */
10088 #if defined(USE_LONG_DOUBLE)
10089 intsize = args ? 0 : 'q';
10093 #if defined(HAS_LONG_DOUBLE)
10102 /* now we need (long double) if intsize == 'q', else (double) */
10104 #if LONG_DOUBLESIZE > DOUBLESIZE
10106 va_arg(*args, long double) :
10107 va_arg(*args, double)
10109 va_arg(*args, double)
10114 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
10115 else. frexp() has some unspecified behaviour for those three */
10116 if (c != 'e' && c != 'E' && (nv * 0) == 0) {
10118 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
10119 will cast our (long double) to (double) */
10120 (void)Perl_frexp(nv, &i);
10121 if (i == PERL_INT_MIN)
10122 Perl_die(aTHX_ "panic: frexp");
10124 need = BIT_DIGITS(i);
10126 need += has_precis ? precis : 6; /* known default */
10131 #ifdef HAS_LDBL_SPRINTF_BUG
10132 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10133 with sfio - Allen <allens@cpan.org> */
10136 # define MY_DBL_MAX DBL_MAX
10137 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
10138 # if DOUBLESIZE >= 8
10139 # define MY_DBL_MAX 1.7976931348623157E+308L
10141 # define MY_DBL_MAX 3.40282347E+38L
10145 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10146 # define MY_DBL_MAX_BUG 1L
10148 # define MY_DBL_MAX_BUG MY_DBL_MAX
10152 # define MY_DBL_MIN DBL_MIN
10153 # else /* XXX guessing! -Allen */
10154 # if DOUBLESIZE >= 8
10155 # define MY_DBL_MIN 2.2250738585072014E-308L
10157 # define MY_DBL_MIN 1.17549435E-38L
10161 if ((intsize == 'q') && (c == 'f') &&
10162 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10163 (need < DBL_DIG)) {
10164 /* it's going to be short enough that
10165 * long double precision is not needed */
10167 if ((nv <= 0L) && (nv >= -0L))
10168 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10170 /* would use Perl_fp_class as a double-check but not
10171 * functional on IRIX - see perl.h comments */
10173 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10174 /* It's within the range that a double can represent */
10175 #if defined(DBL_MAX) && !defined(DBL_MIN)
10176 if ((nv >= ((long double)1/DBL_MAX)) ||
10177 (nv <= (-(long double)1/DBL_MAX)))
10179 fix_ldbl_sprintf_bug = TRUE;
10182 if (fix_ldbl_sprintf_bug == TRUE) {
10192 # undef MY_DBL_MAX_BUG
10195 #endif /* HAS_LDBL_SPRINTF_BUG */
10197 need += 20; /* fudge factor */
10198 if (PL_efloatsize < need) {
10199 Safefree(PL_efloatbuf);
10200 PL_efloatsize = need + 20; /* more fudge */
10201 Newx(PL_efloatbuf, PL_efloatsize, char);
10202 PL_efloatbuf[0] = '\0';
10205 if ( !(width || left || plus || alt) && fill != '0'
10206 && has_precis && intsize != 'q' ) { /* Shortcuts */
10207 /* See earlier comment about buggy Gconvert when digits,
10209 if ( c == 'g' && precis) {
10210 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10211 /* May return an empty string for digits==0 */
10212 if (*PL_efloatbuf) {
10213 elen = strlen(PL_efloatbuf);
10214 goto float_converted;
10216 } else if ( c == 'f' && !precis) {
10217 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10222 char *ptr = ebuf + sizeof ebuf;
10225 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10226 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10227 if (intsize == 'q') {
10228 /* Copy the one or more characters in a long double
10229 * format before the 'base' ([efgEFG]) character to
10230 * the format string. */
10231 static char const prifldbl[] = PERL_PRIfldbl;
10232 char const *p = prifldbl + sizeof(prifldbl) - 3;
10233 while (p >= prifldbl) { *--ptr = *p--; }
10238 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10243 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10255 /* No taint. Otherwise we are in the strange situation
10256 * where printf() taints but print($float) doesn't.
10258 #if defined(HAS_LONG_DOUBLE)
10259 elen = ((intsize == 'q')
10260 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
10261 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
10263 elen = my_sprintf(PL_efloatbuf, ptr, nv);
10267 eptr = PL_efloatbuf;
10275 i = SvCUR(sv) - origlen;
10278 case 'h': *(va_arg(*args, short*)) = i; break;
10279 default: *(va_arg(*args, int*)) = i; break;
10280 case 'l': *(va_arg(*args, long*)) = i; break;
10281 case 'V': *(va_arg(*args, IV*)) = i; break;
10284 *(va_arg(*args, Quad_t*)) = i; break;
10291 sv_setuv_mg(argsv, (UV)i);
10292 continue; /* not "break" */
10299 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
10300 && ckWARN(WARN_PRINTF))
10302 SV * const msg = sv_newmortal();
10303 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10304 (PL_op->op_type == OP_PRTF) ? "" : "s");
10305 if (fmtstart < patend) {
10306 const char * const fmtend = q < patend ? q : patend;
10308 sv_catpvs(msg, "\"%");
10309 for (f = fmtstart; f < fmtend; f++) {
10311 sv_catpvn(msg, f, 1);
10313 Perl_sv_catpvf(aTHX_ msg,
10314 "\\%03"UVof, (UV)*f & 0xFF);
10317 sv_catpvs(msg, "\"");
10319 sv_catpvs(msg, "end of string");
10321 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
10324 /* output mangled stuff ... */
10330 /* ... right here, because formatting flags should not apply */
10331 SvGROW(sv, SvCUR(sv) + elen + 1);
10333 Copy(eptr, p, elen, char);
10336 SvCUR_set(sv, p - SvPVX_const(sv));
10338 continue; /* not "break" */
10341 if (is_utf8 != has_utf8) {
10344 sv_utf8_upgrade(sv);
10347 const STRLEN old_elen = elen;
10348 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
10349 sv_utf8_upgrade(nsv);
10350 eptr = SvPVX_const(nsv);
10353 if (width) { /* fudge width (can't fudge elen) */
10354 width += elen - old_elen;
10360 have = esignlen + zeros + elen;
10362 Perl_croak_nocontext("%s", PL_memory_wrap);
10364 need = (have > width ? have : width);
10367 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
10368 Perl_croak_nocontext("%s", PL_memory_wrap);
10369 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10371 if (esignlen && fill == '0') {
10373 for (i = 0; i < (int)esignlen; i++)
10374 *p++ = esignbuf[i];
10376 if (gap && !left) {
10377 memset(p, fill, gap);
10380 if (esignlen && fill != '0') {
10382 for (i = 0; i < (int)esignlen; i++)
10383 *p++ = esignbuf[i];
10387 for (i = zeros; i; i--)
10391 Copy(eptr, p, elen, char);
10395 memset(p, ' ', gap);
10400 Copy(dotstr, p, dotstrlen, char);
10404 vectorize = FALSE; /* done iterating over vecstr */
10411 SvCUR_set(sv, p - SvPVX_const(sv));
10420 /* =========================================================================
10422 =head1 Cloning an interpreter
10424 All the macros and functions in this section are for the private use of
10425 the main function, perl_clone().
10427 The foo_dup() functions make an exact copy of an existing foo thingy.
10428 During the course of a cloning, a hash table is used to map old addresses
10429 to new addresses. The table is created and manipulated with the
10430 ptr_table_* functions.
10434 * =========================================================================*/
10437 #if defined(USE_ITHREADS)
10439 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
10440 #ifndef GpREFCNT_inc
10441 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10445 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
10446 that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
10447 If this changes, please unmerge ss_dup.
10448 Likewise, sv_dup_inc_multiple() relies on this fact. */
10449 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10450 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t))
10451 #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
10452 #define av_dup_inc(s,t) MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10453 #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
10454 #define hv_dup_inc(s,t) MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10455 #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
10456 #define cv_dup_inc(s,t) MUTABLE_CV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10457 #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
10458 #define io_dup_inc(s,t) MUTABLE_IO(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10459 #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
10460 #define gv_dup_inc(s,t) MUTABLE_GV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10461 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
10462 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
10464 /* clone a parser */
10467 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
10471 PERL_ARGS_ASSERT_PARSER_DUP;
10476 /* look for it in the table first */
10477 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
10481 /* create anew and remember what it is */
10482 Newxz(parser, 1, yy_parser);
10483 ptr_table_store(PL_ptr_table, proto, parser);
10485 parser->yyerrstatus = 0;
10486 parser->yychar = YYEMPTY; /* Cause a token to be read. */
10488 /* XXX these not yet duped */
10489 parser->old_parser = NULL;
10490 parser->stack = NULL;
10492 parser->stack_size = 0;
10493 /* XXX parser->stack->state = 0; */
10495 /* XXX eventually, just Copy() most of the parser struct ? */
10497 parser->lex_brackets = proto->lex_brackets;
10498 parser->lex_casemods = proto->lex_casemods;
10499 parser->lex_brackstack = savepvn(proto->lex_brackstack,
10500 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
10501 parser->lex_casestack = savepvn(proto->lex_casestack,
10502 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
10503 parser->lex_defer = proto->lex_defer;
10504 parser->lex_dojoin = proto->lex_dojoin;
10505 parser->lex_expect = proto->lex_expect;
10506 parser->lex_formbrack = proto->lex_formbrack;
10507 parser->lex_inpat = proto->lex_inpat;
10508 parser->lex_inwhat = proto->lex_inwhat;
10509 parser->lex_op = proto->lex_op;
10510 parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
10511 parser->lex_starts = proto->lex_starts;
10512 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
10513 parser->multi_close = proto->multi_close;
10514 parser->multi_open = proto->multi_open;
10515 parser->multi_start = proto->multi_start;
10516 parser->multi_end = proto->multi_end;
10517 parser->pending_ident = proto->pending_ident;
10518 parser->preambled = proto->preambled;
10519 parser->sublex_info = proto->sublex_info; /* XXX not quite right */
10520 parser->linestr = sv_dup_inc(proto->linestr, param);
10521 parser->expect = proto->expect;
10522 parser->copline = proto->copline;
10523 parser->last_lop_op = proto->last_lop_op;
10524 parser->lex_state = proto->lex_state;
10525 parser->rsfp = fp_dup(proto->rsfp, '<', param);
10526 /* rsfp_filters entries have fake IoDIRP() */
10527 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
10528 parser->in_my = proto->in_my;
10529 parser->in_my_stash = hv_dup(proto->in_my_stash, param);
10530 parser->error_count = proto->error_count;
10533 parser->linestr = sv_dup_inc(proto->linestr, param);
10536 char * const ols = SvPVX(proto->linestr);
10537 char * const ls = SvPVX(parser->linestr);
10539 parser->bufptr = ls + (proto->bufptr >= ols ?
10540 proto->bufptr - ols : 0);
10541 parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
10542 proto->oldbufptr - ols : 0);
10543 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
10544 proto->oldoldbufptr - ols : 0);
10545 parser->linestart = ls + (proto->linestart >= ols ?
10546 proto->linestart - ols : 0);
10547 parser->last_uni = ls + (proto->last_uni >= ols ?
10548 proto->last_uni - ols : 0);
10549 parser->last_lop = ls + (proto->last_lop >= ols ?
10550 proto->last_lop - ols : 0);
10552 parser->bufend = ls + SvCUR(parser->linestr);
10555 Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
10559 parser->endwhite = proto->endwhite;
10560 parser->faketokens = proto->faketokens;
10561 parser->lasttoke = proto->lasttoke;
10562 parser->nextwhite = proto->nextwhite;
10563 parser->realtokenstart = proto->realtokenstart;
10564 parser->skipwhite = proto->skipwhite;
10565 parser->thisclose = proto->thisclose;
10566 parser->thismad = proto->thismad;
10567 parser->thisopen = proto->thisopen;
10568 parser->thisstuff = proto->thisstuff;
10569 parser->thistoken = proto->thistoken;
10570 parser->thiswhite = proto->thiswhite;
10572 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
10573 parser->curforce = proto->curforce;
10575 Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
10576 Copy(proto->nexttype, parser->nexttype, 5, I32);
10577 parser->nexttoke = proto->nexttoke;
10580 /* XXX should clone saved_curcop here, but we aren't passed
10581 * proto_perl; so do it in perl_clone_using instead */
10587 /* duplicate a file handle */
10590 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
10594 PERL_ARGS_ASSERT_FP_DUP;
10595 PERL_UNUSED_ARG(type);
10598 return (PerlIO*)NULL;
10600 /* look for it in the table first */
10601 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10605 /* create anew and remember what it is */
10606 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10607 ptr_table_store(PL_ptr_table, fp, ret);
10611 /* duplicate a directory handle */
10614 Perl_dirp_dup(pTHX_ DIR *const dp)
10616 PERL_UNUSED_CONTEXT;
10623 /* duplicate a typeglob */
10626 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
10630 PERL_ARGS_ASSERT_GP_DUP;
10634 /* look for it in the table first */
10635 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10639 /* create anew and remember what it is */
10641 ptr_table_store(PL_ptr_table, gp, ret);
10644 /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
10645 on Newxz() to do this for us. */
10646 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10647 ret->gp_io = io_dup_inc(gp->gp_io, param);
10648 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10649 ret->gp_av = av_dup_inc(gp->gp_av, param);
10650 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10651 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10652 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10653 ret->gp_cvgen = gp->gp_cvgen;
10654 ret->gp_line = gp->gp_line;
10655 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
10659 /* duplicate a chain of magic */
10662 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
10664 MAGIC *mgret = NULL;
10665 MAGIC **mgprev_p = &mgret;
10667 PERL_ARGS_ASSERT_MG_DUP;
10669 for (; mg; mg = mg->mg_moremagic) {
10671 Newx(nmg, 1, MAGIC);
10673 mgprev_p = &(nmg->mg_moremagic);
10675 /* There was a comment "XXX copy dynamic vtable?" but as we don't have
10676 dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
10677 from the original commit adding Perl_mg_dup() - revision 4538.
10678 Similarly there is the annotation "XXX random ptr?" next to the
10679 assignment to nmg->mg_ptr. */
10682 /* FIXME for plugins
10683 if (nmg->mg_type == PERL_MAGIC_qr) {
10684 nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
10688 if(nmg->mg_type == PERL_MAGIC_backref) {
10689 /* The backref AV has its reference count deliberately bumped by
10692 = SvREFCNT_inc(av_dup_inc((const AV *) nmg->mg_obj, param));
10695 nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
10696 ? sv_dup_inc(nmg->mg_obj, param)
10697 : sv_dup(nmg->mg_obj, param);
10700 if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
10701 if (nmg->mg_len > 0) {
10702 nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
10703 if (nmg->mg_type == PERL_MAGIC_overload_table &&
10704 AMT_AMAGIC((AMT*)nmg->mg_ptr))
10706 AMT * const namtp = (AMT*)nmg->mg_ptr;
10707 sv_dup_inc_multiple((SV**)(namtp->table),
10708 (SV**)(namtp->table), NofAMmeth, param);
10711 else if (nmg->mg_len == HEf_SVKEY)
10712 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
10714 if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
10715 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10721 #endif /* USE_ITHREADS */
10723 struct ptr_tbl_arena {
10724 struct ptr_tbl_arena *next;
10725 struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */
10728 /* create a new pointer-mapping table */
10731 Perl_ptr_table_new(pTHX)
10734 PERL_UNUSED_CONTEXT;
10736 Newx(tbl, 1, PTR_TBL_t);
10737 tbl->tbl_max = 511;
10738 tbl->tbl_items = 0;
10739 tbl->tbl_arena = NULL;
10740 tbl->tbl_arena_next = NULL;
10741 tbl->tbl_arena_end = NULL;
10742 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10746 #define PTR_TABLE_HASH(ptr) \
10747 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
10749 /* map an existing pointer using a table */
10751 STATIC PTR_TBL_ENT_t *
10752 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
10754 PTR_TBL_ENT_t *tblent;
10755 const UV hash = PTR_TABLE_HASH(sv);
10757 PERL_ARGS_ASSERT_PTR_TABLE_FIND;
10759 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10760 for (; tblent; tblent = tblent->next) {
10761 if (tblent->oldval == sv)
10768 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
10770 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
10772 PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
10773 PERL_UNUSED_CONTEXT;
10775 return tblent ? tblent->newval : NULL;
10778 /* add a new entry to a pointer-mapping table */
10781 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
10783 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
10785 PERL_ARGS_ASSERT_PTR_TABLE_STORE;
10786 PERL_UNUSED_CONTEXT;
10789 tblent->newval = newsv;
10791 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
10793 if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
10794 struct ptr_tbl_arena *new_arena;
10796 Newx(new_arena, 1, struct ptr_tbl_arena);
10797 new_arena->next = tbl->tbl_arena;
10798 tbl->tbl_arena = new_arena;
10799 tbl->tbl_arena_next = new_arena->array;
10800 tbl->tbl_arena_end = new_arena->array
10801 + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
10804 tblent = tbl->tbl_arena_next++;
10806 tblent->oldval = oldsv;
10807 tblent->newval = newsv;
10808 tblent->next = tbl->tbl_ary[entry];
10809 tbl->tbl_ary[entry] = tblent;
10811 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
10812 ptr_table_split(tbl);
10816 /* double the hash bucket size of an existing ptr table */
10819 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
10821 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10822 const UV oldsize = tbl->tbl_max + 1;
10823 UV newsize = oldsize * 2;
10826 PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
10827 PERL_UNUSED_CONTEXT;
10829 Renew(ary, newsize, PTR_TBL_ENT_t*);
10830 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10831 tbl->tbl_max = --newsize;
10832 tbl->tbl_ary = ary;
10833 for (i=0; i < oldsize; i++, ary++) {
10834 PTR_TBL_ENT_t **curentp, **entp, *ent;
10837 curentp = ary + oldsize;
10838 for (entp = ary, ent = *ary; ent; ent = *entp) {
10839 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10841 ent->next = *curentp;
10851 /* remove all the entries from a ptr table */
10852 /* Deprecated - will be removed post 5.14 */
10855 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
10857 if (tbl && tbl->tbl_items) {
10858 struct ptr_tbl_arena *arena = tbl->tbl_arena;
10860 Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
10863 struct ptr_tbl_arena *next = arena->next;
10869 tbl->tbl_items = 0;
10870 tbl->tbl_arena = NULL;
10871 tbl->tbl_arena_next = NULL;
10872 tbl->tbl_arena_end = NULL;
10876 /* clear and free a ptr table */
10879 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
10881 struct ptr_tbl_arena *arena;
10887 arena = tbl->tbl_arena;
10890 struct ptr_tbl_arena *next = arena->next;
10896 Safefree(tbl->tbl_ary);
10900 #if defined(USE_ITHREADS)
10903 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
10905 PERL_ARGS_ASSERT_RVPV_DUP;
10908 SvRV_set(dstr, SvWEAKREF(sstr)
10909 ? sv_dup(SvRV_const(sstr), param)
10910 : sv_dup_inc(SvRV_const(sstr), param));
10913 else if (SvPVX_const(sstr)) {
10914 /* Has something there */
10916 /* Normal PV - clone whole allocated space */
10917 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10918 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10919 /* Not that normal - actually sstr is copy on write.
10920 But we are a true, independant SV, so: */
10921 SvREADONLY_off(dstr);
10926 /* Special case - not normally malloced for some reason */
10927 if (isGV_with_GP(sstr)) {
10928 /* Don't need to do anything here. */
10930 else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10931 /* A "shared" PV - clone it as "shared" PV */
10933 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10937 /* Some other special case - random pointer */
10938 SvPV_set(dstr, (char *) SvPVX_const(sstr));
10943 /* Copy the NULL */
10944 SvPV_set(dstr, NULL);
10948 /* duplicate a list of SVs. source and dest may point to the same memory. */
10950 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
10951 SSize_t items, CLONE_PARAMS *const param)
10953 PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
10955 while (items-- > 0) {
10956 *dest++ = sv_dup_inc(*source++, param);
10962 /* duplicate an SV of any type (including AV, HV etc) */
10965 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
10970 PERL_ARGS_ASSERT_SV_DUP;
10974 if (SvTYPE(sstr) == SVTYPEMASK) {
10975 #ifdef DEBUG_LEAKING_SCALARS_ABORT
10980 /* look for it in the table first */
10981 dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
10985 if(param->flags & CLONEf_JOIN_IN) {
10986 /** We are joining here so we don't want do clone
10987 something that is bad **/
10988 if (SvTYPE(sstr) == SVt_PVHV) {
10989 const HEK * const hvname = HvNAME_HEK(sstr);
10991 /** don't clone stashes if they already exist **/
10992 return MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
10996 /* create anew and remember what it is */
10999 #ifdef DEBUG_LEAKING_SCALARS
11000 dstr->sv_debug_optype = sstr->sv_debug_optype;
11001 dstr->sv_debug_line = sstr->sv_debug_line;
11002 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
11003 dstr->sv_debug_cloned = 1;
11004 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
11007 ptr_table_store(PL_ptr_table, sstr, dstr);
11010 SvFLAGS(dstr) = SvFLAGS(sstr);
11011 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
11012 SvREFCNT(dstr) = 0; /* must be before any other dups! */
11015 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
11016 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
11017 (void*)PL_watch_pvx, SvPVX_const(sstr));
11020 /* don't clone objects whose class has asked us not to */
11021 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
11026 switch (SvTYPE(sstr)) {
11028 SvANY(dstr) = NULL;
11031 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
11033 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11035 SvIV_set(dstr, SvIVX(sstr));
11039 SvANY(dstr) = new_XNV();
11040 SvNV_set(dstr, SvNVX(sstr));
11042 /* case SVt_BIND: */
11045 /* These are all the types that need complex bodies allocating. */
11047 const svtype sv_type = SvTYPE(sstr);
11048 const struct body_details *const sv_type_details
11049 = bodies_by_type + sv_type;
11053 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11068 assert(sv_type_details->body_size);
11069 if (sv_type_details->arena) {
11070 new_body_inline(new_body, sv_type);
11072 = (void*)((char*)new_body - sv_type_details->offset);
11074 new_body = new_NOARENA(sv_type_details);
11078 SvANY(dstr) = new_body;
11081 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
11082 ((char*)SvANY(dstr)) + sv_type_details->offset,
11083 sv_type_details->copy, char);
11085 Copy(((char*)SvANY(sstr)),
11086 ((char*)SvANY(dstr)),
11087 sv_type_details->body_size + sv_type_details->offset, char);
11090 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
11091 && !isGV_with_GP(dstr))
11092 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11094 /* The Copy above means that all the source (unduplicated) pointers
11095 are now in the destination. We can check the flags and the
11096 pointers in either, but it's possible that there's less cache
11097 missing by always going for the destination.
11098 FIXME - instrument and check that assumption */
11099 if (sv_type >= SVt_PVMG) {
11100 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
11101 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
11102 } else if (SvMAGIC(dstr))
11103 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
11105 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
11108 /* The cast silences a GCC warning about unhandled types. */
11109 switch ((int)sv_type) {
11119 /* FIXME for plugins */
11120 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
11123 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
11124 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
11125 LvTARG(dstr) = dstr;
11126 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
11127 LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
11129 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
11131 if(isGV_with_GP(sstr)) {
11132 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
11133 /* Don't call sv_add_backref here as it's going to be
11134 created as part of the magic cloning of the symbol
11135 table--unless this is during a join and the stash
11136 is not actually being cloned. */
11137 /* Danger Will Robinson - GvGP(dstr) isn't initialised
11138 at the point of this comment. */
11139 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
11140 if(param->flags & CLONEf_JOIN_IN) {
11141 const HEK * const hvname
11142 = HvNAME_HEK(GvSTASH(dstr));
11144 && GvSTASH(dstr) == gv_stashpvn(
11145 HEK_KEY(hvname), HEK_LEN(hvname), 0
11148 Perl_sv_add_backref(
11149 aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr
11152 GvGP(dstr) = gp_dup(GvGP(sstr), param);
11153 (void)GpREFCNT_inc(GvGP(dstr));
11155 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11158 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
11159 if (IoOFP(dstr) == IoIFP(sstr))
11160 IoOFP(dstr) = IoIFP(dstr);
11162 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
11163 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
11164 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
11165 /* I have no idea why fake dirp (rsfps)
11166 should be treated differently but otherwise
11167 we end up with leaks -- sky*/
11168 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
11169 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
11170 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
11172 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
11173 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
11174 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
11175 if (IoDIRP(dstr)) {
11176 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
11179 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
11182 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
11183 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
11184 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
11187 /* avoid cloning an empty array */
11188 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
11189 SV **dst_ary, **src_ary;
11190 SSize_t items = AvFILLp((const AV *)sstr) + 1;
11192 src_ary = AvARRAY((const AV *)sstr);
11193 Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
11194 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
11195 AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
11196 AvALLOC((const AV *)dstr) = dst_ary;
11197 if (AvREAL((const AV *)sstr)) {
11198 dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
11202 while (items-- > 0)
11203 *dst_ary++ = sv_dup(*src_ary++, param);
11204 if (!(param->flags & CLONEf_COPY_STACKS)
11207 av_reify(MUTABLE_AV(dstr)); /* #41138 */
11210 items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
11211 while (items-- > 0) {
11212 *dst_ary++ = &PL_sv_undef;
11216 AvARRAY(MUTABLE_AV(dstr)) = NULL;
11217 AvALLOC((const AV *)dstr) = (SV**)NULL;
11218 AvMAX( (const AV *)dstr) = -1;
11219 AvFILLp((const AV *)dstr) = -1;
11223 if (HvARRAY((const HV *)sstr)) {
11225 const bool sharekeys = !!HvSHAREKEYS(sstr);
11226 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
11227 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
11229 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
11230 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
11232 HvARRAY(dstr) = (HE**)darray;
11233 while (i <= sxhv->xhv_max) {
11234 const HE * const source = HvARRAY(sstr)[i];
11235 HvARRAY(dstr)[i] = source
11236 ? he_dup(source, sharekeys, param) : 0;
11241 const struct xpvhv_aux * const saux = HvAUX(sstr);
11242 struct xpvhv_aux * const daux = HvAUX(dstr);
11243 /* This flag isn't copied. */
11244 /* SvOOK_on(hv) attacks the IV flags. */
11245 SvFLAGS(dstr) |= SVf_OOK;
11247 hvname = saux->xhv_name;
11248 daux->xhv_name = hek_dup(hvname, param);
11250 daux->xhv_riter = saux->xhv_riter;
11251 daux->xhv_eiter = saux->xhv_eiter
11252 ? he_dup(saux->xhv_eiter,
11253 cBOOL(HvSHAREKEYS(sstr)), param) : 0;
11254 /* backref array needs refcnt=2; see sv_add_backref */
11255 daux->xhv_backreferences =
11256 saux->xhv_backreferences
11257 ? MUTABLE_AV(SvREFCNT_inc(
11258 sv_dup_inc((const SV *)saux->xhv_backreferences, param)))
11261 daux->xhv_mro_meta = saux->xhv_mro_meta
11262 ? mro_meta_dup(saux->xhv_mro_meta, param)
11265 /* Record stashes for possible cloning in Perl_clone(). */
11267 av_push(param->stashes, dstr);
11271 HvARRAY(MUTABLE_HV(dstr)) = NULL;
11274 if (!(param->flags & CLONEf_COPY_STACKS)) {
11278 /* NOTE: not refcounted */
11279 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
11281 if (!CvISXSUB(dstr))
11282 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
11284 if (CvCONST(dstr) && CvISXSUB(dstr)) {
11285 CvXSUBANY(dstr).any_ptr =
11286 sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
11288 /* don't dup if copying back - CvGV isn't refcounted, so the
11289 * duped GV may never be freed. A bit of a hack! DAPM */
11290 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
11291 NULL : gv_dup(CvGV(dstr), param) ;
11292 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
11294 CvWEAKOUTSIDE(sstr)
11295 ? cv_dup( CvOUTSIDE(dstr), param)
11296 : cv_dup_inc(CvOUTSIDE(dstr), param);
11297 if (!CvISXSUB(dstr))
11298 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
11304 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11310 /* duplicate a context */
11313 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11315 PERL_CONTEXT *ncxs;
11317 PERL_ARGS_ASSERT_CX_DUP;
11320 return (PERL_CONTEXT*)NULL;
11322 /* look for it in the table first */
11323 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11327 /* create anew and remember what it is */
11328 Newx(ncxs, max + 1, PERL_CONTEXT);
11329 ptr_table_store(PL_ptr_table, cxs, ncxs);
11330 Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
11333 PERL_CONTEXT * const ncx = &ncxs[ix];
11334 if (CxTYPE(ncx) == CXt_SUBST) {
11335 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11338 switch (CxTYPE(ncx)) {
11340 ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
11341 ? cv_dup_inc(ncx->blk_sub.cv, param)
11342 : cv_dup(ncx->blk_sub.cv,param));
11343 ncx->blk_sub.argarray = (CxHASARGS(ncx)
11344 ? av_dup_inc(ncx->blk_sub.argarray,
11347 ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
11349 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
11350 ncx->blk_sub.oldcomppad);
11353 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
11355 ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
11357 case CXt_LOOP_LAZYSV:
11358 ncx->blk_loop.state_u.lazysv.end
11359 = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
11360 /* We are taking advantage of av_dup_inc and sv_dup_inc
11361 actually being the same function, and order equivalance of
11363 We can assert the later [but only at run time :-(] */
11364 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
11365 (void *) &ncx->blk_loop.state_u.lazysv.cur);
11367 ncx->blk_loop.state_u.ary.ary
11368 = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
11369 case CXt_LOOP_LAZYIV:
11370 case CXt_LOOP_PLAIN:
11371 if (CxPADLOOP(ncx)) {
11372 ncx->blk_loop.oldcomppad
11373 = (PAD*)ptr_table_fetch(PL_ptr_table,
11374 ncx->blk_loop.oldcomppad);
11376 ncx->blk_loop.oldcomppad
11377 = (PAD*)gv_dup((const GV *)ncx->blk_loop.oldcomppad,
11382 ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
11383 ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
11384 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
11397 /* duplicate a stack info structure */
11400 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11404 PERL_ARGS_ASSERT_SI_DUP;
11407 return (PERL_SI*)NULL;
11409 /* look for it in the table first */
11410 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11414 /* create anew and remember what it is */
11415 Newxz(nsi, 1, PERL_SI);
11416 ptr_table_store(PL_ptr_table, si, nsi);
11418 nsi->si_stack = av_dup_inc(si->si_stack, param);
11419 nsi->si_cxix = si->si_cxix;
11420 nsi->si_cxmax = si->si_cxmax;
11421 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11422 nsi->si_type = si->si_type;
11423 nsi->si_prev = si_dup(si->si_prev, param);
11424 nsi->si_next = si_dup(si->si_next, param);
11425 nsi->si_markoff = si->si_markoff;
11430 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
11431 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
11432 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
11433 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
11434 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
11435 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
11436 #define POPUV(ss,ix) ((ss)[--(ix)].any_uv)
11437 #define TOPUV(ss,ix) ((ss)[ix].any_uv)
11438 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
11439 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
11440 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
11441 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
11442 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
11443 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
11444 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11445 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11448 #define pv_dup_inc(p) SAVEPV(p)
11449 #define pv_dup(p) SAVEPV(p)
11450 #define svp_dup_inc(p,pp) any_dup(p,pp)
11452 /* map any object to the new equivent - either something in the
11453 * ptr table, or something in the interpreter structure
11457 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
11461 PERL_ARGS_ASSERT_ANY_DUP;
11464 return (void*)NULL;
11466 /* look for it in the table first */
11467 ret = ptr_table_fetch(PL_ptr_table, v);
11471 /* see if it is part of the interpreter structure */
11472 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11473 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11481 /* duplicate the save stack */
11484 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11487 ANY * const ss = proto_perl->Isavestack;
11488 const I32 max = proto_perl->Isavestack_max;
11489 I32 ix = proto_perl->Isavestack_ix;
11502 void (*dptr) (void*);
11503 void (*dxptr) (pTHX_ void*);
11505 PERL_ARGS_ASSERT_SS_DUP;
11507 Newxz(nss, max, ANY);
11510 const UV uv = POPUV(ss,ix);
11511 const U8 type = (U8)uv & SAVE_MASK;
11513 TOPUV(nss,ix) = uv;
11515 case SAVEt_CLEARSV:
11517 case SAVEt_HELEM: /* hash element */
11518 sv = (const SV *)POPPTR(ss,ix);
11519 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11521 case SAVEt_ITEM: /* normal string */
11522 case SAVEt_SV: /* scalar reference */
11523 sv = (const SV *)POPPTR(ss,ix);
11524 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11527 case SAVEt_MORTALIZESV:
11528 sv = (const SV *)POPPTR(ss,ix);
11529 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11531 case SAVEt_SHARED_PVREF: /* char* in shared space */
11532 c = (char*)POPPTR(ss,ix);
11533 TOPPTR(nss,ix) = savesharedpv(c);
11534 ptr = POPPTR(ss,ix);
11535 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11537 case SAVEt_GENERIC_SVREF: /* generic sv */
11538 case SAVEt_SVREF: /* scalar reference */
11539 sv = (const SV *)POPPTR(ss,ix);
11540 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11541 ptr = POPPTR(ss,ix);
11542 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11544 case SAVEt_HV: /* hash reference */
11545 case SAVEt_AV: /* array reference */
11546 sv = (const SV *) POPPTR(ss,ix);
11547 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11549 case SAVEt_COMPPAD:
11551 sv = (const SV *) POPPTR(ss,ix);
11552 TOPPTR(nss,ix) = sv_dup(sv, param);
11554 case SAVEt_INT: /* int reference */
11555 ptr = POPPTR(ss,ix);
11556 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11557 intval = (int)POPINT(ss,ix);
11558 TOPINT(nss,ix) = intval;
11560 case SAVEt_LONG: /* long reference */
11561 ptr = POPPTR(ss,ix);
11562 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11563 longval = (long)POPLONG(ss,ix);
11564 TOPLONG(nss,ix) = longval;
11566 case SAVEt_I32: /* I32 reference */
11567 case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
11568 ptr = POPPTR(ss,ix);
11569 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11571 TOPINT(nss,ix) = i;
11573 case SAVEt_IV: /* IV reference */
11574 ptr = POPPTR(ss,ix);
11575 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11577 TOPIV(nss,ix) = iv;
11579 case SAVEt_HPTR: /* HV* reference */
11580 case SAVEt_APTR: /* AV* reference */
11581 case SAVEt_SPTR: /* SV* reference */
11582 ptr = POPPTR(ss,ix);
11583 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11584 sv = (const SV *)POPPTR(ss,ix);
11585 TOPPTR(nss,ix) = sv_dup(sv, param);
11587 case SAVEt_VPTR: /* random* reference */
11588 ptr = POPPTR(ss,ix);
11589 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11591 case SAVEt_INT_SMALL:
11592 case SAVEt_I32_SMALL:
11593 case SAVEt_I16: /* I16 reference */
11594 case SAVEt_I8: /* I8 reference */
11596 ptr = POPPTR(ss,ix);
11597 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11599 case SAVEt_GENERIC_PVREF: /* generic char* */
11600 case SAVEt_PPTR: /* char* reference */
11601 ptr = POPPTR(ss,ix);
11602 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11603 c = (char*)POPPTR(ss,ix);
11604 TOPPTR(nss,ix) = pv_dup(c);
11606 case SAVEt_GP: /* scalar reference */
11607 gv = (const GV *)POPPTR(ss,ix);
11608 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11609 gp = (GP*)POPPTR(ss,ix);
11610 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11611 (void)GpREFCNT_inc(gp);
11613 TOPINT(nss,ix) = i;
11616 ptr = POPPTR(ss,ix);
11617 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11618 /* these are assumed to be refcounted properly */
11620 switch (((OP*)ptr)->op_type) {
11622 case OP_LEAVESUBLV:
11626 case OP_LEAVEWRITE:
11627 TOPPTR(nss,ix) = ptr;
11630 (void) OpREFCNT_inc(o);
11634 TOPPTR(nss,ix) = NULL;
11639 TOPPTR(nss,ix) = NULL;
11642 hv = (const HV *)POPPTR(ss,ix);
11643 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11645 TOPINT(nss,ix) = i;
11648 c = (char*)POPPTR(ss,ix);
11649 TOPPTR(nss,ix) = pv_dup_inc(c);
11651 case SAVEt_STACK_POS: /* Position on Perl stack */
11653 TOPINT(nss,ix) = i;
11655 case SAVEt_DESTRUCTOR:
11656 ptr = POPPTR(ss,ix);
11657 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11658 dptr = POPDPTR(ss,ix);
11659 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
11660 any_dup(FPTR2DPTR(void *, dptr),
11663 case SAVEt_DESTRUCTOR_X:
11664 ptr = POPPTR(ss,ix);
11665 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11666 dxptr = POPDXPTR(ss,ix);
11667 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
11668 any_dup(FPTR2DPTR(void *, dxptr),
11671 case SAVEt_REGCONTEXT:
11673 ix -= uv >> SAVE_TIGHT_SHIFT;
11675 case SAVEt_AELEM: /* array element */
11676 sv = (const SV *)POPPTR(ss,ix);
11677 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11679 TOPINT(nss,ix) = i;
11680 av = (const AV *)POPPTR(ss,ix);
11681 TOPPTR(nss,ix) = av_dup_inc(av, param);
11684 ptr = POPPTR(ss,ix);
11685 TOPPTR(nss,ix) = ptr;
11688 ptr = POPPTR(ss,ix);
11691 ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
11692 HINTS_REFCNT_UNLOCK;
11694 TOPPTR(nss,ix) = ptr;
11696 TOPINT(nss,ix) = i;
11697 if (i & HINT_LOCALIZE_HH) {
11698 hv = (const HV *)POPPTR(ss,ix);
11699 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11702 case SAVEt_PADSV_AND_MORTALIZE:
11703 longval = (long)POPLONG(ss,ix);
11704 TOPLONG(nss,ix) = longval;
11705 ptr = POPPTR(ss,ix);
11706 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11707 sv = (const SV *)POPPTR(ss,ix);
11708 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11710 case SAVEt_SET_SVFLAGS:
11712 TOPINT(nss,ix) = i;
11714 TOPINT(nss,ix) = i;
11715 sv = (const SV *)POPPTR(ss,ix);
11716 TOPPTR(nss,ix) = sv_dup(sv, param);
11718 case SAVEt_RE_STATE:
11720 const struct re_save_state *const old_state
11721 = (struct re_save_state *)
11722 (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11723 struct re_save_state *const new_state
11724 = (struct re_save_state *)
11725 (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11727 Copy(old_state, new_state, 1, struct re_save_state);
11728 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11730 new_state->re_state_bostr
11731 = pv_dup(old_state->re_state_bostr);
11732 new_state->re_state_reginput
11733 = pv_dup(old_state->re_state_reginput);
11734 new_state->re_state_regeol
11735 = pv_dup(old_state->re_state_regeol);
11736 new_state->re_state_regoffs
11737 = (regexp_paren_pair*)
11738 any_dup(old_state->re_state_regoffs, proto_perl);
11739 new_state->re_state_reglastparen
11740 = (U32*) any_dup(old_state->re_state_reglastparen,
11742 new_state->re_state_reglastcloseparen
11743 = (U32*)any_dup(old_state->re_state_reglastcloseparen,
11745 /* XXX This just has to be broken. The old save_re_context
11746 code did SAVEGENERICPV(PL_reg_start_tmp);
11747 PL_reg_start_tmp is char **.
11748 Look above to what the dup code does for
11749 SAVEt_GENERIC_PVREF
11750 It can never have worked.
11751 So this is merely a faithful copy of the exiting bug: */
11752 new_state->re_state_reg_start_tmp
11753 = (char **) pv_dup((char *)
11754 old_state->re_state_reg_start_tmp);
11755 /* I assume that it only ever "worked" because no-one called
11756 (pseudo)fork while the regexp engine had re-entered itself.
11758 #ifdef PERL_OLD_COPY_ON_WRITE
11759 new_state->re_state_nrs
11760 = sv_dup(old_state->re_state_nrs, param);
11762 new_state->re_state_reg_magic
11763 = (MAGIC*) any_dup(old_state->re_state_reg_magic,
11765 new_state->re_state_reg_oldcurpm
11766 = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
11768 new_state->re_state_reg_curpm
11769 = (PMOP*) any_dup(old_state->re_state_reg_curpm,
11771 new_state->re_state_reg_oldsaved
11772 = pv_dup(old_state->re_state_reg_oldsaved);
11773 new_state->re_state_reg_poscache
11774 = pv_dup(old_state->re_state_reg_poscache);
11775 new_state->re_state_reg_starttry
11776 = pv_dup(old_state->re_state_reg_starttry);
11779 case SAVEt_COMPILE_WARNINGS:
11780 ptr = POPPTR(ss,ix);
11781 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
11784 ptr = POPPTR(ss,ix);
11785 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
11789 "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
11797 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11798 * flag to the result. This is done for each stash before cloning starts,
11799 * so we know which stashes want their objects cloned */
11802 do_mark_cloneable_stash(pTHX_ SV *const sv)
11804 const HEK * const hvname = HvNAME_HEK((const HV *)sv);
11806 GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
11807 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11808 if (cloner && GvCV(cloner)) {
11815 mXPUSHs(newSVhek(hvname));
11817 call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
11824 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11832 =for apidoc perl_clone
11834 Create and return a new interpreter by cloning the current one.
11836 perl_clone takes these flags as parameters:
11838 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11839 without it we only clone the data and zero the stacks,
11840 with it we copy the stacks and the new perl interpreter is
11841 ready to run at the exact same point as the previous one.
11842 The pseudo-fork code uses COPY_STACKS while the
11843 threads->create doesn't.
11845 CLONEf_KEEP_PTR_TABLE
11846 perl_clone keeps a ptr_table with the pointer of the old
11847 variable as a key and the new variable as a value,
11848 this allows it to check if something has been cloned and not
11849 clone it again but rather just use the value and increase the
11850 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11851 the ptr_table using the function
11852 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11853 reason to keep it around is if you want to dup some of your own
11854 variable who are outside the graph perl scans, example of this
11855 code is in threads.xs create
11858 This is a win32 thing, it is ignored on unix, it tells perls
11859 win32host code (which is c++) to clone itself, this is needed on
11860 win32 if you want to run two threads at the same time,
11861 if you just want to do some stuff in a separate perl interpreter
11862 and then throw it away and return to the original one,
11863 you don't need to do anything.
11868 /* XXX the above needs expanding by someone who actually understands it ! */
11869 EXTERN_C PerlInterpreter *
11870 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11873 perl_clone(PerlInterpreter *proto_perl, UV flags)
11876 #ifdef PERL_IMPLICIT_SYS
11878 PERL_ARGS_ASSERT_PERL_CLONE;
11880 /* perlhost.h so we need to call into it
11881 to clone the host, CPerlHost should have a c interface, sky */
11883 if (flags & CLONEf_CLONE_HOST) {
11884 return perl_clone_host(proto_perl,flags);
11886 return perl_clone_using(proto_perl, flags,
11888 proto_perl->IMemShared,
11889 proto_perl->IMemParse,
11891 proto_perl->IStdIO,
11895 proto_perl->IProc);
11899 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11900 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11901 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11902 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11903 struct IPerlDir* ipD, struct IPerlSock* ipS,
11904 struct IPerlProc* ipP)
11906 /* XXX many of the string copies here can be optimized if they're
11907 * constants; they need to be allocated as common memory and just
11908 * their pointers copied. */
11911 CLONE_PARAMS clone_params;
11912 CLONE_PARAMS* const param = &clone_params;
11914 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11916 PERL_ARGS_ASSERT_PERL_CLONE_USING;
11917 #else /* !PERL_IMPLICIT_SYS */
11919 CLONE_PARAMS clone_params;
11920 CLONE_PARAMS* param = &clone_params;
11921 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11923 PERL_ARGS_ASSERT_PERL_CLONE;
11924 #endif /* PERL_IMPLICIT_SYS */
11926 /* for each stash, determine whether its objects should be cloned */
11927 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11928 PERL_SET_THX(my_perl);
11931 PoisonNew(my_perl, 1, PerlInterpreter);
11936 PL_scopestack_name = 0;
11938 PL_savestack_ix = 0;
11939 PL_savestack_max = -1;
11940 PL_sig_pending = 0;
11942 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11943 # ifdef DEBUG_LEAKING_SCALARS
11944 PL_sv_serial = (((U32)my_perl >> 2) & 0xfff) * 1000000;
11946 #else /* !DEBUGGING */
11947 Zero(my_perl, 1, PerlInterpreter);
11948 #endif /* DEBUGGING */
11950 #ifdef PERL_IMPLICIT_SYS
11951 /* host pointers */
11953 PL_MemShared = ipMS;
11954 PL_MemParse = ipMP;
11961 #endif /* PERL_IMPLICIT_SYS */
11963 param->flags = flags;
11964 param->proto_perl = proto_perl;
11966 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
11968 PL_body_arenas = NULL;
11969 Zero(&PL_body_roots, 1, PL_body_roots);
11971 PL_nice_chunk = NULL;
11972 PL_nice_chunk_size = 0;
11974 PL_sv_objcount = 0;
11976 PL_sv_arenaroot = NULL;
11978 PL_debug = proto_perl->Idebug;
11980 PL_hash_seed = proto_perl->Ihash_seed;
11981 PL_rehash_seed = proto_perl->Irehash_seed;
11983 #ifdef USE_REENTRANT_API
11984 /* XXX: things like -Dm will segfault here in perlio, but doing
11985 * PERL_SET_CONTEXT(proto_perl);
11986 * breaks too many other things
11988 Perl_reentrant_init(aTHX);
11991 /* create SV map for pointer relocation */
11992 PL_ptr_table = ptr_table_new();
11994 /* initialize these special pointers as early as possible */
11995 SvANY(&PL_sv_undef) = NULL;
11996 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11997 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11998 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
12000 SvANY(&PL_sv_no) = new_XPVNV();
12001 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
12002 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12003 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12004 SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
12005 SvCUR_set(&PL_sv_no, 0);
12006 SvLEN_set(&PL_sv_no, 1);
12007 SvIV_set(&PL_sv_no, 0);
12008 SvNV_set(&PL_sv_no, 0);
12009 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
12011 SvANY(&PL_sv_yes) = new_XPVNV();
12012 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
12013 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12014 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12015 SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
12016 SvCUR_set(&PL_sv_yes, 1);
12017 SvLEN_set(&PL_sv_yes, 2);
12018 SvIV_set(&PL_sv_yes, 1);
12019 SvNV_set(&PL_sv_yes, 1);
12020 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
12022 /* dbargs array probably holds garbage */
12025 /* create (a non-shared!) shared string table */
12026 PL_strtab = newHV();
12027 HvSHAREKEYS_off(PL_strtab);
12028 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
12029 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
12031 PL_compiling = proto_perl->Icompiling;
12033 /* These two PVs will be free'd special way so must set them same way op.c does */
12034 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
12035 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
12037 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
12038 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
12040 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
12041 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
12042 if (PL_compiling.cop_hints_hash) {
12044 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
12045 HINTS_REFCNT_UNLOCK;
12047 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
12048 #ifdef PERL_DEBUG_READONLY_OPS
12053 /* pseudo environmental stuff */
12054 PL_origargc = proto_perl->Iorigargc;
12055 PL_origargv = proto_perl->Iorigargv;
12057 param->stashes = newAV(); /* Setup array of objects to call clone on */
12059 /* Set tainting stuff before PerlIO_debug can possibly get called */
12060 PL_tainting = proto_perl->Itainting;
12061 PL_taint_warn = proto_perl->Itaint_warn;
12063 #ifdef PERLIO_LAYERS
12064 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
12065 PerlIO_clone(aTHX_ proto_perl, param);
12068 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
12069 PL_incgv = gv_dup(proto_perl->Iincgv, param);
12070 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
12071 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
12072 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
12073 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
12076 PL_minus_c = proto_perl->Iminus_c;
12077 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
12078 PL_localpatches = proto_perl->Ilocalpatches;
12079 PL_splitstr = proto_perl->Isplitstr;
12080 PL_minus_n = proto_perl->Iminus_n;
12081 PL_minus_p = proto_perl->Iminus_p;
12082 PL_minus_l = proto_perl->Iminus_l;
12083 PL_minus_a = proto_perl->Iminus_a;
12084 PL_minus_E = proto_perl->Iminus_E;
12085 PL_minus_F = proto_perl->Iminus_F;
12086 PL_doswitches = proto_perl->Idoswitches;
12087 PL_dowarn = proto_perl->Idowarn;
12088 PL_doextract = proto_perl->Idoextract;
12089 PL_sawampersand = proto_perl->Isawampersand;
12090 PL_unsafe = proto_perl->Iunsafe;
12091 PL_inplace = SAVEPV(proto_perl->Iinplace);
12092 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
12093 PL_perldb = proto_perl->Iperldb;
12094 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
12095 PL_exit_flags = proto_perl->Iexit_flags;
12097 /* magical thingies */
12098 /* XXX time(&PL_basetime) when asked for? */
12099 PL_basetime = proto_perl->Ibasetime;
12100 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
12102 PL_maxsysfd = proto_perl->Imaxsysfd;
12103 PL_statusvalue = proto_perl->Istatusvalue;
12105 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
12107 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
12109 PL_encoding = sv_dup(proto_perl->Iencoding, param);
12111 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
12112 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
12113 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
12116 /* RE engine related */
12117 Zero(&PL_reg_state, 1, struct re_save_state);
12118 PL_reginterp_cnt = 0;
12119 PL_regmatch_slab = NULL;
12121 /* Clone the regex array */
12122 /* ORANGE FIXME for plugins, probably in the SV dup code.
12123 newSViv(PTR2IV(CALLREGDUPE(
12124 INT2PTR(REGEXP *, SvIVX(regex)), param))))
12126 PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
12127 PL_regex_pad = AvARRAY(PL_regex_padav);
12129 /* shortcuts to various I/O objects */
12130 PL_ofsgv = gv_dup(proto_perl->Iofsgv, param);
12131 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
12132 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
12133 PL_defgv = gv_dup(proto_perl->Idefgv, param);
12134 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
12135 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
12136 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
12138 /* shortcuts to regexp stuff */
12139 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
12141 /* shortcuts to misc objects */
12142 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
12144 /* shortcuts to debugging objects */
12145 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
12146 PL_DBline = gv_dup(proto_perl->IDBline, param);
12147 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
12148 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
12149 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
12150 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
12152 /* symbol tables */
12153 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
12154 PL_curstash = hv_dup(proto_perl->Icurstash, param);
12155 PL_debstash = hv_dup(proto_perl->Idebstash, param);
12156 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
12157 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
12159 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
12160 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
12161 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
12162 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
12163 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
12164 PL_endav = av_dup_inc(proto_perl->Iendav, param);
12165 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
12166 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
12168 PL_sub_generation = proto_perl->Isub_generation;
12169 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
12171 /* funky return mechanisms */
12172 PL_forkprocess = proto_perl->Iforkprocess;
12174 /* subprocess state */
12175 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
12177 /* internal state */
12178 PL_maxo = proto_perl->Imaxo;
12179 if (proto_perl->Iop_mask)
12180 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
12183 /* PL_asserting = proto_perl->Iasserting; */
12185 /* current interpreter roots */
12186 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
12188 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
12190 PL_main_start = proto_perl->Imain_start;
12191 PL_eval_root = proto_perl->Ieval_root;
12192 PL_eval_start = proto_perl->Ieval_start;
12194 /* runtime control stuff */
12195 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
12197 PL_filemode = proto_perl->Ifilemode;
12198 PL_lastfd = proto_perl->Ilastfd;
12199 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
12202 PL_gensym = proto_perl->Igensym;
12203 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
12204 PL_laststatval = proto_perl->Ilaststatval;
12205 PL_laststype = proto_perl->Ilaststype;
12208 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
12210 /* interpreter atexit processing */
12211 PL_exitlistlen = proto_perl->Iexitlistlen;
12212 if (PL_exitlistlen) {
12213 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12214 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12217 PL_exitlist = (PerlExitListEntry*)NULL;
12219 PL_my_cxt_size = proto_perl->Imy_cxt_size;
12220 if (PL_my_cxt_size) {
12221 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
12222 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
12223 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12224 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
12225 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
12229 PL_my_cxt_list = (void**)NULL;
12230 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12231 PL_my_cxt_keys = (const char**)NULL;
12234 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
12235 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
12236 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
12238 PL_profiledata = NULL;
12240 PL_compcv = cv_dup(proto_perl->Icompcv, param);
12242 PAD_CLONE_VARS(proto_perl, param);
12244 #ifdef HAVE_INTERP_INTERN
12245 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
12248 /* more statics moved here */
12249 PL_generation = proto_perl->Igeneration;
12250 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
12252 PL_in_clean_objs = proto_perl->Iin_clean_objs;
12253 PL_in_clean_all = proto_perl->Iin_clean_all;
12255 PL_uid = proto_perl->Iuid;
12256 PL_euid = proto_perl->Ieuid;
12257 PL_gid = proto_perl->Igid;
12258 PL_egid = proto_perl->Iegid;
12259 PL_nomemok = proto_perl->Inomemok;
12260 PL_an = proto_perl->Ian;
12261 PL_evalseq = proto_perl->Ievalseq;
12262 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
12263 PL_origalen = proto_perl->Iorigalen;
12264 #ifdef PERL_USES_PL_PIDSTATUS
12265 PL_pidstatus = newHV(); /* XXX flag for cloning? */
12267 PL_osname = SAVEPV(proto_perl->Iosname);
12268 PL_sighandlerp = proto_perl->Isighandlerp;
12270 PL_runops = proto_perl->Irunops;
12272 PL_parser = parser_dup(proto_perl->Iparser, param);
12274 /* XXX this only works if the saved cop has already been cloned */
12275 if (proto_perl->Iparser) {
12276 PL_parser->saved_curcop = (COP*)any_dup(
12277 proto_perl->Iparser->saved_curcop,
12281 PL_subline = proto_perl->Isubline;
12282 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
12285 PL_cryptseen = proto_perl->Icryptseen;
12288 PL_hints = proto_perl->Ihints;
12290 PL_amagic_generation = proto_perl->Iamagic_generation;
12292 #ifdef USE_LOCALE_COLLATE
12293 PL_collation_ix = proto_perl->Icollation_ix;
12294 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
12295 PL_collation_standard = proto_perl->Icollation_standard;
12296 PL_collxfrm_base = proto_perl->Icollxfrm_base;
12297 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
12298 #endif /* USE_LOCALE_COLLATE */
12300 #ifdef USE_LOCALE_NUMERIC
12301 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
12302 PL_numeric_standard = proto_perl->Inumeric_standard;
12303 PL_numeric_local = proto_perl->Inumeric_local;
12304 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12305 #endif /* !USE_LOCALE_NUMERIC */
12307 /* utf8 character classes */
12308 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12309 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12310 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12311 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
12312 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12313 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
12314 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
12315 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
12316 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
12317 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
12318 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
12319 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12320 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
12321 PL_utf8_X_begin = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
12322 PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
12323 PL_utf8_X_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
12324 PL_utf8_X_non_hangul = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
12325 PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
12326 PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
12327 PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
12328 PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
12329 PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
12330 PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
12331 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12332 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12333 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12334 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12335 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12336 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12338 /* Did the locale setup indicate UTF-8? */
12339 PL_utf8locale = proto_perl->Iutf8locale;
12340 /* Unicode features (see perlrun/-C) */
12341 PL_unicode = proto_perl->Iunicode;
12343 /* Pre-5.8 signals control */
12344 PL_signals = proto_perl->Isignals;
12346 /* times() ticks per second */
12347 PL_clocktick = proto_perl->Iclocktick;
12349 /* Recursion stopper for PerlIO_find_layer */
12350 PL_in_load_module = proto_perl->Iin_load_module;
12352 /* sort() routine */
12353 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
12355 /* Not really needed/useful since the reenrant_retint is "volatile",
12356 * but do it for consistency's sake. */
12357 PL_reentrant_retint = proto_perl->Ireentrant_retint;
12359 /* Hooks to shared SVs and locks. */
12360 PL_sharehook = proto_perl->Isharehook;
12361 PL_lockhook = proto_perl->Ilockhook;
12362 PL_unlockhook = proto_perl->Iunlockhook;
12363 PL_threadhook = proto_perl->Ithreadhook;
12364 PL_destroyhook = proto_perl->Idestroyhook;
12366 #ifdef THREADS_HAVE_PIDS
12367 PL_ppid = proto_perl->Ippid;
12371 PL_last_swash_hv = NULL; /* reinits on demand */
12372 PL_last_swash_klen = 0;
12373 PL_last_swash_key[0]= '\0';
12374 PL_last_swash_tmps = (U8*)NULL;
12375 PL_last_swash_slen = 0;
12377 PL_glob_index = proto_perl->Iglob_index;
12378 PL_srand_called = proto_perl->Isrand_called;
12380 if (proto_perl->Ipsig_pend) {
12381 Newxz(PL_psig_pend, SIG_SIZE, int);
12384 PL_psig_pend = (int*)NULL;
12387 if (proto_perl->Ipsig_name) {
12388 Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
12389 sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
12391 PL_psig_ptr = PL_psig_name + SIG_SIZE;
12394 PL_psig_ptr = (SV**)NULL;
12395 PL_psig_name = (SV**)NULL;
12398 /* intrpvar.h stuff */
12400 if (flags & CLONEf_COPY_STACKS) {
12401 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12402 PL_tmps_ix = proto_perl->Itmps_ix;
12403 PL_tmps_max = proto_perl->Itmps_max;
12404 PL_tmps_floor = proto_perl->Itmps_floor;
12405 Newx(PL_tmps_stack, PL_tmps_max, SV*);
12406 sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
12407 PL_tmps_ix+1, param);
12409 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12410 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
12411 Newxz(PL_markstack, i, I32);
12412 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
12413 - proto_perl->Imarkstack);
12414 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
12415 - proto_perl->Imarkstack);
12416 Copy(proto_perl->Imarkstack, PL_markstack,
12417 PL_markstack_ptr - PL_markstack + 1, I32);
12419 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12420 * NOTE: unlike the others! */
12421 PL_scopestack_ix = proto_perl->Iscopestack_ix;
12422 PL_scopestack_max = proto_perl->Iscopestack_max;
12423 Newxz(PL_scopestack, PL_scopestack_max, I32);
12424 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
12427 Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
12428 Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
12430 /* NOTE: si_dup() looks at PL_markstack */
12431 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
12433 /* PL_curstack = PL_curstackinfo->si_stack; */
12434 PL_curstack = av_dup(proto_perl->Icurstack, param);
12435 PL_mainstack = av_dup(proto_perl->Imainstack, param);
12437 /* next PUSHs() etc. set *(PL_stack_sp+1) */
12438 PL_stack_base = AvARRAY(PL_curstack);
12439 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
12440 - proto_perl->Istack_base);
12441 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
12443 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12444 * NOTE: unlike the others! */
12445 PL_savestack_ix = proto_perl->Isavestack_ix;
12446 PL_savestack_max = proto_perl->Isavestack_max;
12447 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
12448 PL_savestack = ss_dup(proto_perl, param);
12452 ENTER; /* perl_destruct() wants to LEAVE; */
12454 /* although we're not duplicating the tmps stack, we should still
12455 * add entries for any SVs on the tmps stack that got cloned by a
12456 * non-refcount means (eg a temp in @_); otherwise they will be
12459 for (i = 0; i<= proto_perl->Itmps_ix; i++) {
12460 SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table,
12461 proto_perl->Itmps_stack[i]));
12462 if (nsv && !SvREFCNT(nsv)) {
12463 PUSH_EXTEND_MORTAL__SV_C(SvREFCNT_inc_simple(nsv));
12468 PL_start_env = proto_perl->Istart_env; /* XXXXXX */
12469 PL_top_env = &PL_start_env;
12471 PL_op = proto_perl->Iop;
12474 PL_Xpv = (XPV*)NULL;
12475 my_perl->Ina = proto_perl->Ina;
12477 PL_statbuf = proto_perl->Istatbuf;
12478 PL_statcache = proto_perl->Istatcache;
12479 PL_statgv = gv_dup(proto_perl->Istatgv, param);
12480 PL_statname = sv_dup_inc(proto_perl->Istatname, param);
12482 PL_timesbuf = proto_perl->Itimesbuf;
12485 PL_tainted = proto_perl->Itainted;
12486 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
12487 PL_rs = sv_dup_inc(proto_perl->Irs, param);
12488 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
12489 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
12490 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
12491 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
12492 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
12493 PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
12495 PL_restartjmpenv = proto_perl->Irestartjmpenv;
12496 PL_restartop = proto_perl->Irestartop;
12497 PL_in_eval = proto_perl->Iin_eval;
12498 PL_delaymagic = proto_perl->Idelaymagic;
12499 PL_dirty = proto_perl->Idirty;
12500 PL_localizing = proto_perl->Ilocalizing;
12502 PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
12503 PL_hv_fetch_ent_mh = NULL;
12504 PL_modcount = proto_perl->Imodcount;
12505 PL_lastgotoprobe = NULL;
12506 PL_dumpindent = proto_perl->Idumpindent;
12508 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
12509 PL_sortstash = hv_dup(proto_perl->Isortstash, param);
12510 PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
12511 PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
12512 PL_efloatbuf = NULL; /* reinits on demand */
12513 PL_efloatsize = 0; /* reinits on demand */
12517 PL_screamfirst = NULL;
12518 PL_screamnext = NULL;
12519 PL_maxscream = -1; /* reinits on demand */
12520 PL_lastscream = NULL;
12523 PL_regdummy = proto_perl->Iregdummy;
12524 PL_colorset = 0; /* reinits PL_colors[] */
12525 /*PL_colors[6] = {0,0,0,0,0,0};*/
12529 /* Pluggable optimizer */
12530 PL_peepp = proto_perl->Ipeepp;
12531 /* op_free() hook */
12532 PL_opfreehook = proto_perl->Iopfreehook;
12534 PL_stashcache = newHV();
12536 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
12537 proto_perl->Iwatchaddr);
12538 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
12539 if (PL_debug && PL_watchaddr) {
12540 PerlIO_printf(Perl_debug_log,
12541 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
12542 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
12543 PTR2UV(PL_watchok));
12546 PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
12548 /* Call the ->CLONE method, if it exists, for each of the stashes
12549 identified by sv_dup() above.
12551 while(av_len(param->stashes) != -1) {
12552 HV* const stash = MUTABLE_HV(av_shift(param->stashes));
12553 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12554 if (cloner && GvCV(cloner)) {
12559 mXPUSHs(newSVhek(HvNAME_HEK(stash)));
12561 call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
12567 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12568 ptr_table_free(PL_ptr_table);
12569 PL_ptr_table = NULL;
12573 SvREFCNT_dec(param->stashes);
12575 /* orphaned? eg threads->new inside BEGIN or use */
12576 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12577 SvREFCNT_inc_simple_void(PL_compcv);
12578 SAVEFREESV(PL_compcv);
12584 #endif /* USE_ITHREADS */
12587 =head1 Unicode Support
12589 =for apidoc sv_recode_to_utf8
12591 The encoding is assumed to be an Encode object, on entry the PV
12592 of the sv is assumed to be octets in that encoding, and the sv
12593 will be converted into Unicode (and UTF-8).
12595 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12596 is not a reference, nothing is done to the sv. If the encoding is not
12597 an C<Encode::XS> Encoding object, bad things will happen.
12598 (See F<lib/encoding.pm> and L<Encode>).
12600 The PV of the sv is returned.
12605 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12609 PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
12611 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12625 Passing sv_yes is wrong - it needs to be or'ed set of constants
12626 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12627 remove converted chars from source.
12629 Both will default the value - let them.
12631 XPUSHs(&PL_sv_yes);
12634 call_method("decode", G_SCALAR);
12638 s = SvPV_const(uni, len);
12639 if (s != SvPVX_const(sv)) {
12640 SvGROW(sv, len + 1);
12641 Move(s, SvPVX(sv), len + 1, char);
12642 SvCUR_set(sv, len);
12649 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12653 =for apidoc sv_cat_decode
12655 The encoding is assumed to be an Encode object, the PV of the ssv is
12656 assumed to be octets in that encoding and decoding the input starts
12657 from the position which (PV + *offset) pointed to. The dsv will be
12658 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12659 when the string tstr appears in decoding output or the input ends on
12660 the PV of the ssv. The value which the offset points will be modified
12661 to the last input position on the ssv.
12663 Returns TRUE if the terminator was found, else returns FALSE.
12668 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12669 SV *ssv, int *offset, char *tstr, int tlen)
12674 PERL_ARGS_ASSERT_SV_CAT_DECODE;
12676 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12687 offsv = newSViv(*offset);
12689 mXPUSHp(tstr, tlen);
12691 call_method("cat_decode", G_SCALAR);
12693 ret = SvTRUE(TOPs);
12694 *offset = SvIV(offsv);
12700 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12705 /* ---------------------------------------------------------------------
12707 * support functions for report_uninit()
12710 /* the maxiumum size of array or hash where we will scan looking
12711 * for the undefined element that triggered the warning */
12713 #define FUV_MAX_SEARCH_SIZE 1000
12715 /* Look for an entry in the hash whose value has the same SV as val;
12716 * If so, return a mortal copy of the key. */
12719 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
12722 register HE **array;
12725 PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
12727 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
12728 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
12731 array = HvARRAY(hv);
12733 for (i=HvMAX(hv); i>0; i--) {
12734 register HE *entry;
12735 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
12736 if (HeVAL(entry) != val)
12738 if ( HeVAL(entry) == &PL_sv_undef ||
12739 HeVAL(entry) == &PL_sv_placeholder)
12743 if (HeKLEN(entry) == HEf_SVKEY)
12744 return sv_mortalcopy(HeKEY_sv(entry));
12745 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
12751 /* Look for an entry in the array whose value has the same SV as val;
12752 * If so, return the index, otherwise return -1. */
12755 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
12759 PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
12761 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
12762 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
12765 if (val != &PL_sv_undef) {
12766 SV ** const svp = AvARRAY(av);
12769 for (i=AvFILLp(av); i>=0; i--)
12776 /* S_varname(): return the name of a variable, optionally with a subscript.
12777 * If gv is non-zero, use the name of that global, along with gvtype (one
12778 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
12779 * targ. Depending on the value of the subscript_type flag, return:
12782 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
12783 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
12784 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
12785 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
12788 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
12789 const SV *const keyname, I32 aindex, int subscript_type)
12792 SV * const name = sv_newmortal();
12795 buffer[0] = gvtype;
12798 /* as gv_fullname4(), but add literal '^' for $^FOO names */
12800 gv_fullname4(name, gv, buffer, 0);
12802 if ((unsigned int)SvPVX(name)[1] <= 26) {
12804 buffer[1] = SvPVX(name)[1] + 'A' - 1;
12806 /* Swap the 1 unprintable control character for the 2 byte pretty
12807 version - ie substr($name, 1, 1) = $buffer; */
12808 sv_insert(name, 1, 1, buffer, 2);
12812 CV * const cv = find_runcv(NULL);
12816 if (!cv || !CvPADLIST(cv))
12818 av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
12819 sv = *av_fetch(av, targ, FALSE);
12820 sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
12823 if (subscript_type == FUV_SUBSCRIPT_HASH) {
12824 SV * const sv = newSV(0);
12825 *SvPVX(name) = '$';
12826 Perl_sv_catpvf(aTHX_ name, "{%s}",
12827 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
12830 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
12831 *SvPVX(name) = '$';
12832 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
12834 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
12835 /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
12836 Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
12844 =for apidoc find_uninit_var
12846 Find the name of the undefined variable (if any) that caused the operator o
12847 to issue a "Use of uninitialized value" warning.
12848 If match is true, only return a name if it's value matches uninit_sv.
12849 So roughly speaking, if a unary operator (such as OP_COS) generates a
12850 warning, then following the direct child of the op may yield an
12851 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
12852 other hand, with OP_ADD there are two branches to follow, so we only print
12853 the variable name if we get an exact match.
12855 The name is returned as a mortal SV.
12857 Assumes that PL_op is the op that originally triggered the error, and that
12858 PL_comppad/PL_curpad points to the currently executing pad.
12864 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
12870 const OP *o, *o2, *kid;
12872 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
12873 uninit_sv == &PL_sv_placeholder)))
12876 switch (obase->op_type) {
12883 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
12884 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
12887 int subscript_type = FUV_SUBSCRIPT_WITHIN;
12889 if (pad) { /* @lex, %lex */
12890 sv = PAD_SVl(obase->op_targ);
12894 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
12895 /* @global, %global */
12896 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
12899 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
12901 else /* @{expr}, %{expr} */
12902 return find_uninit_var(cUNOPx(obase)->op_first,
12906 /* attempt to find a match within the aggregate */
12908 keysv = find_hash_subscript((const HV*)sv, uninit_sv);
12910 subscript_type = FUV_SUBSCRIPT_HASH;
12913 index = find_array_subscript((const AV *)sv, uninit_sv);
12915 subscript_type = FUV_SUBSCRIPT_ARRAY;
12918 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
12921 return varname(gv, hash ? '%' : '@', obase->op_targ,
12922 keysv, index, subscript_type);
12926 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
12928 return varname(NULL, '$', obase->op_targ,
12929 NULL, 0, FUV_SUBSCRIPT_NONE);
12932 gv = cGVOPx_gv(obase);
12933 if (!gv || (match && GvSV(gv) != uninit_sv))
12935 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
12938 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
12941 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
12942 if (!av || SvRMAGICAL(av))
12944 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12945 if (!svp || *svp != uninit_sv)
12948 return varname(NULL, '$', obase->op_targ,
12949 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12952 gv = cGVOPx_gv(obase);
12957 AV *const av = GvAV(gv);
12958 if (!av || SvRMAGICAL(av))
12960 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12961 if (!svp || *svp != uninit_sv)
12964 return varname(gv, '$', 0,
12965 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12970 o = cUNOPx(obase)->op_first;
12971 if (!o || o->op_type != OP_NULL ||
12972 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
12974 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
12978 if (PL_op == obase)
12979 /* $a[uninit_expr] or $h{uninit_expr} */
12980 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
12983 o = cBINOPx(obase)->op_first;
12984 kid = cBINOPx(obase)->op_last;
12986 /* get the av or hv, and optionally the gv */
12988 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
12989 sv = PAD_SV(o->op_targ);
12991 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
12992 && cUNOPo->op_first->op_type == OP_GV)
12994 gv = cGVOPx_gv(cUNOPo->op_first);
12998 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
13003 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
13004 /* index is constant */
13008 if (obase->op_type == OP_HELEM) {
13009 HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
13010 if (!he || HeVAL(he) != uninit_sv)
13014 SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
13015 if (!svp || *svp != uninit_sv)
13019 if (obase->op_type == OP_HELEM)
13020 return varname(gv, '%', o->op_targ,
13021 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
13023 return varname(gv, '@', o->op_targ, NULL,
13024 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
13027 /* index is an expression;
13028 * attempt to find a match within the aggregate */
13029 if (obase->op_type == OP_HELEM) {
13030 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13032 return varname(gv, '%', o->op_targ,
13033 keysv, 0, FUV_SUBSCRIPT_HASH);
13037 = find_array_subscript((const AV *)sv, uninit_sv);
13039 return varname(gv, '@', o->op_targ,
13040 NULL, index, FUV_SUBSCRIPT_ARRAY);
13045 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
13047 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
13052 /* only examine RHS */
13053 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
13056 o = cUNOPx(obase)->op_first;
13057 if (o->op_type == OP_PUSHMARK)
13060 if (!o->op_sibling) {
13061 /* one-arg version of open is highly magical */
13063 if (o->op_type == OP_GV) { /* open FOO; */
13065 if (match && GvSV(gv) != uninit_sv)
13067 return varname(gv, '$', 0,
13068 NULL, 0, FUV_SUBSCRIPT_NONE);
13070 /* other possibilities not handled are:
13071 * open $x; or open my $x; should return '${*$x}'
13072 * open expr; should return '$'.expr ideally
13078 /* ops where $_ may be an implicit arg */
13082 if ( !(obase->op_flags & OPf_STACKED)) {
13083 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
13084 ? PAD_SVl(obase->op_targ)
13087 sv = sv_newmortal();
13088 sv_setpvs(sv, "$_");
13097 match = 1; /* print etc can return undef on defined args */
13098 /* skip filehandle as it can't produce 'undef' warning */
13099 o = cUNOPx(obase)->op_first;
13100 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
13101 o = o->op_sibling->op_sibling;
13105 case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
13107 case OP_CUSTOM: /* XS or custom code could trigger random warnings */
13109 /* the following ops are capable of returning PL_sv_undef even for
13110 * defined arg(s) */
13129 case OP_GETPEERNAME:
13177 case OP_SMARTMATCH:
13186 /* XXX tmp hack: these two may call an XS sub, and currently
13187 XS subs don't have a SUB entry on the context stack, so CV and
13188 pad determination goes wrong, and BAD things happen. So, just
13189 don't try to determine the value under those circumstances.
13190 Need a better fix at dome point. DAPM 11/2007 */
13196 GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
13197 if (gv && GvSV(gv) == uninit_sv)
13198 return newSVpvs_flags("$.", SVs_TEMP);
13203 /* def-ness of rval pos() is independent of the def-ness of its arg */
13204 if ( !(obase->op_flags & OPf_MOD))
13209 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
13210 return newSVpvs_flags("${$/}", SVs_TEMP);
13215 if (!(obase->op_flags & OPf_KIDS))
13217 o = cUNOPx(obase)->op_first;
13223 /* if all except one arg are constant, or have no side-effects,
13224 * or are optimized away, then it's unambiguous */
13226 for (kid=o; kid; kid = kid->op_sibling) {
13228 const OPCODE type = kid->op_type;
13229 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
13230 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
13231 || (type == OP_PUSHMARK)
13235 if (o2) { /* more than one found */
13242 return find_uninit_var(o2, uninit_sv, match);
13244 /* scan all args */
13246 sv = find_uninit_var(o, uninit_sv, 1);
13258 =for apidoc report_uninit
13260 Print appropriate "Use of uninitialized variable" warning
13266 Perl_report_uninit(pTHX_ const SV *uninit_sv)
13270 SV* varname = NULL;
13272 varname = find_uninit_var(PL_op, uninit_sv,0);
13274 sv_insert(varname, 0, 0, " ", 1);
13276 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13277 varname ? SvPV_nolen_const(varname) : "",
13278 " in ", OP_DESC(PL_op));
13281 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13287 * c-indentation-style: bsd
13288 * c-basic-offset: 4
13289 * indent-tabs-mode: t
13292 * ex: set ts=8 sts=4 sw=4 noet: