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
692 5. pte arenas (thread related)
694 Arena types 2 & 3 are chained by body-type off an array of
695 arena-root pointers, which is indexed by svtype. Some of the
696 larger/less used body types are malloced singly, since a large
697 unused block of them is wasteful. Also, several svtypes dont have
698 bodies; the data fits into the sv-head itself. The arena-root
699 pointer thus has a few unused root-pointers (which may be hijacked
700 later for arena types 4,5)
702 3 differs from 2 as an optimization; some body types have several
703 unused fields in the front of the structure (which are kept in-place
704 for consistency). These bodies can be allocated in smaller chunks,
705 because the leading fields arent accessed. Pointers to such bodies
706 are decremented to point at the unused 'ghost' memory, knowing that
707 the pointers are used with offsets to the real memory.
709 HE, HEK arenas are managed separately, with separate code, but may
710 be merge-able later..
712 PTE arenas are not sv-bodies, but they share these mid-level
713 mechanics, so are considered here. The new mid-level mechanics rely
714 on the sv_type of the body being allocated, so we just reserve one
715 of the unused body-slots for PTEs, then use it in those (2) PTE
716 contexts below (line ~10k)
719 /* get_arena(size): this creates custom-sized arenas
720 TBD: export properly for hv.c: S_more_he().
723 Perl_get_arena(pTHX_ const size_t arena_size, const svtype bodytype)
726 struct arena_desc* adesc;
727 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
730 /* shouldnt need this
731 if (!arena_size) arena_size = PERL_ARENA_SIZE;
734 /* may need new arena-set to hold new arena */
735 if (!aroot || aroot->curr >= aroot->set_size) {
736 struct arena_set *newroot;
737 Newxz(newroot, 1, struct arena_set);
738 newroot->set_size = ARENAS_PER_SET;
739 newroot->next = aroot;
741 PL_body_arenas = (void *) newroot;
742 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
745 /* ok, now have arena-set with at least 1 empty/available arena-desc */
746 curr = aroot->curr++;
747 adesc = &(aroot->set[curr]);
748 assert(!adesc->arena);
750 Newx(adesc->arena, arena_size, char);
751 adesc->size = arena_size;
752 adesc->utype = bodytype;
753 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
754 curr, (void*)adesc->arena, (UV)arena_size));
760 /* return a thing to the free list */
762 #define del_body(thing, root) \
764 void ** const thing_copy = (void **)thing;\
765 *thing_copy = *root; \
766 *root = (void*)thing_copy; \
771 =head1 SV-Body Allocation
773 Allocation of SV-bodies is similar to SV-heads, differing as follows;
774 the allocation mechanism is used for many body types, so is somewhat
775 more complicated, it uses arena-sets, and has no need for still-live
778 At the outermost level, (new|del)_X*V macros return bodies of the
779 appropriate type. These macros call either (new|del)_body_type or
780 (new|del)_body_allocated macro pairs, depending on specifics of the
781 type. Most body types use the former pair, the latter pair is used to
782 allocate body types with "ghost fields".
784 "ghost fields" are fields that are unused in certain types, and
785 consequently don't need to actually exist. They are declared because
786 they're part of a "base type", which allows use of functions as
787 methods. The simplest examples are AVs and HVs, 2 aggregate types
788 which don't use the fields which support SCALAR semantics.
790 For these types, the arenas are carved up into appropriately sized
791 chunks, we thus avoid wasted memory for those unaccessed members.
792 When bodies are allocated, we adjust the pointer back in memory by the
793 size of the part not allocated, so it's as if we allocated the full
794 structure. (But things will all go boom if you write to the part that
795 is "not there", because you'll be overwriting the last members of the
796 preceding structure in memory.)
798 We calculate the correction using the STRUCT_OFFSET macro on the first
799 member present. If the allocated structure is smaller (no initial NV
800 actually allocated) then the net effect is to subtract the size of the NV
801 from the pointer, to return a new pointer as if an initial NV were actually
802 allocated. (We were using structures named *_allocated for this, but
803 this turned out to be a subtle bug, because a structure without an NV
804 could have a lower alignment constraint, but the compiler is allowed to
805 optimised accesses based on the alignment constraint of the actual pointer
806 to the full structure, for example, using a single 64 bit load instruction
807 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
809 This is the same trick as was used for NV and IV bodies. Ironically it
810 doesn't need to be used for NV bodies any more, because NV is now at
811 the start of the structure. IV bodies don't need it either, because
812 they are no longer allocated.
814 In turn, the new_body_* allocators call S_new_body(), which invokes
815 new_body_inline macro, which takes a lock, and takes a body off the
816 linked list at PL_body_roots[sv_type], calling S_more_bodies() if
817 necessary to refresh an empty list. Then the lock is released, and
818 the body is returned.
820 S_more_bodies calls get_arena(), and carves it up into an array of N
821 bodies, which it strings into a linked list. It looks up arena-size
822 and body-size from the body_details table described below, thus
823 supporting the multiple body-types.
825 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
826 the (new|del)_X*V macros are mapped directly to malloc/free.
832 For each sv-type, struct body_details bodies_by_type[] carries
833 parameters which control these aspects of SV handling:
835 Arena_size determines whether arenas are used for this body type, and if
836 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
837 zero, forcing individual mallocs and frees.
839 Body_size determines how big a body is, and therefore how many fit into
840 each arena. Offset carries the body-pointer adjustment needed for
841 "ghost fields", and is used in *_allocated macros.
843 But its main purpose is to parameterize info needed in
844 Perl_sv_upgrade(). The info here dramatically simplifies the function
845 vs the implementation in 5.8.8, making it table-driven. All fields
846 are used for this, except for arena_size.
848 For the sv-types that have no bodies, arenas are not used, so those
849 PL_body_roots[sv_type] are unused, and can be overloaded. In
850 something of a special case, SVt_NULL is borrowed for HE arenas;
851 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
852 bodies_by_type[SVt_NULL] slot is not used, as the table is not
855 PTEs also use arenas, but are never seen in Perl_sv_upgrade. Nonetheless,
856 they get their own slot in bodies_by_type[PTE_SVSLOT =SVt_IV], so they can
857 just use the same allocation semantics. At first, PTEs were also
858 overloaded to a non-body sv-type, but this yielded hard-to-find malloc
859 bugs, so was simplified by claiming a new slot. This choice has no
860 consequence at this time.
864 struct body_details {
865 U8 body_size; /* Size to allocate */
866 U8 copy; /* Size of structure to copy (may be shorter) */
868 unsigned int type : 4; /* We have space for a sanity check. */
869 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
870 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
871 unsigned int arena : 1; /* Allocated from an arena */
872 size_t arena_size; /* Size of arena to allocate */
880 /* With -DPURFIY we allocate everything directly, and don't use arenas.
881 This seems a rather elegant way to simplify some of the code below. */
882 #define HASARENA FALSE
884 #define HASARENA TRUE
886 #define NOARENA FALSE
888 /* Size the arenas to exactly fit a given number of bodies. A count
889 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
890 simplifying the default. If count > 0, the arena is sized to fit
891 only that many bodies, allowing arenas to be used for large, rare
892 bodies (XPVFM, XPVIO) without undue waste. The arena size is
893 limited by PERL_ARENA_SIZE, so we can safely oversize the
896 #define FIT_ARENA0(body_size) \
897 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
898 #define FIT_ARENAn(count,body_size) \
899 ( count * body_size <= PERL_ARENA_SIZE) \
900 ? count * body_size \
901 : FIT_ARENA0 (body_size)
902 #define FIT_ARENA(count,body_size) \
904 ? FIT_ARENAn (count, body_size) \
905 : FIT_ARENA0 (body_size)
907 /* Calculate the length to copy. Specifically work out the length less any
908 final padding the compiler needed to add. See the comment in sv_upgrade
909 for why copying the padding proved to be a bug. */
911 #define copy_length(type, last_member) \
912 STRUCT_OFFSET(type, last_member) \
913 + sizeof (((type*)SvANY((const SV *)0))->last_member)
915 static const struct body_details bodies_by_type[] = {
916 { sizeof(HE), 0, 0, SVt_NULL,
917 FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
919 /* The bind placeholder pretends to be an RV for now.
920 Also it's marked as "can't upgrade" to stop anyone using it before it's
922 { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
924 /* IVs are in the head, so the allocation size is 0.
925 However, the slot is overloaded for PTEs. */
926 { sizeof(struct ptr_tbl_ent), /* This is used for PTEs. */
927 sizeof(IV), /* This is used to copy out the IV body. */
928 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
929 NOARENA /* IVS don't need an arena */,
930 /* But PTEs need to know the size of their arena */
931 FIT_ARENA(0, sizeof(struct ptr_tbl_ent))
934 /* 8 bytes on most ILP32 with IEEE doubles */
935 { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA,
936 FIT_ARENA(0, sizeof(NV)) },
938 /* 8 bytes on most ILP32 with IEEE doubles */
939 { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
940 copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
941 + STRUCT_OFFSET(XPV, xpv_cur),
942 SVt_PV, FALSE, NONV, HASARENA,
943 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
946 { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
947 copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
948 + STRUCT_OFFSET(XPVIV, xpv_cur),
949 SVt_PVIV, FALSE, NONV, HASARENA,
950 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
953 { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV,
954 HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
957 { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
958 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
961 { sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur),
962 sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur),
963 + STRUCT_OFFSET(regexp, xpv_cur),
964 SVt_REGEXP, FALSE, NONV, HASARENA,
965 FIT_ARENA(0, sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur))
969 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
970 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
973 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
974 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
976 { sizeof(XPVAV) - STRUCT_OFFSET(XPVAV, xav_fill),
977 copy_length(XPVAV, xmg_stash) - STRUCT_OFFSET(XPVAV, xav_fill),
978 + STRUCT_OFFSET(XPVAV, xav_fill),
979 SVt_PVAV, TRUE, NONV, HASARENA,
980 FIT_ARENA(0, sizeof(XPVAV) - STRUCT_OFFSET(XPVAV, xav_fill)) },
982 { sizeof(XPVHV) - STRUCT_OFFSET(XPVHV, xhv_fill),
983 copy_length(XPVHV, xmg_stash) - STRUCT_OFFSET(XPVHV, xhv_fill),
984 + STRUCT_OFFSET(XPVHV, xhv_fill),
985 SVt_PVHV, TRUE, NONV, HASARENA,
986 FIT_ARENA(0, sizeof(XPVHV) - STRUCT_OFFSET(XPVHV, xhv_fill)) },
989 { sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur),
990 sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur),
991 + STRUCT_OFFSET(XPVCV, xpv_cur),
992 SVt_PVCV, TRUE, NONV, HASARENA,
993 FIT_ARENA(0, sizeof(XPVCV) - STRUCT_OFFSET(XPVCV, xpv_cur)) },
995 { sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur),
996 sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur),
997 + STRUCT_OFFSET(XPVFM, xpv_cur),
998 SVt_PVFM, TRUE, NONV, NOARENA,
999 FIT_ARENA(20, sizeof(XPVFM) - STRUCT_OFFSET(XPVFM, xpv_cur)) },
1001 /* XPVIO is 84 bytes, fits 48x */
1002 { sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur),
1003 sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur),
1004 + STRUCT_OFFSET(XPVIO, xpv_cur),
1005 SVt_PVIO, TRUE, NONV, HASARENA,
1006 FIT_ARENA(24, sizeof(XPVIO) - STRUCT_OFFSET(XPVIO, xpv_cur)) },
1009 #define new_body_type(sv_type) \
1010 (void *)((char *)S_new_body(aTHX_ sv_type))
1012 #define del_body_type(p, sv_type) \
1013 del_body(p, &PL_body_roots[sv_type])
1016 #define new_body_allocated(sv_type) \
1017 (void *)((char *)S_new_body(aTHX_ sv_type) \
1018 - bodies_by_type[sv_type].offset)
1020 #define del_body_allocated(p, sv_type) \
1021 del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
1024 #define my_safemalloc(s) (void*)safemalloc(s)
1025 #define my_safecalloc(s) (void*)safecalloc(s, 1)
1026 #define my_safefree(p) safefree((char*)p)
1030 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1031 #define del_XNV(p) my_safefree(p)
1033 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1034 #define del_XPVNV(p) my_safefree(p)
1036 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1037 #define del_XPVAV(p) my_safefree(p)
1039 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1040 #define del_XPVHV(p) my_safefree(p)
1042 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1043 #define del_XPVMG(p) my_safefree(p)
1045 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1046 #define del_XPVGV(p) my_safefree(p)
1050 #define new_XNV() new_body_type(SVt_NV)
1051 #define del_XNV(p) del_body_type(p, SVt_NV)
1053 #define new_XPVNV() new_body_type(SVt_PVNV)
1054 #define del_XPVNV(p) del_body_type(p, SVt_PVNV)
1056 #define new_XPVAV() new_body_allocated(SVt_PVAV)
1057 #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
1059 #define new_XPVHV() new_body_allocated(SVt_PVHV)
1060 #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
1062 #define new_XPVMG() new_body_type(SVt_PVMG)
1063 #define del_XPVMG(p) del_body_type(p, SVt_PVMG)
1065 #define new_XPVGV() new_body_type(SVt_PVGV)
1066 #define del_XPVGV(p) del_body_type(p, SVt_PVGV)
1070 /* no arena for you! */
1072 #define new_NOARENA(details) \
1073 my_safemalloc((details)->body_size + (details)->offset)
1074 #define new_NOARENAZ(details) \
1075 my_safecalloc((details)->body_size + (details)->offset)
1078 S_more_bodies (pTHX_ const svtype sv_type)
1081 void ** const root = &PL_body_roots[sv_type];
1082 const struct body_details * const bdp = &bodies_by_type[sv_type];
1083 const size_t body_size = bdp->body_size;
1086 const size_t arena_size = Perl_malloc_good_size(bdp->arena_size);
1087 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1088 static bool done_sanity_check;
1090 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1091 * variables like done_sanity_check. */
1092 if (!done_sanity_check) {
1093 unsigned int i = SVt_LAST;
1095 done_sanity_check = TRUE;
1098 assert (bodies_by_type[i].type == i);
1102 assert(bdp->arena_size);
1104 start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type);
1106 end = start + arena_size - 2 * body_size;
1108 /* computed count doesnt reflect the 1st slot reservation */
1109 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1110 DEBUG_m(PerlIO_printf(Perl_debug_log,
1111 "arena %p end %p arena-size %d (from %d) type %d "
1113 (void*)start, (void*)end, (int)arena_size,
1114 (int)bdp->arena_size, sv_type, (int)body_size,
1115 (int)arena_size / (int)body_size));
1117 DEBUG_m(PerlIO_printf(Perl_debug_log,
1118 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1119 (void*)start, (void*)end,
1120 (int)bdp->arena_size, sv_type, (int)body_size,
1121 (int)bdp->arena_size / (int)body_size));
1123 *root = (void *)start;
1125 while (start <= end) {
1126 char * const next = start + body_size;
1127 *(void**) start = (void *)next;
1130 *(void **)start = 0;
1135 /* grab a new thing from the free list, allocating more if necessary.
1136 The inline version is used for speed in hot routines, and the
1137 function using it serves the rest (unless PURIFY).
1139 #define new_body_inline(xpv, sv_type) \
1141 void ** const r3wt = &PL_body_roots[sv_type]; \
1142 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1143 ? *((void **)(r3wt)) : more_bodies(sv_type)); \
1144 *(r3wt) = *(void**)(xpv); \
1150 S_new_body(pTHX_ const svtype sv_type)
1154 new_body_inline(xpv, sv_type);
1160 static const struct body_details fake_rv =
1161 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1164 =for apidoc sv_upgrade
1166 Upgrade an SV to a more complex form. Generally adds a new body type to the
1167 SV, then copies across as much information as possible from the old body.
1168 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1174 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1179 const svtype old_type = SvTYPE(sv);
1180 const struct body_details *new_type_details;
1181 const struct body_details *old_type_details
1182 = bodies_by_type + old_type;
1183 SV *referant = NULL;
1185 PERL_ARGS_ASSERT_SV_UPGRADE;
1187 if (old_type == new_type)
1190 /* This clause was purposefully added ahead of the early return above to
1191 the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1192 inference by Nick I-S that it would fix other troublesome cases. See
1193 changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1195 Given that shared hash key scalars are no longer PVIV, but PV, there is
1196 no longer need to unshare so as to free up the IVX slot for its proper
1197 purpose. So it's safe to move the early return earlier. */
1199 if (new_type != SVt_PV && SvIsCOW(sv)) {
1200 sv_force_normal_flags(sv, 0);
1203 old_body = SvANY(sv);
1205 /* Copying structures onto other structures that have been neatly zeroed
1206 has a subtle gotcha. Consider XPVMG
1208 +------+------+------+------+------+-------+-------+
1209 | NV | CUR | LEN | IV | MAGIC | STASH |
1210 +------+------+------+------+------+-------+-------+
1211 0 4 8 12 16 20 24 28
1213 where NVs are aligned to 8 bytes, so that sizeof that structure is
1214 actually 32 bytes long, with 4 bytes of padding at the end:
1216 +------+------+------+------+------+-------+-------+------+
1217 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1218 +------+------+------+------+------+-------+-------+------+
1219 0 4 8 12 16 20 24 28 32
1221 so what happens if you allocate memory for this structure:
1223 +------+------+------+------+------+-------+-------+------+------+...
1224 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1225 +------+------+------+------+------+-------+-------+------+------+...
1226 0 4 8 12 16 20 24 28 32 36
1228 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1229 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1230 started out as zero once, but it's quite possible that it isn't. So now,
1231 rather than a nicely zeroed GP, you have it pointing somewhere random.
1234 (In fact, GP ends up pointing at a previous GP structure, because the
1235 principle cause of the padding in XPVMG getting garbage is a copy of
1236 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1237 this happens to be moot because XPVGV has been re-ordered, with GP
1238 no longer after STASH)
1240 So we are careful and work out the size of used parts of all the
1248 referant = SvRV(sv);
1249 old_type_details = &fake_rv;
1250 if (new_type == SVt_NV)
1251 new_type = SVt_PVNV;
1253 if (new_type < SVt_PVIV) {
1254 new_type = (new_type == SVt_NV)
1255 ? SVt_PVNV : SVt_PVIV;
1260 if (new_type < SVt_PVNV) {
1261 new_type = SVt_PVNV;
1265 assert(new_type > SVt_PV);
1266 assert(SVt_IV < SVt_PV);
1267 assert(SVt_NV < SVt_PV);
1274 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1275 there's no way that it can be safely upgraded, because perl.c
1276 expects to Safefree(SvANY(PL_mess_sv)) */
1277 assert(sv != PL_mess_sv);
1278 /* This flag bit is used to mean other things in other scalar types.
1279 Given that it only has meaning inside the pad, it shouldn't be set
1280 on anything that can get upgraded. */
1281 assert(!SvPAD_TYPED(sv));
1284 if (old_type_details->cant_upgrade)
1285 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1286 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1289 if (old_type > new_type)
1290 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1291 (int)old_type, (int)new_type);
1293 new_type_details = bodies_by_type + new_type;
1295 SvFLAGS(sv) &= ~SVTYPEMASK;
1296 SvFLAGS(sv) |= new_type;
1298 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1299 the return statements above will have triggered. */
1300 assert (new_type != SVt_NULL);
1303 assert(old_type == SVt_NULL);
1304 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1308 assert(old_type == SVt_NULL);
1309 SvANY(sv) = new_XNV();
1314 assert(new_type_details->body_size);
1317 assert(new_type_details->arena);
1318 assert(new_type_details->arena_size);
1319 /* This points to the start of the allocated area. */
1320 new_body_inline(new_body, new_type);
1321 Zero(new_body, new_type_details->body_size, char);
1322 new_body = ((char *)new_body) - new_type_details->offset;
1324 /* We always allocated the full length item with PURIFY. To do this
1325 we fake things so that arena is false for all 16 types.. */
1326 new_body = new_NOARENAZ(new_type_details);
1328 SvANY(sv) = new_body;
1329 if (new_type == SVt_PVAV) {
1333 if (old_type_details->body_size) {
1336 /* It will have been zeroed when the new body was allocated.
1337 Lets not write to it, in case it confuses a write-back
1343 #ifndef NODEFAULT_SHAREKEYS
1344 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1346 HvMAX(sv) = 7; /* (start with 8 buckets) */
1347 if (old_type_details->body_size) {
1350 /* It will have been zeroed when the new body was allocated.
1351 Lets not write to it, in case it confuses a write-back
1356 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1357 The target created by newSVrv also is, and it can have magic.
1358 However, it never has SvPVX set.
1360 if (old_type == SVt_IV) {
1362 } else if (old_type >= SVt_PV) {
1363 assert(SvPVX_const(sv) == 0);
1366 if (old_type >= SVt_PVMG) {
1367 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1368 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1370 sv->sv_u.svu_array = NULL; /* or svu_hash */
1376 /* This ensures that SvTHINKFIRST(sv) is true, and hence that
1377 sv_force_normal_flags(sv) is called. */
1380 /* XXX Is this still needed? Was it ever needed? Surely as there is
1381 no route from NV to PVIV, NOK can never be true */
1382 assert(!SvNOKp(sv));
1393 assert(new_type_details->body_size);
1394 /* We always allocated the full length item with PURIFY. To do this
1395 we fake things so that arena is false for all 16 types.. */
1396 if(new_type_details->arena) {
1397 /* This points to the start of the allocated area. */
1398 new_body_inline(new_body, new_type);
1399 Zero(new_body, new_type_details->body_size, char);
1400 new_body = ((char *)new_body) - new_type_details->offset;
1402 new_body = new_NOARENAZ(new_type_details);
1404 SvANY(sv) = new_body;
1406 if (old_type_details->copy) {
1407 /* There is now the potential for an upgrade from something without
1408 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1409 int offset = old_type_details->offset;
1410 int length = old_type_details->copy;
1412 if (new_type_details->offset > old_type_details->offset) {
1413 const int difference
1414 = new_type_details->offset - old_type_details->offset;
1415 offset += difference;
1416 length -= difference;
1418 assert (length >= 0);
1420 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1424 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1425 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1426 * correct 0.0 for us. Otherwise, if the old body didn't have an
1427 * NV slot, but the new one does, then we need to initialise the
1428 * freshly created NV slot with whatever the correct bit pattern is
1430 if (old_type_details->zero_nv && !new_type_details->zero_nv
1431 && !isGV_with_GP(sv))
1435 if (new_type == SVt_PVIO) {
1436 IO * const io = MUTABLE_IO(sv);
1437 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1440 /* Clear the stashcache because a new IO could overrule a package
1442 hv_clear(PL_stashcache);
1444 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1445 IoPAGE_LEN(sv) = 60;
1447 if (old_type < SVt_PV) {
1448 /* referant will be NULL unless the old type was SVt_IV emulating
1450 sv->sv_u.svu_rv = referant;
1454 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1455 (unsigned long)new_type);
1458 if (old_type > SVt_IV) { /* SVt_IVs are overloaded for PTEs */
1460 my_safefree(old_body);
1462 /* Note that there is an assumption that all bodies of types that
1463 can be upgraded came from arenas. Only the more complex non-
1464 upgradable types are allowed to be directly malloc()ed. */
1465 assert(old_type_details->arena);
1466 del_body((void*)((char*)old_body + old_type_details->offset),
1467 &PL_body_roots[old_type]);
1473 =for apidoc sv_backoff
1475 Remove any string offset. You should normally use the C<SvOOK_off> macro
1482 Perl_sv_backoff(pTHX_ register SV *const sv)
1485 const char * const s = SvPVX_const(sv);
1487 PERL_ARGS_ASSERT_SV_BACKOFF;
1488 PERL_UNUSED_CONTEXT;
1491 assert(SvTYPE(sv) != SVt_PVHV);
1492 assert(SvTYPE(sv) != SVt_PVAV);
1494 SvOOK_offset(sv, delta);
1496 SvLEN_set(sv, SvLEN(sv) + delta);
1497 SvPV_set(sv, SvPVX(sv) - delta);
1498 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1499 SvFLAGS(sv) &= ~SVf_OOK;
1506 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1507 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1508 Use the C<SvGROW> wrapper instead.
1514 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1518 PERL_ARGS_ASSERT_SV_GROW;
1520 if (PL_madskills && newlen >= 0x100000) {
1521 PerlIO_printf(Perl_debug_log,
1522 "Allocation too large: %"UVxf"\n", (UV)newlen);
1524 #ifdef HAS_64K_LIMIT
1525 if (newlen >= 0x10000) {
1526 PerlIO_printf(Perl_debug_log,
1527 "Allocation too large: %"UVxf"\n", (UV)newlen);
1530 #endif /* HAS_64K_LIMIT */
1533 if (SvTYPE(sv) < SVt_PV) {
1534 sv_upgrade(sv, SVt_PV);
1535 s = SvPVX_mutable(sv);
1537 else if (SvOOK(sv)) { /* pv is offset? */
1539 s = SvPVX_mutable(sv);
1540 if (newlen > SvLEN(sv))
1541 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1542 #ifdef HAS_64K_LIMIT
1543 if (newlen >= 0x10000)
1548 s = SvPVX_mutable(sv);
1550 if (newlen > SvLEN(sv)) { /* need more room? */
1551 #ifndef Perl_safesysmalloc_size
1552 newlen = PERL_STRLEN_ROUNDUP(newlen);
1554 if (SvLEN(sv) && s) {
1555 s = (char*)saferealloc(s, newlen);
1558 s = (char*)safemalloc(newlen);
1559 if (SvPVX_const(sv) && SvCUR(sv)) {
1560 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1564 #ifdef Perl_safesysmalloc_size
1565 /* Do this here, do it once, do it right, and then we will never get
1566 called back into sv_grow() unless there really is some growing
1568 SvLEN_set(sv, Perl_safesysmalloc_size(s));
1570 SvLEN_set(sv, newlen);
1577 =for apidoc sv_setiv
1579 Copies an integer into the given SV, upgrading first if necessary.
1580 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1586 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1590 PERL_ARGS_ASSERT_SV_SETIV;
1592 SV_CHECK_THINKFIRST_COW_DROP(sv);
1593 switch (SvTYPE(sv)) {
1596 sv_upgrade(sv, SVt_IV);
1599 sv_upgrade(sv, SVt_PVIV);
1603 if (!isGV_with_GP(sv))
1610 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1614 (void)SvIOK_only(sv); /* validate number */
1620 =for apidoc sv_setiv_mg
1622 Like C<sv_setiv>, but also handles 'set' magic.
1628 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1630 PERL_ARGS_ASSERT_SV_SETIV_MG;
1637 =for apidoc sv_setuv
1639 Copies an unsigned integer into the given SV, upgrading first if necessary.
1640 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1646 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1648 PERL_ARGS_ASSERT_SV_SETUV;
1650 /* With these two if statements:
1651 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1654 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1656 If you wish to remove them, please benchmark to see what the effect is
1658 if (u <= (UV)IV_MAX) {
1659 sv_setiv(sv, (IV)u);
1668 =for apidoc sv_setuv_mg
1670 Like C<sv_setuv>, but also handles 'set' magic.
1676 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1678 PERL_ARGS_ASSERT_SV_SETUV_MG;
1685 =for apidoc sv_setnv
1687 Copies a double into the given SV, upgrading first if necessary.
1688 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1694 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1698 PERL_ARGS_ASSERT_SV_SETNV;
1700 SV_CHECK_THINKFIRST_COW_DROP(sv);
1701 switch (SvTYPE(sv)) {
1704 sv_upgrade(sv, SVt_NV);
1708 sv_upgrade(sv, SVt_PVNV);
1712 if (!isGV_with_GP(sv))
1719 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1724 (void)SvNOK_only(sv); /* validate number */
1729 =for apidoc sv_setnv_mg
1731 Like C<sv_setnv>, but also handles 'set' magic.
1737 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1739 PERL_ARGS_ASSERT_SV_SETNV_MG;
1745 /* Print an "isn't numeric" warning, using a cleaned-up,
1746 * printable version of the offending string
1750 S_not_a_number(pTHX_ SV *const sv)
1757 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1760 dsv = newSVpvs_flags("", SVs_TEMP);
1761 pv = sv_uni_display(dsv, sv, 10, 0);
1764 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1765 /* each *s can expand to 4 chars + "...\0",
1766 i.e. need room for 8 chars */
1768 const char *s = SvPVX_const(sv);
1769 const char * const end = s + SvCUR(sv);
1770 for ( ; s < end && d < limit; s++ ) {
1772 if (ch & 128 && !isPRINT_LC(ch)) {
1781 else if (ch == '\r') {
1785 else if (ch == '\f') {
1789 else if (ch == '\\') {
1793 else if (ch == '\0') {
1797 else if (isPRINT_LC(ch))
1814 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1815 "Argument \"%s\" isn't numeric in %s", pv,
1818 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1819 "Argument \"%s\" isn't numeric", pv);
1823 =for apidoc looks_like_number
1825 Test if the content of an SV looks like a number (or is a number).
1826 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1827 non-numeric warning), even if your atof() doesn't grok them.
1833 Perl_looks_like_number(pTHX_ SV *const sv)
1835 register const char *sbegin;
1838 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1841 sbegin = SvPVX_const(sv);
1844 else if (SvPOKp(sv))
1845 sbegin = SvPV_const(sv, len);
1847 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1848 return grok_number(sbegin, len, NULL);
1852 S_glob_2number(pTHX_ GV * const gv)
1854 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1855 SV *const buffer = sv_newmortal();
1857 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1859 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1862 gv_efullname3(buffer, gv, "*");
1863 SvFLAGS(gv) |= wasfake;
1865 /* We know that all GVs stringify to something that is not-a-number,
1866 so no need to test that. */
1867 if (ckWARN(WARN_NUMERIC))
1868 not_a_number(buffer);
1869 /* We just want something true to return, so that S_sv_2iuv_common
1870 can tail call us and return true. */
1874 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1875 until proven guilty, assume that things are not that bad... */
1880 As 64 bit platforms often have an NV that doesn't preserve all bits of
1881 an IV (an assumption perl has been based on to date) it becomes necessary
1882 to remove the assumption that the NV always carries enough precision to
1883 recreate the IV whenever needed, and that the NV is the canonical form.
1884 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1885 precision as a side effect of conversion (which would lead to insanity
1886 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1887 1) to distinguish between IV/UV/NV slots that have cached a valid
1888 conversion where precision was lost and IV/UV/NV slots that have a
1889 valid conversion which has lost no precision
1890 2) to ensure that if a numeric conversion to one form is requested that
1891 would lose precision, the precise conversion (or differently
1892 imprecise conversion) is also performed and cached, to prevent
1893 requests for different numeric formats on the same SV causing
1894 lossy conversion chains. (lossless conversion chains are perfectly
1899 SvIOKp is true if the IV slot contains a valid value
1900 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1901 SvNOKp is true if the NV slot contains a valid value
1902 SvNOK is true only if the NV value is accurate
1905 while converting from PV to NV, check to see if converting that NV to an
1906 IV(or UV) would lose accuracy over a direct conversion from PV to
1907 IV(or UV). If it would, cache both conversions, return NV, but mark
1908 SV as IOK NOKp (ie not NOK).
1910 While converting from PV to IV, check to see if converting that IV to an
1911 NV would lose accuracy over a direct conversion from PV to NV. If it
1912 would, cache both conversions, flag similarly.
1914 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1915 correctly because if IV & NV were set NV *always* overruled.
1916 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1917 changes - now IV and NV together means that the two are interchangeable:
1918 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1920 The benefit of this is that operations such as pp_add know that if
1921 SvIOK is true for both left and right operands, then integer addition
1922 can be used instead of floating point (for cases where the result won't
1923 overflow). Before, floating point was always used, which could lead to
1924 loss of precision compared with integer addition.
1926 * making IV and NV equal status should make maths accurate on 64 bit
1928 * may speed up maths somewhat if pp_add and friends start to use
1929 integers when possible instead of fp. (Hopefully the overhead in
1930 looking for SvIOK and checking for overflow will not outweigh the
1931 fp to integer speedup)
1932 * will slow down integer operations (callers of SvIV) on "inaccurate"
1933 values, as the change from SvIOK to SvIOKp will cause a call into
1934 sv_2iv each time rather than a macro access direct to the IV slot
1935 * should speed up number->string conversion on integers as IV is
1936 favoured when IV and NV are equally accurate
1938 ####################################################################
1939 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1940 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1941 On the other hand, SvUOK is true iff UV.
1942 ####################################################################
1944 Your mileage will vary depending your CPU's relative fp to integer
1948 #ifndef NV_PRESERVES_UV
1949 # define IS_NUMBER_UNDERFLOW_IV 1
1950 # define IS_NUMBER_UNDERFLOW_UV 2
1951 # define IS_NUMBER_IV_AND_UV 2
1952 # define IS_NUMBER_OVERFLOW_IV 4
1953 # define IS_NUMBER_OVERFLOW_UV 5
1955 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1957 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1959 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1967 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1969 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));
1970 if (SvNVX(sv) < (NV)IV_MIN) {
1971 (void)SvIOKp_on(sv);
1973 SvIV_set(sv, IV_MIN);
1974 return IS_NUMBER_UNDERFLOW_IV;
1976 if (SvNVX(sv) > (NV)UV_MAX) {
1977 (void)SvIOKp_on(sv);
1980 SvUV_set(sv, UV_MAX);
1981 return IS_NUMBER_OVERFLOW_UV;
1983 (void)SvIOKp_on(sv);
1985 /* Can't use strtol etc to convert this string. (See truth table in
1987 if (SvNVX(sv) <= (UV)IV_MAX) {
1988 SvIV_set(sv, I_V(SvNVX(sv)));
1989 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1990 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1992 /* Integer is imprecise. NOK, IOKp */
1994 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1997 SvUV_set(sv, U_V(SvNVX(sv)));
1998 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1999 if (SvUVX(sv) == UV_MAX) {
2000 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2001 possibly be preserved by NV. Hence, it must be overflow.
2003 return IS_NUMBER_OVERFLOW_UV;
2005 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2007 /* Integer is imprecise. NOK, IOKp */
2009 return IS_NUMBER_OVERFLOW_IV;
2011 #endif /* !NV_PRESERVES_UV*/
2014 S_sv_2iuv_common(pTHX_ SV *const sv)
2018 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2021 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2022 * without also getting a cached IV/UV from it at the same time
2023 * (ie PV->NV conversion should detect loss of accuracy and cache
2024 * IV or UV at same time to avoid this. */
2025 /* IV-over-UV optimisation - choose to cache IV if possible */
2027 if (SvTYPE(sv) == SVt_NV)
2028 sv_upgrade(sv, SVt_PVNV);
2030 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2031 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2032 certainly cast into the IV range at IV_MAX, whereas the correct
2033 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2035 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2036 if (Perl_isnan(SvNVX(sv))) {
2042 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2043 SvIV_set(sv, I_V(SvNVX(sv)));
2044 if (SvNVX(sv) == (NV) SvIVX(sv)
2045 #ifndef NV_PRESERVES_UV
2046 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2047 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2048 /* Don't flag it as "accurately an integer" if the number
2049 came from a (by definition imprecise) NV operation, and
2050 we're outside the range of NV integer precision */
2054 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2056 /* scalar has trailing garbage, eg "42a" */
2058 DEBUG_c(PerlIO_printf(Perl_debug_log,
2059 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2065 /* IV not precise. No need to convert from PV, as NV
2066 conversion would already have cached IV if it detected
2067 that PV->IV would be better than PV->NV->IV
2068 flags already correct - don't set public IOK. */
2069 DEBUG_c(PerlIO_printf(Perl_debug_log,
2070 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2075 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2076 but the cast (NV)IV_MIN rounds to a the value less (more
2077 negative) than IV_MIN which happens to be equal to SvNVX ??
2078 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2079 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2080 (NV)UVX == NVX are both true, but the values differ. :-(
2081 Hopefully for 2s complement IV_MIN is something like
2082 0x8000000000000000 which will be exact. NWC */
2085 SvUV_set(sv, U_V(SvNVX(sv)));
2087 (SvNVX(sv) == (NV) SvUVX(sv))
2088 #ifndef NV_PRESERVES_UV
2089 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2090 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2091 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2092 /* Don't flag it as "accurately an integer" if the number
2093 came from a (by definition imprecise) NV operation, and
2094 we're outside the range of NV integer precision */
2100 DEBUG_c(PerlIO_printf(Perl_debug_log,
2101 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2107 else if (SvPOKp(sv) && SvLEN(sv)) {
2109 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2110 /* We want to avoid a possible problem when we cache an IV/ a UV which
2111 may be later translated to an NV, and the resulting NV is not
2112 the same as the direct translation of the initial string
2113 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2114 be careful to ensure that the value with the .456 is around if the
2115 NV value is requested in the future).
2117 This means that if we cache such an IV/a UV, we need to cache the
2118 NV as well. Moreover, we trade speed for space, and do not
2119 cache the NV if we are sure it's not needed.
2122 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2123 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2124 == IS_NUMBER_IN_UV) {
2125 /* It's definitely an integer, only upgrade to PVIV */
2126 if (SvTYPE(sv) < SVt_PVIV)
2127 sv_upgrade(sv, SVt_PVIV);
2129 } else if (SvTYPE(sv) < SVt_PVNV)
2130 sv_upgrade(sv, SVt_PVNV);
2132 /* If NVs preserve UVs then we only use the UV value if we know that
2133 we aren't going to call atof() below. If NVs don't preserve UVs
2134 then the value returned may have more precision than atof() will
2135 return, even though value isn't perfectly accurate. */
2136 if ((numtype & (IS_NUMBER_IN_UV
2137 #ifdef NV_PRESERVES_UV
2140 )) == IS_NUMBER_IN_UV) {
2141 /* This won't turn off the public IOK flag if it was set above */
2142 (void)SvIOKp_on(sv);
2144 if (!(numtype & IS_NUMBER_NEG)) {
2146 if (value <= (UV)IV_MAX) {
2147 SvIV_set(sv, (IV)value);
2149 /* it didn't overflow, and it was positive. */
2150 SvUV_set(sv, value);
2154 /* 2s complement assumption */
2155 if (value <= (UV)IV_MIN) {
2156 SvIV_set(sv, -(IV)value);
2158 /* Too negative for an IV. This is a double upgrade, but
2159 I'm assuming it will be rare. */
2160 if (SvTYPE(sv) < SVt_PVNV)
2161 sv_upgrade(sv, SVt_PVNV);
2165 SvNV_set(sv, -(NV)value);
2166 SvIV_set(sv, IV_MIN);
2170 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2171 will be in the previous block to set the IV slot, and the next
2172 block to set the NV slot. So no else here. */
2174 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2175 != IS_NUMBER_IN_UV) {
2176 /* It wasn't an (integer that doesn't overflow the UV). */
2177 SvNV_set(sv, Atof(SvPVX_const(sv)));
2179 if (! numtype && ckWARN(WARN_NUMERIC))
2182 #if defined(USE_LONG_DOUBLE)
2183 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2184 PTR2UV(sv), SvNVX(sv)));
2186 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2187 PTR2UV(sv), SvNVX(sv)));
2190 #ifdef NV_PRESERVES_UV
2191 (void)SvIOKp_on(sv);
2193 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2194 SvIV_set(sv, I_V(SvNVX(sv)));
2195 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2198 NOOP; /* Integer is imprecise. NOK, IOKp */
2200 /* UV will not work better than IV */
2202 if (SvNVX(sv) > (NV)UV_MAX) {
2204 /* Integer is inaccurate. NOK, IOKp, is UV */
2205 SvUV_set(sv, UV_MAX);
2207 SvUV_set(sv, U_V(SvNVX(sv)));
2208 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2209 NV preservse UV so can do correct comparison. */
2210 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2213 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
2218 #else /* NV_PRESERVES_UV */
2219 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2220 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2221 /* The IV/UV slot will have been set from value returned by
2222 grok_number above. The NV slot has just been set using
2225 assert (SvIOKp(sv));
2227 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2228 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2229 /* Small enough to preserve all bits. */
2230 (void)SvIOKp_on(sv);
2232 SvIV_set(sv, I_V(SvNVX(sv)));
2233 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2235 /* Assumption: first non-preserved integer is < IV_MAX,
2236 this NV is in the preserved range, therefore: */
2237 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2239 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);
2243 0 0 already failed to read UV.
2244 0 1 already failed to read UV.
2245 1 0 you won't get here in this case. IV/UV
2246 slot set, public IOK, Atof() unneeded.
2247 1 1 already read UV.
2248 so there's no point in sv_2iuv_non_preserve() attempting
2249 to use atol, strtol, strtoul etc. */
2251 sv_2iuv_non_preserve (sv, numtype);
2253 sv_2iuv_non_preserve (sv);
2257 #endif /* NV_PRESERVES_UV */
2258 /* It might be more code efficient to go through the entire logic above
2259 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2260 gets complex and potentially buggy, so more programmer efficient
2261 to do it this way, by turning off the public flags: */
2263 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2267 if (isGV_with_GP(sv))
2268 return glob_2number(MUTABLE_GV(sv));
2270 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2271 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2274 if (SvTYPE(sv) < SVt_IV)
2275 /* Typically the caller expects that sv_any is not NULL now. */
2276 sv_upgrade(sv, SVt_IV);
2277 /* Return 0 from the caller. */
2284 =for apidoc sv_2iv_flags
2286 Return the integer value of an SV, doing any necessary string
2287 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2288 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2294 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2299 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2300 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2301 cache IVs just in case. In practice it seems that they never
2302 actually anywhere accessible by user Perl code, let alone get used
2303 in anything other than a string context. */
2304 if (flags & SV_GMAGIC)
2309 return I_V(SvNVX(sv));
2311 if (SvPOKp(sv) && SvLEN(sv)) {
2314 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2316 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2317 == IS_NUMBER_IN_UV) {
2318 /* It's definitely an integer */
2319 if (numtype & IS_NUMBER_NEG) {
2320 if (value < (UV)IV_MIN)
2323 if (value < (UV)IV_MAX)
2328 if (ckWARN(WARN_NUMERIC))
2331 return I_V(Atof(SvPVX_const(sv)));
2336 assert(SvTYPE(sv) >= SVt_PVMG);
2337 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2338 } else if (SvTHINKFIRST(sv)) {
2342 SV * const tmpstr=AMG_CALLun(sv,numer);
2343 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2344 return SvIV(tmpstr);
2347 return PTR2IV(SvRV(sv));
2350 sv_force_normal_flags(sv, 0);
2352 if (SvREADONLY(sv) && !SvOK(sv)) {
2353 if (ckWARN(WARN_UNINITIALIZED))
2359 if (S_sv_2iuv_common(aTHX_ sv))
2362 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2363 PTR2UV(sv),SvIVX(sv)));
2364 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2368 =for apidoc sv_2uv_flags
2370 Return the unsigned integer value of an SV, doing any necessary string
2371 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2372 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2378 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2383 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2384 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2385 cache IVs just in case. */
2386 if (flags & SV_GMAGIC)
2391 return U_V(SvNVX(sv));
2392 if (SvPOKp(sv) && SvLEN(sv)) {
2395 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2397 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2398 == IS_NUMBER_IN_UV) {
2399 /* It's definitely an integer */
2400 if (!(numtype & IS_NUMBER_NEG))
2404 if (ckWARN(WARN_NUMERIC))
2407 return U_V(Atof(SvPVX_const(sv)));
2412 assert(SvTYPE(sv) >= SVt_PVMG);
2413 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2414 } else if (SvTHINKFIRST(sv)) {
2418 SV *const tmpstr = AMG_CALLun(sv,numer);
2419 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2420 return SvUV(tmpstr);
2423 return PTR2UV(SvRV(sv));
2426 sv_force_normal_flags(sv, 0);
2428 if (SvREADONLY(sv) && !SvOK(sv)) {
2429 if (ckWARN(WARN_UNINITIALIZED))
2435 if (S_sv_2iuv_common(aTHX_ sv))
2439 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2440 PTR2UV(sv),SvUVX(sv)));
2441 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2447 Return the num value of an SV, doing any necessary string or integer
2448 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2455 Perl_sv_2nv(pTHX_ register SV *const sv)
2460 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2461 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2462 cache IVs just in case. */
2466 if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2467 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2468 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2470 return Atof(SvPVX_const(sv));
2474 return (NV)SvUVX(sv);
2476 return (NV)SvIVX(sv);
2481 assert(SvTYPE(sv) >= SVt_PVMG);
2482 /* This falls through to the report_uninit near the end of the
2484 } else if (SvTHINKFIRST(sv)) {
2488 SV *const tmpstr = AMG_CALLun(sv,numer);
2489 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2490 return SvNV(tmpstr);
2493 return PTR2NV(SvRV(sv));
2496 sv_force_normal_flags(sv, 0);
2498 if (SvREADONLY(sv) && !SvOK(sv)) {
2499 if (ckWARN(WARN_UNINITIALIZED))
2504 if (SvTYPE(sv) < SVt_NV) {
2505 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2506 sv_upgrade(sv, SVt_NV);
2507 #ifdef USE_LONG_DOUBLE
2509 STORE_NUMERIC_LOCAL_SET_STANDARD();
2510 PerlIO_printf(Perl_debug_log,
2511 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2512 PTR2UV(sv), SvNVX(sv));
2513 RESTORE_NUMERIC_LOCAL();
2517 STORE_NUMERIC_LOCAL_SET_STANDARD();
2518 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2519 PTR2UV(sv), SvNVX(sv));
2520 RESTORE_NUMERIC_LOCAL();
2524 else if (SvTYPE(sv) < SVt_PVNV)
2525 sv_upgrade(sv, SVt_PVNV);
2530 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2531 #ifdef NV_PRESERVES_UV
2537 /* Only set the public NV OK flag if this NV preserves the IV */
2538 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2540 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2541 : (SvIVX(sv) == I_V(SvNVX(sv))))
2547 else if (SvPOKp(sv) && SvLEN(sv)) {
2549 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2550 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2552 #ifdef NV_PRESERVES_UV
2553 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2554 == IS_NUMBER_IN_UV) {
2555 /* It's definitely an integer */
2556 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2558 SvNV_set(sv, Atof(SvPVX_const(sv)));
2564 SvNV_set(sv, Atof(SvPVX_const(sv)));
2565 /* Only set the public NV OK flag if this NV preserves the value in
2566 the PV at least as well as an IV/UV would.
2567 Not sure how to do this 100% reliably. */
2568 /* if that shift count is out of range then Configure's test is
2569 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2571 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2572 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2573 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2574 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2575 /* Can't use strtol etc to convert this string, so don't try.
2576 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2579 /* value has been set. It may not be precise. */
2580 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2581 /* 2s complement assumption for (UV)IV_MIN */
2582 SvNOK_on(sv); /* Integer is too negative. */
2587 if (numtype & IS_NUMBER_NEG) {
2588 SvIV_set(sv, -(IV)value);
2589 } else if (value <= (UV)IV_MAX) {
2590 SvIV_set(sv, (IV)value);
2592 SvUV_set(sv, value);
2596 if (numtype & IS_NUMBER_NOT_INT) {
2597 /* I believe that even if the original PV had decimals,
2598 they are lost beyond the limit of the FP precision.
2599 However, neither is canonical, so both only get p
2600 flags. NWC, 2000/11/25 */
2601 /* Both already have p flags, so do nothing */
2603 const NV nv = SvNVX(sv);
2604 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2605 if (SvIVX(sv) == I_V(nv)) {
2608 /* It had no "." so it must be integer. */
2612 /* between IV_MAX and NV(UV_MAX).
2613 Could be slightly > UV_MAX */
2615 if (numtype & IS_NUMBER_NOT_INT) {
2616 /* UV and NV both imprecise. */
2618 const UV nv_as_uv = U_V(nv);
2620 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2629 /* It might be more code efficient to go through the entire logic above
2630 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2631 gets complex and potentially buggy, so more programmer efficient
2632 to do it this way, by turning off the public flags: */
2634 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2635 #endif /* NV_PRESERVES_UV */
2638 if (isGV_with_GP(sv)) {
2639 glob_2number(MUTABLE_GV(sv));
2643 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2645 assert (SvTYPE(sv) >= SVt_NV);
2646 /* Typically the caller expects that sv_any is not NULL now. */
2647 /* XXX Ilya implies that this is a bug in callers that assume this
2648 and ideally should be fixed. */
2651 #if defined(USE_LONG_DOUBLE)
2653 STORE_NUMERIC_LOCAL_SET_STANDARD();
2654 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2655 PTR2UV(sv), SvNVX(sv));
2656 RESTORE_NUMERIC_LOCAL();
2660 STORE_NUMERIC_LOCAL_SET_STANDARD();
2661 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2662 PTR2UV(sv), SvNVX(sv));
2663 RESTORE_NUMERIC_LOCAL();
2672 Return an SV with the numeric value of the source SV, doing any necessary
2673 reference or overload conversion. You must use the C<SvNUM(sv)> macro to
2674 access this function.
2680 Perl_sv_2num(pTHX_ register SV *const sv)
2682 PERL_ARGS_ASSERT_SV_2NUM;
2687 SV * const tmpsv = AMG_CALLun(sv,numer);
2688 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2689 return sv_2num(tmpsv);
2691 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2694 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2695 * UV as a string towards the end of buf, and return pointers to start and
2698 * We assume that buf is at least TYPE_CHARS(UV) long.
2702 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2704 char *ptr = buf + TYPE_CHARS(UV);
2705 char * const ebuf = ptr;
2708 PERL_ARGS_ASSERT_UIV_2BUF;
2720 *--ptr = '0' + (char)(uv % 10);
2729 =for apidoc sv_2pv_flags
2731 Returns a pointer to the string value of an SV, and sets *lp to its length.
2732 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2734 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2735 usually end up here too.
2741 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2751 if (SvGMAGICAL(sv)) {
2752 if (flags & SV_GMAGIC)
2757 if (flags & SV_MUTABLE_RETURN)
2758 return SvPVX_mutable(sv);
2759 if (flags & SV_CONST_RETURN)
2760 return (char *)SvPVX_const(sv);
2763 if (SvIOKp(sv) || SvNOKp(sv)) {
2764 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2769 ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2770 : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2772 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2779 #ifdef FIXNEGATIVEZERO
2780 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2786 SvUPGRADE(sv, SVt_PV);
2789 s = SvGROW_mutable(sv, len + 1);
2792 return (char*)memcpy(s, tbuf, len + 1);
2798 assert(SvTYPE(sv) >= SVt_PVMG);
2799 /* This falls through to the report_uninit near the end of the
2801 } else if (SvTHINKFIRST(sv)) {
2805 SV *const tmpstr = AMG_CALLun(sv,string);
2806 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2808 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2812 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2813 if (flags & SV_CONST_RETURN) {
2814 pv = (char *) SvPVX_const(tmpstr);
2816 pv = (flags & SV_MUTABLE_RETURN)
2817 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2820 *lp = SvCUR(tmpstr);
2822 pv = sv_2pv_flags(tmpstr, lp, flags);
2835 SV *const referent = SvRV(sv);
2839 retval = buffer = savepvn("NULLREF", len);
2840 } else if (SvTYPE(referent) == SVt_REGEXP) {
2841 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2846 /* If the regex is UTF-8 we want the containing scalar to
2847 have an UTF-8 flag too */
2853 if ((seen_evals = RX_SEEN_EVALS(re)))
2854 PL_reginterp_cnt += seen_evals;
2857 *lp = RX_WRAPLEN(re);
2859 return RX_WRAPPED(re);
2861 const char *const typestr = sv_reftype(referent, 0);
2862 const STRLEN typelen = strlen(typestr);
2863 UV addr = PTR2UV(referent);
2864 const char *stashname = NULL;
2865 STRLEN stashnamelen = 0; /* hush, gcc */
2866 const char *buffer_end;
2868 if (SvOBJECT(referent)) {
2869 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2872 stashname = HEK_KEY(name);
2873 stashnamelen = HEK_LEN(name);
2875 if (HEK_UTF8(name)) {
2881 stashname = "__ANON__";
2884 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2885 + 2 * sizeof(UV) + 2 /* )\0 */;
2887 len = typelen + 3 /* (0x */
2888 + 2 * sizeof(UV) + 2 /* )\0 */;
2891 Newx(buffer, len, char);
2892 buffer_end = retval = buffer + len;
2894 /* Working backwards */
2898 *--retval = PL_hexdigit[addr & 15];
2899 } while (addr >>= 4);
2905 memcpy(retval, typestr, typelen);
2909 retval -= stashnamelen;
2910 memcpy(retval, stashname, stashnamelen);
2912 /* retval may not neccesarily have reached the start of the
2914 assert (retval >= buffer);
2916 len = buffer_end - retval - 1; /* -1 for that \0 */
2924 if (SvREADONLY(sv) && !SvOK(sv)) {
2927 if (flags & SV_UNDEF_RETURNS_NULL)
2929 if (ckWARN(WARN_UNINITIALIZED))
2934 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2935 /* I'm assuming that if both IV and NV are equally valid then
2936 converting the IV is going to be more efficient */
2937 const U32 isUIOK = SvIsUV(sv);
2938 char buf[TYPE_CHARS(UV)];
2942 if (SvTYPE(sv) < SVt_PVIV)
2943 sv_upgrade(sv, SVt_PVIV);
2944 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2946 /* inlined from sv_setpvn */
2947 s = SvGROW_mutable(sv, len + 1);
2948 Move(ptr, s, len, char);
2952 else if (SvNOKp(sv)) {
2954 if (SvTYPE(sv) < SVt_PVNV)
2955 sv_upgrade(sv, SVt_PVNV);
2956 /* The +20 is pure guesswork. Configure test needed. --jhi */
2957 s = SvGROW_mutable(sv, NV_DIG + 20);
2958 /* some Xenix systems wipe out errno here */
2960 if (SvNVX(sv) == 0.0)
2961 my_strlcpy(s, "0", SvLEN(sv));
2965 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2968 #ifdef FIXNEGATIVEZERO
2969 if (*s == '-' && s[1] == '0' && !s[2]) {
2981 if (isGV_with_GP(sv)) {
2982 GV *const gv = MUTABLE_GV(sv);
2983 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
2984 SV *const buffer = sv_newmortal();
2986 /* FAKE globs can get coerced, so need to turn this off temporarily
2989 gv_efullname3(buffer, gv, "*");
2990 SvFLAGS(gv) |= wasfake;
2992 if (SvPOK(buffer)) {
2994 *lp = SvCUR(buffer);
2996 return SvPVX(buffer);
3007 if (flags & SV_UNDEF_RETURNS_NULL)
3009 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
3011 if (SvTYPE(sv) < SVt_PV)
3012 /* Typically the caller expects that sv_any is not NULL now. */
3013 sv_upgrade(sv, SVt_PV);
3017 const STRLEN len = s - SvPVX_const(sv);
3023 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3024 PTR2UV(sv),SvPVX_const(sv)));
3025 if (flags & SV_CONST_RETURN)
3026 return (char *)SvPVX_const(sv);
3027 if (flags & SV_MUTABLE_RETURN)
3028 return SvPVX_mutable(sv);
3033 =for apidoc sv_copypv
3035 Copies a stringified representation of the source SV into the
3036 destination SV. Automatically performs any necessary mg_get and
3037 coercion of numeric values into strings. Guaranteed to preserve
3038 UTF8 flag even from overloaded objects. Similar in nature to
3039 sv_2pv[_flags] but operates directly on an SV instead of just the
3040 string. Mostly uses sv_2pv_flags to do its work, except when that
3041 would lose the UTF-8'ness of the PV.
3047 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3050 const char * const s = SvPV_const(ssv,len);
3052 PERL_ARGS_ASSERT_SV_COPYPV;
3054 sv_setpvn(dsv,s,len);
3062 =for apidoc sv_2pvbyte
3064 Return a pointer to the byte-encoded representation of the SV, and set *lp
3065 to its length. May cause the SV to be downgraded from UTF-8 as a
3068 Usually accessed via the C<SvPVbyte> macro.
3074 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3076 PERL_ARGS_ASSERT_SV_2PVBYTE;
3078 sv_utf8_downgrade(sv,0);
3079 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3083 =for apidoc sv_2pvutf8
3085 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3086 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3088 Usually accessed via the C<SvPVutf8> macro.
3094 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3096 PERL_ARGS_ASSERT_SV_2PVUTF8;
3098 sv_utf8_upgrade(sv);
3099 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3104 =for apidoc sv_2bool
3106 This function is only called on magical items, and is only used by
3107 sv_true() or its macro equivalent.
3113 Perl_sv_2bool(pTHX_ register SV *const sv)
3117 PERL_ARGS_ASSERT_SV_2BOOL;
3125 SV * const tmpsv = AMG_CALLun(sv,bool_);
3126 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3127 return (bool)SvTRUE(tmpsv);
3129 return SvRV(sv) != 0;
3132 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3134 (*sv->sv_u.svu_pv > '0' ||
3135 Xpvtmp->xpv_cur > 1 ||
3136 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3143 return SvIVX(sv) != 0;
3146 return SvNVX(sv) != 0.0;
3148 if (isGV_with_GP(sv))
3158 =for apidoc sv_utf8_upgrade
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 Will C<mg_get> on C<sv> if appropriate.
3163 Always sets the SvUTF8 flag to avoid future validity checks even
3164 if the whole string is the same in UTF-8 as not.
3165 Returns the number of bytes in the converted string
3167 This is not as a general purpose byte encoding to Unicode interface:
3168 use the Encode extension for that.
3170 =for apidoc sv_utf8_upgrade_nomg
3172 Like sv_utf8_upgrade, but doesn't do magic on C<sv>
3174 =for apidoc sv_utf8_upgrade_flags
3176 Converts the PV of an SV to its UTF-8-encoded form.
3177 Forces the SV to string form if it is not already.
3178 Always sets the SvUTF8 flag to avoid future validity checks even
3179 if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
3180 will C<mg_get> on C<sv> if appropriate, else not.
3181 Returns the number of bytes in the converted string
3182 C<sv_utf8_upgrade> and
3183 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3185 This is not as a general purpose byte encoding to Unicode interface:
3186 use the Encode extension for that.
3190 The grow version is currently not externally documented. It adds a parameter,
3191 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3192 have free after it upon return. This allows the caller to reserve extra space
3193 that it intends to fill, to avoid extra grows.
3195 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3196 which can be used to tell this function to not first check to see if there are
3197 any characters that are different in UTF-8 (variant characters) which would
3198 force it to allocate a new string to sv, but to assume there are. Typically
3199 this flag is used by a routine that has already parsed the string to find that
3200 there are such characters, and passes this information on so that the work
3201 doesn't have to be repeated.
3203 (One might think that the calling routine could pass in the position of the
3204 first such variant, so it wouldn't have to be found again. But that is not the
3205 case, because typically when the caller is likely to use this flag, it won't be
3206 calling this routine unless it finds something that won't fit into a byte.
3207 Otherwise it tries to not upgrade and just use bytes. But some things that
3208 do fit into a byte are variants in utf8, and the caller may not have been
3209 keeping track of these.)
3211 If the routine itself changes the string, it adds a trailing NUL. Such a NUL
3212 isn't guaranteed due to having other routines do the work in some input cases,
3213 or if the input is already flagged as being in utf8.
3215 The speed of this could perhaps be improved for many cases if someone wanted to
3216 write a fast function that counts the number of variant characters in a string,
3217 especially if it could return the position of the first one.
3222 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
3226 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3228 if (sv == &PL_sv_undef)
3232 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3233 (void) sv_2pv_flags(sv,&len, flags);
3235 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3239 (void) SvPV_force(sv,len);
3244 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3249 sv_force_normal_flags(sv, 0);
3252 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3253 sv_recode_to_utf8(sv, PL_encoding);
3254 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3258 if (SvCUR(sv) == 0) {
3259 if (extra) SvGROW(sv, extra);
3260 } else { /* Assume Latin-1/EBCDIC */
3261 /* This function could be much more efficient if we
3262 * had a FLAG in SVs to signal if there are any variant
3263 * chars in the PV. Given that there isn't such a flag
3264 * make the loop as fast as possible (although there are certainly ways
3265 * to speed this up, eg. through vectorization) */
3266 U8 * s = (U8 *) SvPVX_const(sv);
3267 U8 * e = (U8 *) SvEND(sv);
3269 STRLEN two_byte_count = 0;
3271 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3273 /* See if really will need to convert to utf8. We mustn't rely on our
3274 * incoming SV being well formed and having a trailing '\0', as certain
3275 * code in pp_formline can send us partially built SVs. */
3279 if (NATIVE_IS_INVARIANT(ch)) continue;
3281 t--; /* t already incremented; re-point to first variant */
3286 /* utf8 conversion not needed because all are invariants. Mark as
3287 * UTF-8 even if no variant - saves scanning loop */
3293 /* Here, the string should be converted to utf8, either because of an
3294 * input flag (two_byte_count = 0), or because a character that
3295 * requires 2 bytes was found (two_byte_count = 1). t points either to
3296 * the beginning of the string (if we didn't examine anything), or to
3297 * the first variant. In either case, everything from s to t - 1 will
3298 * occupy only 1 byte each on output.
3300 * There are two main ways to convert. One is to create a new string
3301 * and go through the input starting from the beginning, appending each
3302 * converted value onto the new string as we go along. It's probably
3303 * best to allocate enough space in the string for the worst possible
3304 * case rather than possibly running out of space and having to
3305 * reallocate and then copy what we've done so far. Since everything
3306 * from s to t - 1 is invariant, the destination can be initialized
3307 * with these using a fast memory copy
3309 * The other way is to figure out exactly how big the string should be
3310 * by parsing the entire input. Then you don't have to make it big
3311 * enough to handle the worst possible case, and more importantly, if
3312 * the string you already have is large enough, you don't have to
3313 * allocate a new string, you can copy the last character in the input
3314 * string to the final position(s) that will be occupied by the
3315 * converted string and go backwards, stopping at t, since everything
3316 * before that is invariant.
3318 * There are advantages and disadvantages to each method.
3320 * In the first method, we can allocate a new string, do the memory
3321 * copy from the s to t - 1, and then proceed through the rest of the
3322 * string byte-by-byte.
3324 * In the second method, we proceed through the rest of the input
3325 * string just calculating how big the converted string will be. Then
3326 * there are two cases:
3327 * 1) if the string has enough extra space to handle the converted
3328 * value. We go backwards through the string, converting until we
3329 * get to the position we are at now, and then stop. If this
3330 * position is far enough along in the string, this method is
3331 * faster than the other method. If the memory copy were the same
3332 * speed as the byte-by-byte loop, that position would be about
3333 * half-way, as at the half-way mark, parsing to the end and back
3334 * is one complete string's parse, the same amount as starting
3335 * over and going all the way through. Actually, it would be
3336 * somewhat less than half-way, as it's faster to just count bytes
3337 * than to also copy, and we don't have the overhead of allocating
3338 * a new string, changing the scalar to use it, and freeing the
3339 * existing one. But if the memory copy is fast, the break-even
3340 * point is somewhere after half way. The counting loop could be
3341 * sped up by vectorization, etc, to move the break-even point
3342 * further towards the beginning.
3343 * 2) if the string doesn't have enough space to handle the converted
3344 * value. A new string will have to be allocated, and one might
3345 * as well, given that, start from the beginning doing the first
3346 * method. We've spent extra time parsing the string and in
3347 * exchange all we've gotten is that we know precisely how big to
3348 * make the new one. Perl is more optimized for time than space,
3349 * so this case is a loser.
3350 * So what I've decided to do is not use the 2nd method unless it is
3351 * guaranteed that a new string won't have to be allocated, assuming
3352 * the worst case. I also decided not to put any more conditions on it
3353 * than this, for now. It seems likely that, since the worst case is
3354 * twice as big as the unknown portion of the string (plus 1), we won't
3355 * be guaranteed enough space, causing us to go to the first method,
3356 * unless the string is short, or the first variant character is near
3357 * the end of it. In either of these cases, it seems best to use the
3358 * 2nd method. The only circumstance I can think of where this would
3359 * be really slower is if the string had once had much more data in it
3360 * than it does now, but there is still a substantial amount in it */
3363 STRLEN invariant_head = t - s;
3364 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3365 if (SvLEN(sv) < size) {
3367 /* Here, have decided to allocate a new string */
3372 Newx(dst, size, U8);
3374 /* If no known invariants at the beginning of the input string,
3375 * set so starts from there. Otherwise, can use memory copy to
3376 * get up to where we are now, and then start from here */
3378 if (invariant_head <= 0) {
3381 Copy(s, dst, invariant_head, char);
3382 d = dst + invariant_head;
3386 const UV uv = NATIVE8_TO_UNI(*t++);
3387 if (UNI_IS_INVARIANT(uv))
3388 *d++ = (U8)UNI_TO_NATIVE(uv);
3390 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3391 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3395 SvPV_free(sv); /* No longer using pre-existing string */
3396 SvPV_set(sv, (char*)dst);
3397 SvCUR_set(sv, d - dst);
3398 SvLEN_set(sv, size);
3401 /* Here, have decided to get the exact size of the string.
3402 * Currently this happens only when we know that there is
3403 * guaranteed enough space to fit the converted string, so
3404 * don't have to worry about growing. If two_byte_count is 0,
3405 * then t points to the first byte of the string which hasn't
3406 * been examined yet. Otherwise two_byte_count is 1, and t
3407 * points to the first byte in the string that will expand to
3408 * two. Depending on this, start examining at t or 1 after t.
3411 U8 *d = t + two_byte_count;
3414 /* Count up the remaining bytes that expand to two */
3417 const U8 chr = *d++;
3418 if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3421 /* The string will expand by just the number of bytes that
3422 * occupy two positions. But we are one afterwards because of
3423 * the increment just above. This is the place to put the
3424 * trailing NUL, and to set the length before we decrement */
3426 d += two_byte_count;
3427 SvCUR_set(sv, d - s);
3431 /* Having decremented d, it points to the position to put the
3432 * very last byte of the expanded string. Go backwards through
3433 * the string, copying and expanding as we go, stopping when we
3434 * get to the part that is invariant the rest of the way down */
3438 const U8 ch = NATIVE8_TO_UNI(*e--);
3439 if (UNI_IS_INVARIANT(ch)) {
3440 *d-- = UNI_TO_NATIVE(ch);
3442 *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3443 *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3450 /* Mark as UTF-8 even if no variant - saves scanning loop */
3456 =for apidoc sv_utf8_downgrade
3458 Attempts to convert the PV of an SV from characters to bytes.
3459 If the PV contains a character that cannot fit
3460 in a byte, this conversion will fail;
3461 in this case, either returns false or, if C<fail_ok> is not
3464 This is not as a general purpose Unicode to byte encoding interface:
3465 use the Encode extension for that.
3471 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3475 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3477 if (SvPOKp(sv) && SvUTF8(sv)) {
3483 sv_force_normal_flags(sv, 0);
3485 s = (U8 *) SvPV(sv, len);
3486 if (!utf8_to_bytes(s, &len)) {
3491 Perl_croak(aTHX_ "Wide character in %s",
3494 Perl_croak(aTHX_ "Wide character");
3505 =for apidoc sv_utf8_encode
3507 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3508 flag off so that it looks like octets again.
3514 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3516 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3519 sv_force_normal_flags(sv, 0);
3521 if (SvREADONLY(sv)) {
3522 Perl_croak(aTHX_ "%s", PL_no_modify);
3524 (void) sv_utf8_upgrade(sv);
3529 =for apidoc sv_utf8_decode
3531 If the PV of the SV is an octet sequence in UTF-8
3532 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3533 so that it looks like a character. If the PV contains only single-byte
3534 characters, the C<SvUTF8> flag stays being off.
3535 Scans PV for validity and returns false if the PV is invalid UTF-8.
3541 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3543 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3549 /* The octets may have got themselves encoded - get them back as
3552 if (!sv_utf8_downgrade(sv, TRUE))
3555 /* it is actually just a matter of turning the utf8 flag on, but
3556 * we want to make sure everything inside is valid utf8 first.
3558 c = (const U8 *) SvPVX_const(sv);
3559 if (!is_utf8_string(c, SvCUR(sv)+1))
3561 e = (const U8 *) SvEND(sv);
3564 if (!UTF8_IS_INVARIANT(ch)) {
3574 =for apidoc sv_setsv
3576 Copies the contents of the source SV C<ssv> into the destination SV
3577 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3578 function if the source SV needs to be reused. Does not handle 'set' magic.
3579 Loosely speaking, it performs a copy-by-value, obliterating any previous
3580 content of the destination.
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 =for apidoc sv_setsv_flags
3588 Copies the contents of the source SV C<ssv> into the destination SV
3589 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3590 function if the source SV needs to be reused. Does not handle 'set' magic.
3591 Loosely speaking, it performs a copy-by-value, obliterating any previous
3592 content of the destination.
3593 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3594 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3595 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3596 and C<sv_setsv_nomg> are implemented in terms of this function.
3598 You probably want to use one of the assortment of wrappers, such as
3599 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3600 C<SvSetMagicSV_nosteal>.
3602 This is the primary function for copying scalars, and most other
3603 copy-ish functions and macros use this underneath.
3609 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3611 I32 mro_changes = 0; /* 1 = method, 2 = isa */
3613 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3615 if (dtype != SVt_PVGV) {
3616 const char * const name = GvNAME(sstr);
3617 const STRLEN len = GvNAMELEN(sstr);
3619 if (dtype >= SVt_PV) {
3625 SvUPGRADE(dstr, SVt_PVGV);
3626 (void)SvOK_off(dstr);
3627 /* FIXME - why are we doing this, then turning it off and on again
3629 isGV_with_GP_on(dstr);
3631 GvSTASH(dstr) = GvSTASH(sstr);
3633 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3634 gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
3635 SvFAKE_on(dstr); /* can coerce to non-glob */
3638 if(GvGP(MUTABLE_GV(sstr))) {
3639 /* If source has method cache entry, clear it */
3641 SvREFCNT_dec(GvCV(sstr));
3645 /* If source has a real method, then a method is
3647 else if(GvCV((const GV *)sstr)) {
3652 /* If dest already had a real method, that's a change as well */
3653 if(!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)) {
3657 if(strEQ(GvNAME((const GV *)dstr),"ISA"))
3660 gp_free(MUTABLE_GV(dstr));
3661 isGV_with_GP_off(dstr);
3662 (void)SvOK_off(dstr);
3663 isGV_with_GP_on(dstr);
3664 GvINTRO_off(dstr); /* one-shot flag */
3665 GvGP(dstr) = gp_ref(GvGP(sstr));
3666 if (SvTAINTED(sstr))
3668 if (GvIMPORTED(dstr) != GVf_IMPORTED
3669 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3671 GvIMPORTED_on(dstr);
3674 if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
3675 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3680 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3682 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3684 const int intro = GvINTRO(dstr);
3687 const U32 stype = SvTYPE(sref);
3689 PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3692 GvINTRO_off(dstr); /* one-shot flag */
3693 GvLINE(dstr) = CopLINE(PL_curcop);
3694 GvEGV(dstr) = MUTABLE_GV(dstr);
3699 location = (SV **) &GvCV(dstr);
3700 import_flag = GVf_IMPORTED_CV;
3703 location = (SV **) &GvHV(dstr);
3704 import_flag = GVf_IMPORTED_HV;
3707 location = (SV **) &GvAV(dstr);
3708 import_flag = GVf_IMPORTED_AV;
3711 location = (SV **) &GvIOp(dstr);
3714 location = (SV **) &GvFORM(dstr);
3717 location = &GvSV(dstr);
3718 import_flag = GVf_IMPORTED_SV;
3721 if (stype == SVt_PVCV) {
3722 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3723 if (GvCVGEN(dstr)) {
3724 SvREFCNT_dec(GvCV(dstr));
3726 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3729 SAVEGENERICSV(*location);
3733 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3734 CV* const cv = MUTABLE_CV(*location);
3736 if (!GvCVGEN((const GV *)dstr) &&
3737 (CvROOT(cv) || CvXSUB(cv)))
3739 /* Redefining a sub - warning is mandatory if
3740 it was a const and its value changed. */
3741 if (CvCONST(cv) && CvCONST((const CV *)sref)
3743 == cv_const_sv((const CV *)sref)) {
3745 /* They are 2 constant subroutines generated from
3746 the same constant. This probably means that
3747 they are really the "same" proxy subroutine
3748 instantiated in 2 places. Most likely this is
3749 when a constant is exported twice. Don't warn.
3752 else if (ckWARN(WARN_REDEFINE)
3754 && (!CvCONST((const CV *)sref)
3755 || sv_cmp(cv_const_sv(cv),
3756 cv_const_sv((const CV *)
3758 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3761 ? "Constant subroutine %s::%s redefined"
3762 : "Subroutine %s::%s redefined"),
3763 HvNAME_get(GvSTASH((const GV *)dstr)),
3764 GvENAME(MUTABLE_GV(dstr)));
3768 cv_ckproto_len(cv, (const GV *)dstr,
3769 SvPOK(sref) ? SvPVX_const(sref) : NULL,
3770 SvPOK(sref) ? SvCUR(sref) : 0);
3772 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3773 GvASSUMECV_on(dstr);
3774 if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3777 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3778 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3779 GvFLAGS(dstr) |= import_flag;
3781 if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
3782 sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3783 mro_isa_changed_in(GvSTASH(dstr));
3788 if (SvTAINTED(sstr))
3794 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3797 register U32 sflags;
3799 register svtype stype;
3801 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3806 if (SvIS_FREED(dstr)) {
3807 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3808 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3810 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3812 sstr = &PL_sv_undef;
3813 if (SvIS_FREED(sstr)) {
3814 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3815 (void*)sstr, (void*)dstr);
3817 stype = SvTYPE(sstr);
3818 dtype = SvTYPE(dstr);
3820 (void)SvAMAGIC_off(dstr);
3823 /* need to nuke the magic */
3827 /* There's a lot of redundancy below but we're going for speed here */
3832 if (dtype != SVt_PVGV) {
3833 (void)SvOK_off(dstr);
3841 sv_upgrade(dstr, SVt_IV);
3845 sv_upgrade(dstr, SVt_PVIV);
3848 goto end_of_first_switch;
3850 (void)SvIOK_only(dstr);
3851 SvIV_set(dstr, SvIVX(sstr));
3854 /* SvTAINTED can only be true if the SV has taint magic, which in
3855 turn means that the SV type is PVMG (or greater). This is the
3856 case statement for SVt_IV, so this cannot be true (whatever gcov
3858 assert(!SvTAINTED(sstr));
3863 if (dtype < SVt_PV && dtype != SVt_IV)
3864 sv_upgrade(dstr, SVt_IV);
3872 sv_upgrade(dstr, SVt_NV);
3876 sv_upgrade(dstr, SVt_PVNV);
3879 goto end_of_first_switch;
3881 SvNV_set(dstr, SvNVX(sstr));
3882 (void)SvNOK_only(dstr);
3883 /* SvTAINTED can only be true if the SV has taint magic, which in
3884 turn means that the SV type is PVMG (or greater). This is the
3885 case statement for SVt_NV, so this cannot be true (whatever gcov
3887 assert(!SvTAINTED(sstr));
3893 #ifdef PERL_OLD_COPY_ON_WRITE
3894 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3895 if (dtype < SVt_PVIV)
3896 sv_upgrade(dstr, SVt_PVIV);
3903 sv_upgrade(dstr, SVt_PV);
3906 if (dtype < SVt_PVIV)
3907 sv_upgrade(dstr, SVt_PVIV);
3910 if (dtype < SVt_PVNV)
3911 sv_upgrade(dstr, SVt_PVNV);
3915 const char * const type = sv_reftype(sstr,0);
3917 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3919 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3924 if (dtype < SVt_REGEXP)
3925 sv_upgrade(dstr, SVt_REGEXP);
3928 /* case SVt_BIND: */
3931 if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
3932 glob_assign_glob(dstr, sstr, dtype);
3935 /* SvVALID means that this PVGV is playing at being an FBM. */
3939 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3941 if (SvTYPE(sstr) != stype) {
3942 stype = SvTYPE(sstr);
3943 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
3944 glob_assign_glob(dstr, sstr, dtype);
3949 if (stype == SVt_PVLV)
3950 SvUPGRADE(dstr, SVt_PVNV);
3952 SvUPGRADE(dstr, (svtype)stype);
3954 end_of_first_switch:
3956 /* dstr may have been upgraded. */
3957 dtype = SvTYPE(dstr);
3958 sflags = SvFLAGS(sstr);
3960 if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
3961 /* Assigning to a subroutine sets the prototype. */
3964 const char *const ptr = SvPV_const(sstr, len);
3966 SvGROW(dstr, len + 1);
3967 Copy(ptr, SvPVX(dstr), len + 1, char);
3968 SvCUR_set(dstr, len);
3970 SvFLAGS(dstr) |= sflags & SVf_UTF8;
3974 } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3975 const char * const type = sv_reftype(dstr,0);
3977 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op));
3979 Perl_croak(aTHX_ "Cannot copy to %s", type);
3980 } else if (sflags & SVf_ROK) {
3981 if (isGV_with_GP(dstr) && dtype == SVt_PVGV
3982 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
3985 if (GvIMPORTED(dstr) != GVf_IMPORTED
3986 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3988 GvIMPORTED_on(dstr);
3993 glob_assign_glob(dstr, sstr, dtype);
3997 if (dtype >= SVt_PV) {
3998 if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3999 glob_assign_ref(dstr, sstr);
4002 if (SvPVX_const(dstr)) {
4008 (void)SvOK_off(dstr);
4009 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4010 SvFLAGS(dstr) |= sflags & SVf_ROK;
4011 assert(!(sflags & SVp_NOK));
4012 assert(!(sflags & SVp_IOK));
4013 assert(!(sflags & SVf_NOK));
4014 assert(!(sflags & SVf_IOK));
4016 else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
4017 if (!(sflags & SVf_OK)) {
4018 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4019 "Undefined value assigned to typeglob");
4022 GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
4023 if (dstr != (const SV *)gv) {
4025 gp_free(MUTABLE_GV(dstr));
4026 GvGP(dstr) = gp_ref(GvGP(gv));
4030 else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
4031 reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4033 else if (sflags & SVp_POK) {
4037 * Check to see if we can just swipe the string. If so, it's a
4038 * possible small lose on short strings, but a big win on long ones.
4039 * It might even be a win on short strings if SvPVX_const(dstr)
4040 * has to be allocated and SvPVX_const(sstr) has to be freed.
4041 * Likewise if we can set up COW rather than doing an actual copy, we
4042 * drop to the else clause, as the swipe code and the COW setup code
4043 * have much in common.
4046 /* Whichever path we take through the next code, we want this true,
4047 and doing it now facilitates the COW check. */
4048 (void)SvPOK_only(dstr);
4051 /* If we're already COW then this clause is not true, and if COW
4052 is allowed then we drop down to the else and make dest COW
4053 with us. If caller hasn't said that we're allowed to COW
4054 shared hash keys then we don't do the COW setup, even if the
4055 source scalar is a shared hash key scalar. */
4056 (((flags & SV_COW_SHARED_HASH_KEYS)
4057 ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4058 : 1 /* If making a COW copy is forbidden then the behaviour we
4059 desire is as if the source SV isn't actually already
4060 COW, even if it is. So we act as if the source flags
4061 are not COW, rather than actually testing them. */
4063 #ifndef PERL_OLD_COPY_ON_WRITE
4064 /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4065 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4066 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4067 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4068 but in turn, it's somewhat dead code, never expected to go
4069 live, but more kept as a placeholder on how to do it better
4070 in a newer implementation. */
4071 /* If we are COW and dstr is a suitable target then we drop down
4072 into the else and make dest a COW of us. */
4073 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4078 (sflags & SVs_TEMP) && /* slated for free anyway? */
4079 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4080 (!(flags & SV_NOSTEAL)) &&
4081 /* and we're allowed to steal temps */
4082 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4083 SvLEN(sstr) && /* and really is a string */
4084 /* and won't be needed again, potentially */
4085 !(PL_op && PL_op->op_type == OP_AASSIGN))
4086 #ifdef PERL_OLD_COPY_ON_WRITE
4087 && ((flags & SV_COW_SHARED_HASH_KEYS)
4088 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4089 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4090 && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4094 /* Failed the swipe test, and it's not a shared hash key either.
4095 Have to copy the string. */
4096 STRLEN len = SvCUR(sstr);
4097 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4098 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4099 SvCUR_set(dstr, len);
4100 *SvEND(dstr) = '\0';
4102 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4104 /* Either it's a shared hash key, or it's suitable for
4105 copy-on-write or we can swipe the string. */
4107 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4111 #ifdef PERL_OLD_COPY_ON_WRITE
4113 if ((sflags & (SVf_FAKE | SVf_READONLY))
4114 != (SVf_FAKE | SVf_READONLY)) {
4115 SvREADONLY_on(sstr);
4117 /* Make the source SV into a loop of 1.
4118 (about to become 2) */
4119 SV_COW_NEXT_SV_SET(sstr, sstr);
4123 /* Initial code is common. */
4124 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4129 /* making another shared SV. */
4130 STRLEN cur = SvCUR(sstr);
4131 STRLEN len = SvLEN(sstr);
4132 #ifdef PERL_OLD_COPY_ON_WRITE
4134 assert (SvTYPE(dstr) >= SVt_PVIV);
4135 /* SvIsCOW_normal */
4136 /* splice us in between source and next-after-source. */
4137 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4138 SV_COW_NEXT_SV_SET(sstr, dstr);
4139 SvPV_set(dstr, SvPVX_mutable(sstr));
4143 /* SvIsCOW_shared_hash */
4144 DEBUG_C(PerlIO_printf(Perl_debug_log,
4145 "Copy on write: Sharing hash\n"));
4147 assert (SvTYPE(dstr) >= SVt_PV);
4149 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4151 SvLEN_set(dstr, len);
4152 SvCUR_set(dstr, cur);
4153 SvREADONLY_on(dstr);
4157 { /* Passes the swipe test. */
4158 SvPV_set(dstr, SvPVX_mutable(sstr));
4159 SvLEN_set(dstr, SvLEN(sstr));
4160 SvCUR_set(dstr, SvCUR(sstr));
4163 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4164 SvPV_set(sstr, NULL);
4170 if (sflags & SVp_NOK) {
4171 SvNV_set(dstr, SvNVX(sstr));
4173 if (sflags & SVp_IOK) {
4174 SvIV_set(dstr, SvIVX(sstr));
4175 /* Must do this otherwise some other overloaded use of 0x80000000
4176 gets confused. I guess SVpbm_VALID */
4177 if (sflags & SVf_IVisUV)
4180 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4182 const MAGIC * const smg = SvVSTRING_mg(sstr);
4184 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4185 smg->mg_ptr, smg->mg_len);
4186 SvRMAGICAL_on(dstr);
4190 else if (sflags & (SVp_IOK|SVp_NOK)) {
4191 (void)SvOK_off(dstr);
4192 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4193 if (sflags & SVp_IOK) {
4194 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4195 SvIV_set(dstr, SvIVX(sstr));
4197 if (sflags & SVp_NOK) {
4198 SvNV_set(dstr, SvNVX(sstr));
4202 if (isGV_with_GP(sstr)) {
4203 /* This stringification rule for globs is spread in 3 places.
4204 This feels bad. FIXME. */
4205 const U32 wasfake = sflags & SVf_FAKE;
4207 /* FAKE globs can get coerced, so need to turn this off
4208 temporarily if it is on. */
4210 gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4211 SvFLAGS(sstr) |= wasfake;
4214 (void)SvOK_off(dstr);
4216 if (SvTAINTED(sstr))
4221 =for apidoc sv_setsv_mg
4223 Like C<sv_setsv>, but also handles 'set' magic.
4229 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4231 PERL_ARGS_ASSERT_SV_SETSV_MG;
4233 sv_setsv(dstr,sstr);
4237 #ifdef PERL_OLD_COPY_ON_WRITE
4239 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4241 STRLEN cur = SvCUR(sstr);
4242 STRLEN len = SvLEN(sstr);
4243 register char *new_pv;
4245 PERL_ARGS_ASSERT_SV_SETSV_COW;
4248 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4249 (void*)sstr, (void*)dstr);
4256 if (SvTHINKFIRST(dstr))
4257 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4258 else if (SvPVX_const(dstr))
4259 Safefree(SvPVX_const(dstr));
4263 SvUPGRADE(dstr, SVt_PVIV);
4265 assert (SvPOK(sstr));
4266 assert (SvPOKp(sstr));
4267 assert (!SvIOK(sstr));
4268 assert (!SvIOKp(sstr));
4269 assert (!SvNOK(sstr));
4270 assert (!SvNOKp(sstr));
4272 if (SvIsCOW(sstr)) {
4274 if (SvLEN(sstr) == 0) {
4275 /* source is a COW shared hash key. */
4276 DEBUG_C(PerlIO_printf(Perl_debug_log,
4277 "Fast copy on write: Sharing hash\n"));
4278 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4281 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4283 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4284 SvUPGRADE(sstr, SVt_PVIV);
4285 SvREADONLY_on(sstr);
4287 DEBUG_C(PerlIO_printf(Perl_debug_log,
4288 "Fast copy on write: Converting sstr to COW\n"));
4289 SV_COW_NEXT_SV_SET(dstr, sstr);
4291 SV_COW_NEXT_SV_SET(sstr, dstr);
4292 new_pv = SvPVX_mutable(sstr);
4295 SvPV_set(dstr, new_pv);
4296 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4299 SvLEN_set(dstr, len);
4300 SvCUR_set(dstr, cur);
4309 =for apidoc sv_setpvn
4311 Copies a string into an SV. The C<len> parameter indicates the number of
4312 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4313 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4319 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4322 register char *dptr;
4324 PERL_ARGS_ASSERT_SV_SETPVN;
4326 SV_CHECK_THINKFIRST_COW_DROP(sv);
4332 /* len is STRLEN which is unsigned, need to copy to signed */
4335 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4337 SvUPGRADE(sv, SVt_PV);
4339 dptr = SvGROW(sv, len + 1);
4340 Move(ptr,dptr,len,char);
4343 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4348 =for apidoc sv_setpvn_mg
4350 Like C<sv_setpvn>, but also handles 'set' magic.
4356 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4358 PERL_ARGS_ASSERT_SV_SETPVN_MG;
4360 sv_setpvn(sv,ptr,len);
4365 =for apidoc sv_setpv
4367 Copies a string into an SV. The string must be null-terminated. Does not
4368 handle 'set' magic. See C<sv_setpv_mg>.
4374 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4377 register STRLEN len;
4379 PERL_ARGS_ASSERT_SV_SETPV;
4381 SV_CHECK_THINKFIRST_COW_DROP(sv);
4387 SvUPGRADE(sv, SVt_PV);
4389 SvGROW(sv, len + 1);
4390 Move(ptr,SvPVX(sv),len+1,char);
4392 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4397 =for apidoc sv_setpv_mg
4399 Like C<sv_setpv>, but also handles 'set' magic.
4405 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4407 PERL_ARGS_ASSERT_SV_SETPV_MG;
4414 =for apidoc sv_usepvn_flags
4416 Tells an SV to use C<ptr> to find its string value. Normally the
4417 string is stored inside the SV but sv_usepvn allows the SV to use an
4418 outside string. The C<ptr> should point to memory that was allocated
4419 by C<malloc>. The string length, C<len>, must be supplied. By default
4420 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4421 so that pointer should not be freed or used by the programmer after
4422 giving it to sv_usepvn, and neither should any pointers from "behind"
4423 that pointer (e.g. ptr + 1) be used.
4425 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4426 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4427 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4428 C<len>, and already meets the requirements for storing in C<SvPVX>)
4434 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4439 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4441 SV_CHECK_THINKFIRST_COW_DROP(sv);
4442 SvUPGRADE(sv, SVt_PV);
4445 if (flags & SV_SMAGIC)
4449 if (SvPVX_const(sv))
4453 if (flags & SV_HAS_TRAILING_NUL)
4454 assert(ptr[len] == '\0');
4457 allocate = (flags & SV_HAS_TRAILING_NUL)
4459 #ifdef Perl_safesysmalloc_size
4462 PERL_STRLEN_ROUNDUP(len + 1);
4464 if (flags & SV_HAS_TRAILING_NUL) {
4465 /* It's long enough - do nothing.
4466 Specfically Perl_newCONSTSUB is relying on this. */
4469 /* Force a move to shake out bugs in callers. */
4470 char *new_ptr = (char*)safemalloc(allocate);
4471 Copy(ptr, new_ptr, len, char);
4472 PoisonFree(ptr,len,char);
4476 ptr = (char*) saferealloc (ptr, allocate);
4479 #ifdef Perl_safesysmalloc_size
4480 SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4482 SvLEN_set(sv, allocate);
4486 if (!(flags & SV_HAS_TRAILING_NUL)) {
4489 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4491 if (flags & SV_SMAGIC)
4495 #ifdef PERL_OLD_COPY_ON_WRITE
4496 /* Need to do this *after* making the SV normal, as we need the buffer
4497 pointer to remain valid until after we've copied it. If we let go too early,
4498 another thread could invalidate it by unsharing last of the same hash key
4499 (which it can do by means other than releasing copy-on-write Svs)
4500 or by changing the other copy-on-write SVs in the loop. */
4502 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4504 PERL_ARGS_ASSERT_SV_RELEASE_COW;
4506 { /* this SV was SvIsCOW_normal(sv) */
4507 /* we need to find the SV pointing to us. */
4508 SV *current = SV_COW_NEXT_SV(after);
4510 if (current == sv) {
4511 /* The SV we point to points back to us (there were only two of us
4513 Hence other SV is no longer copy on write either. */
4515 SvREADONLY_off(after);
4517 /* We need to follow the pointers around the loop. */
4519 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4522 /* don't loop forever if the structure is bust, and we have
4523 a pointer into a closed loop. */
4524 assert (current != after);
4525 assert (SvPVX_const(current) == pvx);
4527 /* Make the SV before us point to the SV after us. */
4528 SV_COW_NEXT_SV_SET(current, after);
4534 =for apidoc sv_force_normal_flags
4536 Undo various types of fakery on an SV: if the PV is a shared string, make
4537 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4538 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4539 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4540 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4541 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4542 set to some other value.) In addition, the C<flags> parameter gets passed to
4543 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4544 with flags set to 0.
4550 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4554 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4556 #ifdef PERL_OLD_COPY_ON_WRITE
4557 if (SvREADONLY(sv)) {
4559 const char * const pvx = SvPVX_const(sv);
4560 const STRLEN len = SvLEN(sv);
4561 const STRLEN cur = SvCUR(sv);
4562 /* next COW sv in the loop. If len is 0 then this is a shared-hash
4563 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4564 we'll fail an assertion. */
4565 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4568 PerlIO_printf(Perl_debug_log,
4569 "Copy on write: Force normal %ld\n",
4575 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4578 if (flags & SV_COW_DROP_PV) {
4579 /* OK, so we don't need to copy our buffer. */
4582 SvGROW(sv, cur + 1);
4583 Move(pvx,SvPVX(sv),cur,char);
4588 sv_release_COW(sv, pvx, next);
4590 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4596 else if (IN_PERL_RUNTIME)
4597 Perl_croak(aTHX_ "%s", PL_no_modify);
4600 if (SvREADONLY(sv)) {
4602 const char * const pvx = SvPVX_const(sv);
4603 const STRLEN len = SvCUR(sv);
4608 SvGROW(sv, len + 1);
4609 Move(pvx,SvPVX(sv),len,char);
4611 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4613 else if (IN_PERL_RUNTIME)
4614 Perl_croak(aTHX_ "%s", PL_no_modify);
4618 sv_unref_flags(sv, flags);
4619 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4621 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
4622 /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous
4623 to sv_unglob. We only need it here, so inline it. */
4624 const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
4625 SV *const temp = newSV_type(new_type);
4626 void *const temp_p = SvANY(sv);
4628 if (new_type == SVt_PVMG) {
4629 SvMAGIC_set(temp, SvMAGIC(sv));
4630 SvMAGIC_set(sv, NULL);
4631 SvSTASH_set(temp, SvSTASH(sv));
4632 SvSTASH_set(sv, NULL);
4634 SvCUR_set(temp, SvCUR(sv));
4635 /* Remember that SvPVX is in the head, not the body. */
4637 SvLEN_set(temp, SvLEN(sv));
4638 /* This signals "buffer is owned by someone else" in sv_clear,
4639 which is the least effort way to stop it freeing the buffer.
4641 SvLEN_set(sv, SvLEN(sv)+1);
4643 /* Their buffer is already owned by someone else. */
4644 SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
4645 SvLEN_set(temp, SvCUR(sv)+1);
4648 /* Now swap the rest of the bodies. */
4650 SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
4651 SvFLAGS(sv) |= new_type;
4652 SvANY(sv) = SvANY(temp);
4654 SvFLAGS(temp) &= ~(SVTYPEMASK);
4655 SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
4656 SvANY(temp) = temp_p;
4665 Efficient removal of characters from the beginning of the string buffer.
4666 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4667 the string buffer. The C<ptr> becomes the first character of the adjusted
4668 string. Uses the "OOK hack".
4669 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4670 refer to the same chunk of data.
4676 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4682 const U8 *real_start;
4686 PERL_ARGS_ASSERT_SV_CHOP;
4688 if (!ptr || !SvPOKp(sv))
4690 delta = ptr - SvPVX_const(sv);
4692 /* Nothing to do. */
4695 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4696 nothing uses the value of ptr any more. */
4697 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4698 if (ptr <= SvPVX_const(sv))
4699 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4700 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4701 SV_CHECK_THINKFIRST(sv);
4702 if (delta > max_delta)
4703 Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4704 SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4705 SvPVX_const(sv) + max_delta);
4708 if (!SvLEN(sv)) { /* make copy of shared string */
4709 const char *pvx = SvPVX_const(sv);
4710 const STRLEN len = SvCUR(sv);
4711 SvGROW(sv, len + 1);
4712 Move(pvx,SvPVX(sv),len,char);
4715 SvFLAGS(sv) |= SVf_OOK;
4718 SvOOK_offset(sv, old_delta);
4720 SvLEN_set(sv, SvLEN(sv) - delta);
4721 SvCUR_set(sv, SvCUR(sv) - delta);
4722 SvPV_set(sv, SvPVX(sv) + delta);
4724 p = (U8 *)SvPVX_const(sv);
4729 real_start = p - delta;
4733 if (delta < 0x100) {
4737 p -= sizeof(STRLEN);
4738 Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4742 /* Fill the preceding buffer with sentinals to verify that no-one is
4744 while (p > real_start) {
4752 =for apidoc sv_catpvn
4754 Concatenates the string onto the end of the string which is in the SV. The
4755 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4756 status set, then the bytes appended should be valid UTF-8.
4757 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4759 =for apidoc sv_catpvn_flags
4761 Concatenates the string onto the end of the string which is in the SV. The
4762 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4763 status set, then the bytes appended should be valid UTF-8.
4764 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4765 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4766 in terms of this function.
4772 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4776 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4778 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4780 SvGROW(dsv, dlen + slen + 1);
4782 sstr = SvPVX_const(dsv);
4783 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4784 SvCUR_set(dsv, SvCUR(dsv) + slen);
4786 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4788 if (flags & SV_SMAGIC)
4793 =for apidoc sv_catsv
4795 Concatenates the string from SV C<ssv> onto the end of the string in
4796 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4797 not 'set' magic. See C<sv_catsv_mg>.
4799 =for apidoc sv_catsv_flags
4801 Concatenates the string from SV C<ssv> onto the end of the string in
4802 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4803 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4804 and C<sv_catsv_nomg> are implemented in terms of this function.
4809 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4813 PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4817 const char *spv = SvPV_const(ssv, slen);
4819 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4820 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4821 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4822 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4823 dsv->sv_flags doesn't have that bit set.
4824 Andy Dougherty 12 Oct 2001
4826 const I32 sutf8 = DO_UTF8(ssv);
4829 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4831 dutf8 = DO_UTF8(dsv);
4833 if (dutf8 != sutf8) {
4835 /* Not modifying source SV, so taking a temporary copy. */
4836 SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4838 sv_utf8_upgrade(csv);
4839 spv = SvPV_const(csv, slen);
4842 /* Leave enough space for the cat that's about to happen */
4843 sv_utf8_upgrade_flags_grow(dsv, 0, slen);
4845 sv_catpvn_nomg(dsv, spv, slen);
4848 if (flags & SV_SMAGIC)
4853 =for apidoc sv_catpv
4855 Concatenates the string onto the end of the string which is in the SV.
4856 If the SV has the UTF-8 status set, then the bytes appended should be
4857 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4862 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4865 register STRLEN len;
4869 PERL_ARGS_ASSERT_SV_CATPV;
4873 junk = SvPV_force(sv, tlen);
4875 SvGROW(sv, tlen + len + 1);
4877 ptr = SvPVX_const(sv);
4878 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4879 SvCUR_set(sv, SvCUR(sv) + len);
4880 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4885 =for apidoc sv_catpv_mg
4887 Like C<sv_catpv>, but also handles 'set' magic.
4893 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4895 PERL_ARGS_ASSERT_SV_CATPV_MG;
4904 Creates a new SV. A non-zero C<len> parameter indicates the number of
4905 bytes of preallocated string space the SV should have. An extra byte for a
4906 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
4907 space is allocated.) The reference count for the new SV is set to 1.
4909 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4910 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4911 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4912 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
4913 modules supporting older perls.
4919 Perl_newSV(pTHX_ const STRLEN len)
4926 sv_upgrade(sv, SVt_PV);
4927 SvGROW(sv, len + 1);
4932 =for apidoc sv_magicext
4934 Adds magic to an SV, upgrading it if necessary. Applies the
4935 supplied vtable and returns a pointer to the magic added.
4937 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4938 In particular, you can add magic to SvREADONLY SVs, and add more than
4939 one instance of the same 'how'.
4941 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4942 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4943 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4944 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4946 (This is now used as a subroutine by C<sv_magic>.)
4951 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
4952 const MGVTBL *const vtable, const char *const name, const I32 namlen)
4957 PERL_ARGS_ASSERT_SV_MAGICEXT;
4959 SvUPGRADE(sv, SVt_PVMG);
4960 Newxz(mg, 1, MAGIC);
4961 mg->mg_moremagic = SvMAGIC(sv);
4962 SvMAGIC_set(sv, mg);
4964 /* Sometimes a magic contains a reference loop, where the sv and
4965 object refer to each other. To prevent a reference loop that
4966 would prevent such objects being freed, we look for such loops
4967 and if we find one we avoid incrementing the object refcount.
4969 Note we cannot do this to avoid self-tie loops as intervening RV must
4970 have its REFCNT incremented to keep it in existence.
4973 if (!obj || obj == sv ||
4974 how == PERL_MAGIC_arylen ||
4975 how == PERL_MAGIC_symtab ||
4976 (SvTYPE(obj) == SVt_PVGV &&
4977 (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
4978 || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
4979 || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
4984 mg->mg_obj = SvREFCNT_inc_simple(obj);
4985 mg->mg_flags |= MGf_REFCOUNTED;
4988 /* Normal self-ties simply pass a null object, and instead of
4989 using mg_obj directly, use the SvTIED_obj macro to produce a
4990 new RV as needed. For glob "self-ties", we are tieing the PVIO
4991 with an RV obj pointing to the glob containing the PVIO. In
4992 this case, to avoid a reference loop, we need to weaken the
4996 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4997 obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5003 mg->mg_len = namlen;
5006 mg->mg_ptr = savepvn(name, namlen);
5007 else if (namlen == HEf_SVKEY) {
5008 /* Yes, this is casting away const. This is only for the case of
5009 HEf_SVKEY. I think we need to document this abberation of the
5010 constness of the API, rather than making name non-const, as
5011 that change propagating outwards a long way. */
5012 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5014 mg->mg_ptr = (char *) name;
5016 mg->mg_virtual = (MGVTBL *) vtable;
5020 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5025 =for apidoc sv_magic
5027 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5028 then adds a new magic item of type C<how> to the head of the magic list.
5030 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5031 handling of the C<name> and C<namlen> arguments.
5033 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5034 to add more than one instance of the same 'how'.
5040 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
5041 const char *const name, const I32 namlen)
5044 const MGVTBL *vtable;
5047 PERL_ARGS_ASSERT_SV_MAGIC;
5049 #ifdef PERL_OLD_COPY_ON_WRITE
5051 sv_force_normal_flags(sv, 0);
5053 if (SvREADONLY(sv)) {
5055 /* its okay to attach magic to shared strings; the subsequent
5056 * upgrade to PVMG will unshare the string */
5057 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
5060 && how != PERL_MAGIC_regex_global
5061 && how != PERL_MAGIC_bm
5062 && how != PERL_MAGIC_fm
5063 && how != PERL_MAGIC_sv
5064 && how != PERL_MAGIC_backref
5067 Perl_croak(aTHX_ "%s", PL_no_modify);
5070 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5071 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5072 /* sv_magic() refuses to add a magic of the same 'how' as an
5075 if (how == PERL_MAGIC_taint) {
5077 /* Any scalar which already had taint magic on which someone
5078 (erroneously?) did SvIOK_on() or similar will now be
5079 incorrectly sporting public "OK" flags. */
5080 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5088 vtable = &PL_vtbl_sv;
5090 case PERL_MAGIC_overload:
5091 vtable = &PL_vtbl_amagic;
5093 case PERL_MAGIC_overload_elem:
5094 vtable = &PL_vtbl_amagicelem;
5096 case PERL_MAGIC_overload_table:
5097 vtable = &PL_vtbl_ovrld;
5100 vtable = &PL_vtbl_bm;
5102 case PERL_MAGIC_regdata:
5103 vtable = &PL_vtbl_regdata;
5105 case PERL_MAGIC_regdatum:
5106 vtable = &PL_vtbl_regdatum;
5108 case PERL_MAGIC_env:
5109 vtable = &PL_vtbl_env;
5112 vtable = &PL_vtbl_fm;
5114 case PERL_MAGIC_envelem:
5115 vtable = &PL_vtbl_envelem;
5117 case PERL_MAGIC_regex_global:
5118 vtable = &PL_vtbl_mglob;
5120 case PERL_MAGIC_isa:
5121 vtable = &PL_vtbl_isa;
5123 case PERL_MAGIC_isaelem:
5124 vtable = &PL_vtbl_isaelem;
5126 case PERL_MAGIC_nkeys:
5127 vtable = &PL_vtbl_nkeys;
5129 case PERL_MAGIC_dbfile:
5132 case PERL_MAGIC_dbline:
5133 vtable = &PL_vtbl_dbline;
5135 #ifdef USE_LOCALE_COLLATE
5136 case PERL_MAGIC_collxfrm:
5137 vtable = &PL_vtbl_collxfrm;
5139 #endif /* USE_LOCALE_COLLATE */
5140 case PERL_MAGIC_tied:
5141 vtable = &PL_vtbl_pack;
5143 case PERL_MAGIC_tiedelem:
5144 case PERL_MAGIC_tiedscalar:
5145 vtable = &PL_vtbl_packelem;
5148 vtable = &PL_vtbl_regexp;
5150 case PERL_MAGIC_sig:
5151 vtable = &PL_vtbl_sig;
5153 case PERL_MAGIC_sigelem:
5154 vtable = &PL_vtbl_sigelem;
5156 case PERL_MAGIC_taint:
5157 vtable = &PL_vtbl_taint;
5159 case PERL_MAGIC_uvar:
5160 vtable = &PL_vtbl_uvar;
5162 case PERL_MAGIC_vec:
5163 vtable = &PL_vtbl_vec;
5165 case PERL_MAGIC_arylen_p:
5166 case PERL_MAGIC_rhash:
5167 case PERL_MAGIC_symtab:
5168 case PERL_MAGIC_vstring:
5171 case PERL_MAGIC_utf8:
5172 vtable = &PL_vtbl_utf8;
5174 case PERL_MAGIC_substr:
5175 vtable = &PL_vtbl_substr;
5177 case PERL_MAGIC_defelem:
5178 vtable = &PL_vtbl_defelem;
5180 case PERL_MAGIC_arylen:
5181 vtable = &PL_vtbl_arylen;
5183 case PERL_MAGIC_pos:
5184 vtable = &PL_vtbl_pos;
5186 case PERL_MAGIC_backref:
5187 vtable = &PL_vtbl_backref;
5189 case PERL_MAGIC_hintselem:
5190 vtable = &PL_vtbl_hintselem;
5192 case PERL_MAGIC_hints:
5193 vtable = &PL_vtbl_hints;
5195 case PERL_MAGIC_ext:
5196 /* Reserved for use by extensions not perl internals. */
5197 /* Useful for attaching extension internal data to perl vars. */
5198 /* Note that multiple extensions may clash if magical scalars */
5199 /* etc holding private data from one are passed to another. */
5203 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5206 /* Rest of work is done else where */
5207 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5210 case PERL_MAGIC_taint:
5213 case PERL_MAGIC_ext:
5214 case PERL_MAGIC_dbfile:
5221 =for apidoc sv_unmagic
5223 Removes all magic of type C<type> from an SV.
5229 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5234 PERL_ARGS_ASSERT_SV_UNMAGIC;
5236 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5238 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5239 for (mg = *mgp; mg; mg = *mgp) {
5240 if (mg->mg_type == type) {
5241 const MGVTBL* const vtbl = mg->mg_virtual;
5242 *mgp = mg->mg_moremagic;
5243 if (vtbl && vtbl->svt_free)
5244 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5245 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5247 Safefree(mg->mg_ptr);
5248 else if (mg->mg_len == HEf_SVKEY)
5249 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5250 else if (mg->mg_type == PERL_MAGIC_utf8)
5251 Safefree(mg->mg_ptr);
5253 if (mg->mg_flags & MGf_REFCOUNTED)
5254 SvREFCNT_dec(mg->mg_obj);
5258 mgp = &mg->mg_moremagic;
5261 if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
5262 mg_magical(sv); /* else fix the flags now */
5266 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5272 =for apidoc sv_rvweaken
5274 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5275 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5276 push a back-reference to this RV onto the array of backreferences
5277 associated with that magic. If the RV is magical, set magic will be
5278 called after the RV is cleared.
5284 Perl_sv_rvweaken(pTHX_ SV *const sv)
5288 PERL_ARGS_ASSERT_SV_RVWEAKEN;
5290 if (!SvOK(sv)) /* let undefs pass */
5293 Perl_croak(aTHX_ "Can't weaken a nonreference");
5294 else if (SvWEAKREF(sv)) {
5295 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5299 Perl_sv_add_backref(aTHX_ tsv, sv);
5305 /* Give tsv backref magic if it hasn't already got it, then push a
5306 * back-reference to sv onto the array associated with the backref magic.
5309 /* A discussion about the backreferences array and its refcount:
5311 * The AV holding the backreferences is pointed to either as the mg_obj of
5312 * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
5313 * structure, from the xhv_backreferences field. (A HV without hv_aux will
5314 * have the standard magic instead.) The array is created with a refcount
5315 * of 2. This means that if during global destruction the array gets
5316 * picked on first to have its refcount decremented by the random zapper,
5317 * it won't actually be freed, meaning it's still theere for when its
5318 * parent gets freed.
5319 * When the parent SV is freed, in the case of magic, the magic is freed,
5320 * Perl_magic_killbackrefs is called which decrements one refcount, then
5321 * mg_obj is freed which kills the second count.
5322 * In the vase of a HV being freed, one ref is removed by
5323 * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
5328 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5333 PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5335 if (SvTYPE(tsv) == SVt_PVHV) {
5336 AV **const avp = Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5340 /* There is no AV in the offical place - try a fixup. */
5341 MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
5344 /* Aha. They've got it stowed in magic. Bring it back. */
5345 av = MUTABLE_AV(mg->mg_obj);
5346 /* Stop mg_free decreasing the refernce count. */
5348 /* Stop mg_free even calling the destructor, given that
5349 there's no AV to free up. */
5351 sv_unmagic(tsv, PERL_MAGIC_backref);
5355 SvREFCNT_inc_simple_void(av); /* see discussion above */
5360 const MAGIC *const mg
5361 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5363 av = MUTABLE_AV(mg->mg_obj);
5367 sv_magic(tsv, MUTABLE_SV(av), PERL_MAGIC_backref, NULL, 0);
5368 /* av now has a refcnt of 2; see discussion above */
5371 if (AvFILLp(av) >= AvMAX(av)) {
5372 av_extend(av, AvFILLp(av)+1);
5374 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5377 /* delete a back-reference to ourselves from the backref magic associated
5378 * with the SV we point to.
5382 S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5389 PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5391 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5392 av = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5393 /* We mustn't attempt to "fix up" the hash here by moving the
5394 backreference array back to the hv_aux structure, as that is stored
5395 in the main HvARRAY(), and hfreentries assumes that no-one
5396 reallocates HvARRAY() while it is running. */
5399 const MAGIC *const mg
5400 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5402 av = MUTABLE_AV(mg->mg_obj);
5406 Perl_croak(aTHX_ "panic: del_backref");
5408 assert(!SvIS_FREED(av));
5411 /* We shouldn't be in here more than once, but for paranoia reasons lets
5413 for (i = AvFILLp(av); i >= 0; i--) {
5415 const SSize_t fill = AvFILLp(av);
5417 /* We weren't the last entry.
5418 An unordered list has this property that you can take the
5419 last element off the end to fill the hole, and it's still
5420 an unordered list :-)
5425 AvFILLp(av) = fill - 1;
5431 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5433 SV **svp = AvARRAY(av);
5435 PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5436 PERL_UNUSED_ARG(sv);
5438 assert(!svp || !SvIS_FREED(av));
5440 SV *const *const last = svp + AvFILLp(av);
5442 while (svp <= last) {
5444 SV *const referrer = *svp;
5445 if (SvWEAKREF(referrer)) {
5446 /* XXX Should we check that it hasn't changed? */
5447 SvRV_set(referrer, 0);
5449 SvWEAKREF_off(referrer);
5450 SvSETMAGIC(referrer);
5451 } else if (SvTYPE(referrer) == SVt_PVGV ||
5452 SvTYPE(referrer) == SVt_PVLV) {
5453 /* You lookin' at me? */
5454 assert(GvSTASH(referrer));
5455 assert(GvSTASH(referrer) == (const HV *)sv);
5456 GvSTASH(referrer) = 0;
5459 "panic: magic_killbackrefs (flags=%"UVxf")",
5460 (UV)SvFLAGS(referrer));
5468 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5473 =for apidoc sv_insert
5475 Inserts a string at the specified offset/length within the SV. Similar to
5476 the Perl substr() function. Handles get magic.
5478 =for apidoc sv_insert_flags
5480 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5486 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5491 register char *midend;
5492 register char *bigend;
5496 PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5499 Perl_croak(aTHX_ "Can't modify non-existent substring");
5500 SvPV_force_flags(bigstr, curlen, flags);
5501 (void)SvPOK_only_UTF8(bigstr);
5502 if (offset + len > curlen) {
5503 SvGROW(bigstr, offset+len+1);
5504 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5505 SvCUR_set(bigstr, offset+len);
5509 i = littlelen - len;
5510 if (i > 0) { /* string might grow */
5511 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5512 mid = big + offset + len;
5513 midend = bigend = big + SvCUR(bigstr);
5516 while (midend > mid) /* shove everything down */
5517 *--bigend = *--midend;
5518 Move(little,big+offset,littlelen,char);
5519 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5524 Move(little,SvPVX(bigstr)+offset,len,char);
5529 big = SvPVX(bigstr);
5532 bigend = big + SvCUR(bigstr);
5534 if (midend > bigend)
5535 Perl_croak(aTHX_ "panic: sv_insert");
5537 if (mid - big > bigend - midend) { /* faster to shorten from end */
5539 Move(little, mid, littlelen,char);
5542 i = bigend - midend;
5544 Move(midend, mid, i,char);
5548 SvCUR_set(bigstr, mid - big);
5550 else if ((i = mid - big)) { /* faster from front */
5551 midend -= littlelen;
5553 Move(big, midend - i, i, char);
5554 sv_chop(bigstr,midend-i);
5556 Move(little, mid, littlelen,char);
5558 else if (littlelen) {
5559 midend -= littlelen;
5560 sv_chop(bigstr,midend);
5561 Move(little,midend,littlelen,char);
5564 sv_chop(bigstr,midend);
5570 =for apidoc sv_replace
5572 Make the first argument a copy of the second, then delete the original.
5573 The target SV physically takes over ownership of the body of the source SV
5574 and inherits its flags; however, the target keeps any magic it owns,
5575 and any magic in the source is discarded.
5576 Note that this is a rather specialist SV copying operation; most of the
5577 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5583 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5586 const U32 refcnt = SvREFCNT(sv);
5588 PERL_ARGS_ASSERT_SV_REPLACE;
5590 SV_CHECK_THINKFIRST_COW_DROP(sv);
5591 if (SvREFCNT(nsv) != 1) {
5592 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
5593 " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
5595 if (SvMAGICAL(sv)) {
5599 sv_upgrade(nsv, SVt_PVMG);
5600 SvMAGIC_set(nsv, SvMAGIC(sv));
5601 SvFLAGS(nsv) |= SvMAGICAL(sv);
5603 SvMAGIC_set(sv, NULL);
5607 assert(!SvREFCNT(sv));
5608 #ifdef DEBUG_LEAKING_SCALARS
5609 sv->sv_flags = nsv->sv_flags;
5610 sv->sv_any = nsv->sv_any;
5611 sv->sv_refcnt = nsv->sv_refcnt;
5612 sv->sv_u = nsv->sv_u;
5614 StructCopy(nsv,sv,SV);
5616 if(SvTYPE(sv) == SVt_IV) {
5618 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5622 #ifdef PERL_OLD_COPY_ON_WRITE
5623 if (SvIsCOW_normal(nsv)) {
5624 /* We need to follow the pointers around the loop to make the
5625 previous SV point to sv, rather than nsv. */
5628 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5631 assert(SvPVX_const(current) == SvPVX_const(nsv));
5633 /* Make the SV before us point to the SV after us. */
5635 PerlIO_printf(Perl_debug_log, "previous is\n");
5637 PerlIO_printf(Perl_debug_log,
5638 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5639 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5641 SV_COW_NEXT_SV_SET(current, sv);
5644 SvREFCNT(sv) = refcnt;
5645 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5651 =for apidoc sv_clear
5653 Clear an SV: call any destructors, free up any memory used by the body,
5654 and free the body itself. The SV's head is I<not> freed, although
5655 its type is set to all 1's so that it won't inadvertently be assumed
5656 to be live during global destruction etc.
5657 This function should only be called when REFCNT is zero. Most of the time
5658 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5665 Perl_sv_clear(pTHX_ register SV *const sv)
5668 const U32 type = SvTYPE(sv);
5669 const struct body_details *const sv_type_details
5670 = bodies_by_type + type;
5673 PERL_ARGS_ASSERT_SV_CLEAR;
5674 assert(SvREFCNT(sv) == 0);
5675 assert(SvTYPE(sv) != SVTYPEMASK);
5677 if (type <= SVt_IV) {
5678 /* See the comment in sv.h about the collusion between this early
5679 return and the overloading of the NULL and IV slots in the size
5682 SV * const target = SvRV(sv);
5684 sv_del_backref(target, sv);
5686 SvREFCNT_dec(target);
5688 SvFLAGS(sv) &= SVf_BREAK;
5689 SvFLAGS(sv) |= SVTYPEMASK;
5694 if (PL_defstash && /* Still have a symbol table? */
5701 stash = SvSTASH(sv);
5702 destructor = StashHANDLER(stash,DESTROY);
5704 /* A constant subroutine can have no side effects, so
5705 don't bother calling it. */
5706 && !CvCONST(destructor)
5707 /* Don't bother calling an empty destructor */
5708 && (CvISXSUB(destructor)
5709 || (CvSTART(destructor)
5710 && (CvSTART(destructor)->op_next->op_type != OP_LEAVESUB))))
5712 SV* const tmpref = newRV(sv);
5713 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5715 PUSHSTACKi(PERLSI_DESTROY);
5720 call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5726 if(SvREFCNT(tmpref) < 2) {
5727 /* tmpref is not kept alive! */
5729 SvRV_set(tmpref, NULL);
5732 SvREFCNT_dec(tmpref);
5734 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5738 if (PL_in_clean_objs)
5739 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5741 /* DESTROY gave object new lease on life */
5747 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5748 SvOBJECT_off(sv); /* Curse the object. */
5749 if (type != SVt_PVIO)
5750 --PL_sv_objcount; /* XXX Might want something more general */
5753 if (type >= SVt_PVMG) {
5754 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
5755 SvREFCNT_dec(SvOURSTASH(sv));
5756 } else if (SvMAGIC(sv))
5758 if (type == SVt_PVMG && SvPAD_TYPED(sv))
5759 SvREFCNT_dec(SvSTASH(sv));
5762 /* case SVt_BIND: */
5765 IoIFP(sv) != PerlIO_stdin() &&
5766 IoIFP(sv) != PerlIO_stdout() &&
5767 IoIFP(sv) != PerlIO_stderr())
5769 io_close(MUTABLE_IO(sv), FALSE);
5771 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5772 PerlDir_close(IoDIRP(sv));
5773 IoDIRP(sv) = (DIR*)NULL;
5774 Safefree(IoTOP_NAME(sv));
5775 Safefree(IoFMT_NAME(sv));
5776 Safefree(IoBOTTOM_NAME(sv));
5779 /* FIXME for plugins */
5780 pregfree2((REGEXP*) sv);
5784 cv_undef(MUTABLE_CV(sv));
5787 if (PL_last_swash_hv == (const HV *)sv) {
5788 PL_last_swash_hv = NULL;
5790 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
5791 hv_undef(MUTABLE_HV(sv));
5794 if (PL_comppad == MUTABLE_AV(sv)) {
5798 av_undef(MUTABLE_AV(sv));
5801 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5802 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5803 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5804 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5806 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5807 SvREFCNT_dec(LvTARG(sv));
5809 if (isGV_with_GP(sv)) {
5810 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
5811 && HvNAME_get(stash))
5812 mro_method_changed_in(stash);
5813 gp_free(MUTABLE_GV(sv));
5815 unshare_hek(GvNAME_HEK(sv));
5816 /* If we're in a stash, we don't own a reference to it. However it does
5817 have a back reference to us, which needs to be cleared. */
5818 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
5819 sv_del_backref(MUTABLE_SV(stash), sv);
5821 /* FIXME. There are probably more unreferenced pointers to SVs in the
5822 interpreter struct that we should check and tidy in a similar
5824 if ((const GV *)sv == PL_last_in_gv)
5825 PL_last_in_gv = NULL;
5831 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5834 SvOOK_offset(sv, offset);
5835 SvPV_set(sv, SvPVX_mutable(sv) - offset);
5836 /* Don't even bother with turning off the OOK flag. */
5839 SV * const target = SvRV(sv);
5841 sv_del_backref(target, sv);
5843 SvREFCNT_dec(target);
5845 #ifdef PERL_OLD_COPY_ON_WRITE
5846 else if (SvPVX_const(sv)) {
5849 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5853 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
5855 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5859 } else if (SvLEN(sv)) {
5860 Safefree(SvPVX_const(sv));
5864 else if (SvPVX_const(sv) && SvLEN(sv))
5865 Safefree(SvPVX_mutable(sv));
5866 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5867 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5876 SvFLAGS(sv) &= SVf_BREAK;
5877 SvFLAGS(sv) |= SVTYPEMASK;
5879 if (sv_type_details->arena) {
5880 del_body(((char *)SvANY(sv) + sv_type_details->offset),
5881 &PL_body_roots[type]);
5883 else if (sv_type_details->body_size) {
5884 my_safefree(SvANY(sv));
5889 =for apidoc sv_newref
5891 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5898 Perl_sv_newref(pTHX_ SV *const sv)
5900 PERL_UNUSED_CONTEXT;
5909 Decrement an SV's reference count, and if it drops to zero, call
5910 C<sv_clear> to invoke destructors and free up any memory used by
5911 the body; finally, deallocate the SV's head itself.
5912 Normally called via a wrapper macro C<SvREFCNT_dec>.
5918 Perl_sv_free(pTHX_ SV *const sv)
5923 if (SvREFCNT(sv) == 0) {
5924 if (SvFLAGS(sv) & SVf_BREAK)
5925 /* this SV's refcnt has been artificially decremented to
5926 * trigger cleanup */
5928 if (PL_in_clean_all) /* All is fair */
5930 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5931 /* make sure SvREFCNT(sv)==0 happens very seldom */
5932 SvREFCNT(sv) = (~(U32)0)/2;
5935 if (ckWARN_d(WARN_INTERNAL)) {
5936 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5937 Perl_dump_sv_child(aTHX_ sv);
5939 #ifdef DEBUG_LEAKING_SCALARS
5942 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5943 if (PL_warnhook == PERL_WARNHOOK_FATAL
5944 || ckDEAD(packWARN(WARN_INTERNAL))) {
5945 /* Don't let Perl_warner cause us to escape our fate: */
5949 /* This may not return: */
5950 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5951 "Attempt to free unreferenced scalar: SV 0x%"UVxf
5952 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5955 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5960 if (--(SvREFCNT(sv)) > 0)
5962 Perl_sv_free2(aTHX_ sv);
5966 Perl_sv_free2(pTHX_ SV *const sv)
5970 PERL_ARGS_ASSERT_SV_FREE2;
5974 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
5975 "Attempt to free temp prematurely: SV 0x%"UVxf
5976 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5980 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5981 /* make sure SvREFCNT(sv)==0 happens very seldom */
5982 SvREFCNT(sv) = (~(U32)0)/2;
5993 Returns the length of the string in the SV. Handles magic and type
5994 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6000 Perl_sv_len(pTHX_ register SV *const sv)
6008 len = mg_length(sv);
6010 (void)SvPV_const(sv, len);
6015 =for apidoc sv_len_utf8
6017 Returns the number of characters in the string in an SV, counting wide
6018 UTF-8 bytes as a single character. Handles magic and type coercion.
6024 * The length is cached in PERL_MAGIC_utf8, in the mg_len field. Also the
6025 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6026 * (Note that the mg_len is not the length of the mg_ptr field.
6027 * This allows the cache to store the character length of the string without
6028 * needing to malloc() extra storage to attach to the mg_ptr.)
6033 Perl_sv_len_utf8(pTHX_ register SV *const sv)
6039 return mg_length(sv);
6043 const U8 *s = (U8*)SvPV_const(sv, len);
6047 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6049 if (mg && mg->mg_len != -1) {
6051 if (PL_utf8cache < 0) {
6052 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6054 /* Need to turn the assertions off otherwise we may
6055 recurse infinitely while printing error messages.
6057 SAVEI8(PL_utf8cache);
6059 Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
6060 " real %"UVuf" for %"SVf,
6061 (UV) ulen, (UV) real, SVfARG(sv));
6066 ulen = Perl_utf8_length(aTHX_ s, s + len);
6067 if (!SvREADONLY(sv)) {
6068 if (!mg && (SvTYPE(sv) < SVt_PVMG ||
6069 !(mg = mg_find(sv, PERL_MAGIC_utf8)))) {
6070 mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
6071 &PL_vtbl_utf8, 0, 0);
6075 /* For now, treat "overflowed" as "still unknown".
6077 if (ulen != (STRLEN) mg->mg_len)
6083 return Perl_utf8_length(aTHX_ s, s + len);
6087 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6090 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6093 const U8 *s = start;
6095 PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6097 while (s < send && uoffset--)
6100 /* This is the existing behaviour. Possibly it should be a croak, as
6101 it's actually a bounds error */
6107 /* Given the length of the string in both bytes and UTF-8 characters, decide
6108 whether to walk forwards or backwards to find the byte corresponding to
6109 the passed in UTF-8 offset. */
6111 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6112 const STRLEN uoffset, const STRLEN uend)
6114 STRLEN backw = uend - uoffset;
6116 PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6118 if (uoffset < 2 * backw) {
6119 /* The assumption is that going forwards is twice the speed of going
6120 forward (that's where the 2 * backw comes from).
6121 (The real figure of course depends on the UTF-8 data.) */
6122 return sv_pos_u2b_forwards(start, send, uoffset);
6127 while (UTF8_IS_CONTINUATION(*send))
6130 return send - start;
6133 /* For the string representation of the given scalar, find the byte
6134 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
6135 give another position in the string, *before* the sought offset, which
6136 (which is always true, as 0, 0 is a valid pair of positions), which should
6137 help reduce the amount of linear searching.
6138 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6139 will be used to reduce the amount of linear searching. The cache will be
6140 created if necessary, and the found value offered to it for update. */
6142 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6143 const U8 *const send, const STRLEN uoffset,
6144 STRLEN uoffset0, STRLEN boffset0)
6146 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
6149 PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6151 assert (uoffset >= uoffset0);
6155 && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
6156 (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
6157 if ((*mgp)->mg_ptr) {
6158 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6159 if (cache[0] == uoffset) {
6160 /* An exact match. */
6163 if (cache[2] == uoffset) {
6164 /* An exact match. */
6168 if (cache[0] < uoffset) {
6169 /* The cache already knows part of the way. */
6170 if (cache[0] > uoffset0) {
6171 /* The cache knows more than the passed in pair */
6172 uoffset0 = cache[0];
6173 boffset0 = cache[1];
6175 if ((*mgp)->mg_len != -1) {
6176 /* And we know the end too. */
6178 + sv_pos_u2b_midway(start + boffset0, send,
6180 (*mgp)->mg_len - uoffset0);
6183 + sv_pos_u2b_forwards(start + boffset0,
6184 send, uoffset - uoffset0);
6187 else if (cache[2] < uoffset) {
6188 /* We're between the two cache entries. */
6189 if (cache[2] > uoffset0) {
6190 /* and the cache knows more than the passed in pair */
6191 uoffset0 = cache[2];
6192 boffset0 = cache[3];
6196 + sv_pos_u2b_midway(start + boffset0,
6199 cache[0] - uoffset0);
6202 + sv_pos_u2b_midway(start + boffset0,
6205 cache[2] - uoffset0);
6209 else if ((*mgp)->mg_len != -1) {
6210 /* If we can take advantage of a passed in offset, do so. */
6211 /* In fact, offset0 is either 0, or less than offset, so don't
6212 need to worry about the other possibility. */
6214 + sv_pos_u2b_midway(start + boffset0, send,
6216 (*mgp)->mg_len - uoffset0);
6221 if (!found || PL_utf8cache < 0) {
6222 const STRLEN real_boffset
6223 = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6224 send, uoffset - uoffset0);
6226 if (found && PL_utf8cache < 0) {
6227 if (real_boffset != boffset) {
6228 /* Need to turn the assertions off otherwise we may recurse
6229 infinitely while printing error messages. */
6230 SAVEI8(PL_utf8cache);
6232 Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
6233 " real %"UVuf" for %"SVf,
6234 (UV) boffset, (UV) real_boffset, SVfARG(sv));
6237 boffset = real_boffset;
6241 utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6247 =for apidoc sv_pos_u2b_flags
6249 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6250 the start of the string, to a count of the equivalent number of bytes; if
6251 lenp is non-zero, it does the same to lenp, but this time starting from
6252 the offset, rather than from the start of the string. Handles type coercion.
6253 I<flags> is passed to C<SvPV_flags>, and usually should be
6254 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
6260 * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
6261 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6262 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6267 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
6274 PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
6276 start = (U8*)SvPV_flags(sv, len, flags);
6278 const U8 * const send = start + len;
6280 boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
6283 /* Convert the relative offset to absolute. */
6284 const STRLEN uoffset2 = uoffset + *lenp;
6285 const STRLEN boffset2
6286 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6287 uoffset, boffset) - boffset;
6301 =for apidoc sv_pos_u2b
6303 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6304 the start of the string, to a count of the equivalent number of bytes; if
6305 lenp is non-zero, it does the same to lenp, but this time starting from
6306 the offset, rather than from the start of the string. Handles magic and
6309 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
6316 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6317 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6318 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6322 /* This function is subject to size and sign problems */
6325 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6327 PERL_ARGS_ASSERT_SV_POS_U2B;
6330 STRLEN ulen = (STRLEN)*lenp;
6331 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
6332 SV_GMAGIC|SV_CONST_RETURN);
6335 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
6336 SV_GMAGIC|SV_CONST_RETURN);
6340 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6341 byte length pairing. The (byte) length of the total SV is passed in too,
6342 as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6343 may not have updated SvCUR, so we can't rely on reading it directly.
6345 The proffered utf8/byte length pairing isn't used if the cache already has
6346 two pairs, and swapping either for the proffered pair would increase the
6347 RMS of the intervals between known byte offsets.
6349 The cache itself consists of 4 STRLEN values
6350 0: larger UTF-8 offset
6351 1: corresponding byte offset
6352 2: smaller UTF-8 offset
6353 3: corresponding byte offset
6355 Unused cache pairs have the value 0, 0.
6356 Keeping the cache "backwards" means that the invariant of
6357 cache[0] >= cache[2] is maintained even with empty slots, which means that
6358 the code that uses it doesn't need to worry if only 1 entry has actually
6359 been set to non-zero. It also makes the "position beyond the end of the
6360 cache" logic much simpler, as the first slot is always the one to start
6364 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6365 const STRLEN utf8, const STRLEN blen)
6369 PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6374 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6375 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6376 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6378 (*mgp)->mg_len = -1;
6382 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6383 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6384 (*mgp)->mg_ptr = (char *) cache;
6388 if (PL_utf8cache < 0 && SvPOKp(sv)) {
6389 /* SvPOKp() because it's possible that sv has string overloading, and
6390 therefore is a reference, hence SvPVX() is actually a pointer.
6391 This cures the (very real) symptoms of RT 69422, but I'm not actually
6392 sure whether we should even be caching the results of UTF-8
6393 operations on overloading, given that nothing stops overloading
6394 returning a different value every time it's called. */
6395 const U8 *start = (const U8 *) SvPVX_const(sv);
6396 const STRLEN realutf8 = utf8_length(start, start + byte);
6398 if (realutf8 != utf8) {
6399 /* Need to turn the assertions off otherwise we may recurse
6400 infinitely while printing error messages. */
6401 SAVEI8(PL_utf8cache);
6403 Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
6404 " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
6408 /* Cache is held with the later position first, to simplify the code
6409 that deals with unbounded ends. */
6411 ASSERT_UTF8_CACHE(cache);
6412 if (cache[1] == 0) {
6413 /* Cache is totally empty */
6416 } else if (cache[3] == 0) {
6417 if (byte > cache[1]) {
6418 /* New one is larger, so goes first. */
6419 cache[2] = cache[0];
6420 cache[3] = cache[1];
6428 #define THREEWAY_SQUARE(a,b,c,d) \
6429 ((float)((d) - (c))) * ((float)((d) - (c))) \
6430 + ((float)((c) - (b))) * ((float)((c) - (b))) \
6431 + ((float)((b) - (a))) * ((float)((b) - (a)))
6433 /* Cache has 2 slots in use, and we know three potential pairs.
6434 Keep the two that give the lowest RMS distance. Do the
6435 calcualation in bytes simply because we always know the byte
6436 length. squareroot has the same ordering as the positive value,
6437 so don't bother with the actual square root. */
6438 const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6439 if (byte > cache[1]) {
6440 /* New position is after the existing pair of pairs. */
6441 const float keep_earlier
6442 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6443 const float keep_later
6444 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6446 if (keep_later < keep_earlier) {
6447 if (keep_later < existing) {
6448 cache[2] = cache[0];
6449 cache[3] = cache[1];
6455 if (keep_earlier < existing) {
6461 else if (byte > cache[3]) {
6462 /* New position is between the existing pair of pairs. */
6463 const float keep_earlier
6464 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6465 const float keep_later
6466 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6468 if (keep_later < keep_earlier) {
6469 if (keep_later < existing) {
6475 if (keep_earlier < existing) {
6482 /* New position is before the existing pair of pairs. */
6483 const float keep_earlier
6484 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6485 const float keep_later
6486 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6488 if (keep_later < keep_earlier) {
6489 if (keep_later < existing) {
6495 if (keep_earlier < existing) {
6496 cache[0] = cache[2];
6497 cache[1] = cache[3];
6504 ASSERT_UTF8_CACHE(cache);
6507 /* We already know all of the way, now we may be able to walk back. The same
6508 assumption is made as in S_sv_pos_u2b_midway(), namely that walking
6509 backward is half the speed of walking forward. */
6511 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
6512 const U8 *end, STRLEN endu)
6514 const STRLEN forw = target - s;
6515 STRLEN backw = end - target;
6517 PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
6519 if (forw < 2 * backw) {
6520 return utf8_length(s, target);
6523 while (end > target) {
6525 while (UTF8_IS_CONTINUATION(*end)) {
6534 =for apidoc sv_pos_b2u
6536 Converts the value pointed to by offsetp from a count of bytes from the
6537 start of the string, to a count of the equivalent number of UTF-8 chars.
6538 Handles magic and type coercion.
6544 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6545 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6550 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
6553 const STRLEN byte = *offsetp;
6554 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
6560 PERL_ARGS_ASSERT_SV_POS_B2U;
6565 s = (const U8*)SvPV_const(sv, blen);
6568 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6574 && SvTYPE(sv) >= SVt_PVMG
6575 && (mg = mg_find(sv, PERL_MAGIC_utf8)))
6578 STRLEN * const cache = (STRLEN *) mg->mg_ptr;
6579 if (cache[1] == byte) {
6580 /* An exact match. */
6581 *offsetp = cache[0];
6584 if (cache[3] == byte) {
6585 /* An exact match. */
6586 *offsetp = cache[2];
6590 if (cache[1] < byte) {
6591 /* We already know part of the way. */
6592 if (mg->mg_len != -1) {
6593 /* Actually, we know the end too. */
6595 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
6596 s + blen, mg->mg_len - cache[0]);
6598 len = cache[0] + utf8_length(s + cache[1], send);
6601 else if (cache[3] < byte) {
6602 /* We're between the two cached pairs, so we do the calculation
6603 offset by the byte/utf-8 positions for the earlier pair,
6604 then add the utf-8 characters from the string start to
6606 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
6607 s + cache[1], cache[0] - cache[2])
6611 else { /* cache[3] > byte */
6612 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
6616 ASSERT_UTF8_CACHE(cache);
6618 } else if (mg->mg_len != -1) {
6619 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
6623 if (!found || PL_utf8cache < 0) {
6624 const STRLEN real_len = utf8_length(s, send);
6626 if (found && PL_utf8cache < 0) {
6627 if (len != real_len) {
6628 /* Need to turn the assertions off otherwise we may recurse
6629 infinitely while printing error messages. */
6630 SAVEI8(PL_utf8cache);
6632 Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
6633 " real %"UVuf" for %"SVf,
6634 (UV) len, (UV) real_len, SVfARG(sv));
6642 utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
6648 Returns a boolean indicating whether the strings in the two SVs are
6649 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6650 coerce its args to strings if necessary.
6656 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6665 SV* svrecode = NULL;
6672 /* if pv1 and pv2 are the same, second SvPV_const call may
6673 * invalidate pv1, so we may need to make a copy */
6674 if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
6675 pv1 = SvPV_const(sv1, cur1);
6676 sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
6678 pv1 = SvPV_const(sv1, cur1);
6686 pv2 = SvPV_const(sv2, cur2);
6688 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6689 /* Differing utf8ness.
6690 * Do not UTF8size the comparands as a side-effect. */
6693 svrecode = newSVpvn(pv2, cur2);
6694 sv_recode_to_utf8(svrecode, PL_encoding);
6695 pv2 = SvPV_const(svrecode, cur2);
6698 svrecode = newSVpvn(pv1, cur1);
6699 sv_recode_to_utf8(svrecode, PL_encoding);
6700 pv1 = SvPV_const(svrecode, cur1);
6702 /* Now both are in UTF-8. */
6704 SvREFCNT_dec(svrecode);
6709 bool is_utf8 = TRUE;
6712 /* sv1 is the UTF-8 one,
6713 * if is equal it must be downgrade-able */
6714 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6720 /* sv2 is the UTF-8 one,
6721 * if is equal it must be downgrade-able */
6722 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6728 /* Downgrade not possible - cannot be eq */
6736 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6738 SvREFCNT_dec(svrecode);
6748 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6749 string in C<sv1> is less than, equal to, or greater than the string in
6750 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6751 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6757 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
6761 const char *pv1, *pv2;
6764 SV *svrecode = NULL;
6771 pv1 = SvPV_const(sv1, cur1);
6778 pv2 = SvPV_const(sv2, cur2);
6780 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6781 /* Differing utf8ness.
6782 * Do not UTF8size the comparands as a side-effect. */
6785 svrecode = newSVpvn(pv2, cur2);
6786 sv_recode_to_utf8(svrecode, PL_encoding);
6787 pv2 = SvPV_const(svrecode, cur2);
6790 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6795 svrecode = newSVpvn(pv1, cur1);
6796 sv_recode_to_utf8(svrecode, PL_encoding);
6797 pv1 = SvPV_const(svrecode, cur1);
6800 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6806 cmp = cur2 ? -1 : 0;
6810 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6813 cmp = retval < 0 ? -1 : 1;
6814 } else if (cur1 == cur2) {
6817 cmp = cur1 < cur2 ? -1 : 1;
6821 SvREFCNT_dec(svrecode);
6829 =for apidoc sv_cmp_locale
6831 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6832 'use bytes' aware, handles get magic, and will coerce its args to strings
6833 if necessary. See also C<sv_cmp>.
6839 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
6842 #ifdef USE_LOCALE_COLLATE
6848 if (PL_collation_standard)
6852 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6854 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6856 if (!pv1 || !len1) {
6867 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6870 return retval < 0 ? -1 : 1;
6873 * When the result of collation is equality, that doesn't mean
6874 * that there are no differences -- some locales exclude some
6875 * characters from consideration. So to avoid false equalities,
6876 * we use the raw string as a tiebreaker.
6882 #endif /* USE_LOCALE_COLLATE */
6884 return sv_cmp(sv1, sv2);
6888 #ifdef USE_LOCALE_COLLATE
6891 =for apidoc sv_collxfrm
6893 Add Collate Transform magic to an SV if it doesn't already have it.
6895 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6896 scalar data of the variable, but transformed to such a format that a normal
6897 memory comparison can be used to compare the data according to the locale
6904 Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
6909 PERL_ARGS_ASSERT_SV_COLLXFRM;
6911 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6912 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6918 Safefree(mg->mg_ptr);
6919 s = SvPV_const(sv, len);
6920 if ((xf = mem_collxfrm(s, len, &xlen))) {
6922 #ifdef PERL_OLD_COPY_ON_WRITE
6924 sv_force_normal_flags(sv, 0);
6926 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
6940 if (mg && mg->mg_ptr) {
6942 return mg->mg_ptr + sizeof(PL_collation_ix);
6950 #endif /* USE_LOCALE_COLLATE */
6955 Get a line from the filehandle and store it into the SV, optionally
6956 appending to the currently-stored string.
6962 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
6967 register STDCHAR rslast;
6968 register STDCHAR *bp;
6973 PERL_ARGS_ASSERT_SV_GETS;
6975 if (SvTHINKFIRST(sv))
6976 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6977 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6979 However, perlbench says it's slower, because the existing swipe code
6980 is faster than copy on write.
6981 Swings and roundabouts. */
6982 SvUPGRADE(sv, SVt_PV);
6987 if (PerlIO_isutf8(fp)) {
6989 sv_utf8_upgrade_nomg(sv);
6990 sv_pos_u2b(sv,&append,0);
6992 } else if (SvUTF8(sv)) {
6993 SV * const tsv = newSV(0);
6994 sv_gets(tsv, fp, 0);
6995 sv_utf8_upgrade_nomg(tsv);
6996 SvCUR_set(sv,append);
6999 goto return_string_or_null;
7004 if (PerlIO_isutf8(fp))
7007 if (IN_PERL_COMPILETIME) {
7008 /* we always read code in line mode */
7012 else if (RsSNARF(PL_rs)) {
7013 /* If it is a regular disk file use size from stat() as estimate
7014 of amount we are going to read -- may result in mallocing
7015 more memory than we really need if the layers below reduce
7016 the size we read (e.g. CRLF or a gzip layer).
7019 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
7020 const Off_t offset = PerlIO_tell(fp);
7021 if (offset != (Off_t) -1 && st.st_size + append > offset) {
7022 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7028 else if (RsRECORD(PL_rs)) {
7036 /* Grab the size of the record we're getting */
7037 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7038 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7041 /* VMS wants read instead of fread, because fread doesn't respect */
7042 /* RMS record boundaries. This is not necessarily a good thing to be */
7043 /* doing, but we've got no other real choice - except avoid stdio
7044 as implementation - perhaps write a :vms layer ?
7046 fd = PerlIO_fileno(fp);
7047 if (fd == -1) { /* in-memory file from PerlIO::Scalar */
7048 bytesread = PerlIO_read(fp, buffer, recsize);
7051 bytesread = PerlLIO_read(fd, buffer, recsize);
7054 bytesread = PerlIO_read(fp, buffer, recsize);
7058 SvCUR_set(sv, bytesread + append);
7059 buffer[bytesread] = '\0';
7060 goto return_string_or_null;
7062 else if (RsPARA(PL_rs)) {
7068 /* Get $/ i.e. PL_rs into same encoding as stream wants */
7069 if (PerlIO_isutf8(fp)) {
7070 rsptr = SvPVutf8(PL_rs, rslen);
7073 if (SvUTF8(PL_rs)) {
7074 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7075 Perl_croak(aTHX_ "Wide character in $/");
7078 rsptr = SvPV_const(PL_rs, rslen);
7082 rslast = rslen ? rsptr[rslen - 1] : '\0';
7084 if (rspara) { /* have to do this both before and after */
7085 do { /* to make sure file boundaries work right */
7088 i = PerlIO_getc(fp);
7092 PerlIO_ungetc(fp,i);
7098 /* See if we know enough about I/O mechanism to cheat it ! */
7100 /* This used to be #ifdef test - it is made run-time test for ease
7101 of abstracting out stdio interface. One call should be cheap
7102 enough here - and may even be a macro allowing compile
7106 if (PerlIO_fast_gets(fp)) {
7109 * We're going to steal some values from the stdio struct
7110 * and put EVERYTHING in the innermost loop into registers.
7112 register STDCHAR *ptr;
7116 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7117 /* An ungetc()d char is handled separately from the regular
7118 * buffer, so we getc() it back out and stuff it in the buffer.
7120 i = PerlIO_getc(fp);
7121 if (i == EOF) return 0;
7122 *(--((*fp)->_ptr)) = (unsigned char) i;
7126 /* Here is some breathtakingly efficient cheating */
7128 cnt = PerlIO_get_cnt(fp); /* get count into register */
7129 /* make sure we have the room */
7130 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7131 /* Not room for all of it
7132 if we are looking for a separator and room for some
7134 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7135 /* just process what we have room for */
7136 shortbuffered = cnt - SvLEN(sv) + append + 1;
7137 cnt -= shortbuffered;
7141 /* remember that cnt can be negative */
7142 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7147 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
7148 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7149 DEBUG_P(PerlIO_printf(Perl_debug_log,
7150 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7151 DEBUG_P(PerlIO_printf(Perl_debug_log,
7152 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7153 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7154 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7159 while (cnt > 0) { /* this | eat */
7161 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7162 goto thats_all_folks; /* screams | sed :-) */
7166 Copy(ptr, bp, cnt, char); /* this | eat */
7167 bp += cnt; /* screams | dust */
7168 ptr += cnt; /* louder | sed :-) */
7173 if (shortbuffered) { /* oh well, must extend */
7174 cnt = shortbuffered;
7176 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7178 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7179 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7183 DEBUG_P(PerlIO_printf(Perl_debug_log,
7184 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7185 PTR2UV(ptr),(long)cnt));
7186 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7188 DEBUG_P(PerlIO_printf(Perl_debug_log,
7189 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7190 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7191 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7193 /* This used to call 'filbuf' in stdio form, but as that behaves like
7194 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7195 another abstraction. */
7196 i = PerlIO_getc(fp); /* get more characters */
7198 DEBUG_P(PerlIO_printf(Perl_debug_log,
7199 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7200 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7201 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7203 cnt = PerlIO_get_cnt(fp);
7204 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7205 DEBUG_P(PerlIO_printf(Perl_debug_log,
7206 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7208 if (i == EOF) /* all done for ever? */
7209 goto thats_really_all_folks;
7211 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7213 SvGROW(sv, bpx + cnt + 2);
7214 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7216 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7218 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7219 goto thats_all_folks;
7223 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7224 memNE((char*)bp - rslen, rsptr, rslen))
7225 goto screamer; /* go back to the fray */
7226 thats_really_all_folks:
7228 cnt += shortbuffered;
7229 DEBUG_P(PerlIO_printf(Perl_debug_log,
7230 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7231 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7232 DEBUG_P(PerlIO_printf(Perl_debug_log,
7233 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7234 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7235 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7237 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
7238 DEBUG_P(PerlIO_printf(Perl_debug_log,
7239 "Screamer: done, len=%ld, string=|%.*s|\n",
7240 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7244 /*The big, slow, and stupid way. */
7245 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
7246 STDCHAR *buf = NULL;
7247 Newx(buf, 8192, STDCHAR);
7255 register const STDCHAR * const bpe = buf + sizeof(buf);
7257 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7258 ; /* keep reading */
7262 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7263 /* Accomodate broken VAXC compiler, which applies U8 cast to
7264 * both args of ?: operator, causing EOF to change into 255
7267 i = (U8)buf[cnt - 1];
7273 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7275 sv_catpvn(sv, (char *) buf, cnt);
7277 sv_setpvn(sv, (char *) buf, cnt);
7279 if (i != EOF && /* joy */
7281 SvCUR(sv) < rslen ||
7282 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7286 * If we're reading from a TTY and we get a short read,
7287 * indicating that the user hit his EOF character, we need
7288 * to notice it now, because if we try to read from the TTY
7289 * again, the EOF condition will disappear.
7291 * The comparison of cnt to sizeof(buf) is an optimization
7292 * that prevents unnecessary calls to feof().
7296 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7300 #ifdef USE_HEAP_INSTEAD_OF_STACK
7305 if (rspara) { /* have to do this both before and after */
7306 while (i != EOF) { /* to make sure file boundaries work right */
7307 i = PerlIO_getc(fp);
7309 PerlIO_ungetc(fp,i);
7315 return_string_or_null:
7316 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7322 Auto-increment of the value in the SV, doing string to numeric conversion
7323 if necessary. Handles 'get' magic.
7329 Perl_sv_inc(pTHX_ register SV *const sv)
7338 if (SvTHINKFIRST(sv)) {
7340 sv_force_normal_flags(sv, 0);
7341 if (SvREADONLY(sv)) {
7342 if (IN_PERL_RUNTIME)
7343 Perl_croak(aTHX_ "%s", PL_no_modify);
7347 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7349 i = PTR2IV(SvRV(sv));
7354 flags = SvFLAGS(sv);
7355 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7356 /* It's (privately or publicly) a float, but not tested as an
7357 integer, so test it to see. */
7359 flags = SvFLAGS(sv);
7361 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7362 /* It's publicly an integer, or privately an integer-not-float */
7363 #ifdef PERL_PRESERVE_IVUV
7367 if (SvUVX(sv) == UV_MAX)
7368 sv_setnv(sv, UV_MAX_P1);
7370 (void)SvIOK_only_UV(sv);
7371 SvUV_set(sv, SvUVX(sv) + 1);
7373 if (SvIVX(sv) == IV_MAX)
7374 sv_setuv(sv, (UV)IV_MAX + 1);
7376 (void)SvIOK_only(sv);
7377 SvIV_set(sv, SvIVX(sv) + 1);
7382 if (flags & SVp_NOK) {
7383 const NV was = SvNVX(sv);
7384 if (NV_OVERFLOWS_INTEGERS_AT &&
7385 was >= NV_OVERFLOWS_INTEGERS_AT) {
7386 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7387 "Lost precision when incrementing %" NVff " by 1",
7390 (void)SvNOK_only(sv);
7391 SvNV_set(sv, was + 1.0);
7395 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7396 if ((flags & SVTYPEMASK) < SVt_PVIV)
7397 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
7398 (void)SvIOK_only(sv);
7403 while (isALPHA(*d)) d++;
7404 while (isDIGIT(*d)) d++;
7405 if (d < SvEND(sv)) {
7406 #ifdef PERL_PRESERVE_IVUV
7407 /* Got to punt this as an integer if needs be, but we don't issue
7408 warnings. Probably ought to make the sv_iv_please() that does
7409 the conversion if possible, and silently. */
7410 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7411 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7412 /* Need to try really hard to see if it's an integer.
7413 9.22337203685478e+18 is an integer.
7414 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7415 so $a="9.22337203685478e+18"; $a+0; $a++
7416 needs to be the same as $a="9.22337203685478e+18"; $a++
7423 /* sv_2iv *should* have made this an NV */
7424 if (flags & SVp_NOK) {
7425 (void)SvNOK_only(sv);
7426 SvNV_set(sv, SvNVX(sv) + 1.0);
7429 /* I don't think we can get here. Maybe I should assert this
7430 And if we do get here I suspect that sv_setnv will croak. NWC
7432 #if defined(USE_LONG_DOUBLE)
7433 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",
7434 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7436 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7437 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7440 #endif /* PERL_PRESERVE_IVUV */
7441 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7445 while (d >= SvPVX_const(sv)) {
7453 /* MKS: The original code here died if letters weren't consecutive.
7454 * at least it didn't have to worry about non-C locales. The
7455 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7456 * arranged in order (although not consecutively) and that only
7457 * [A-Za-z] are accepted by isALPHA in the C locale.
7459 if (*d != 'z' && *d != 'Z') {
7460 do { ++*d; } while (!isALPHA(*d));
7463 *(d--) -= 'z' - 'a';
7468 *(d--) -= 'z' - 'a' + 1;
7472 /* oh,oh, the number grew */
7473 SvGROW(sv, SvCUR(sv) + 2);
7474 SvCUR_set(sv, SvCUR(sv) + 1);
7475 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7486 Auto-decrement of the value in the SV, doing string to numeric conversion
7487 if necessary. Handles 'get' magic.
7493 Perl_sv_dec(pTHX_ register SV *const sv)
7501 if (SvTHINKFIRST(sv)) {
7503 sv_force_normal_flags(sv, 0);
7504 if (SvREADONLY(sv)) {
7505 if (IN_PERL_RUNTIME)
7506 Perl_croak(aTHX_ "%s", PL_no_modify);
7510 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7512 i = PTR2IV(SvRV(sv));
7517 /* Unlike sv_inc we don't have to worry about string-never-numbers
7518 and keeping them magic. But we mustn't warn on punting */
7519 flags = SvFLAGS(sv);
7520 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7521 /* It's publicly an integer, or privately an integer-not-float */
7522 #ifdef PERL_PRESERVE_IVUV
7526 if (SvUVX(sv) == 0) {
7527 (void)SvIOK_only(sv);
7531 (void)SvIOK_only_UV(sv);
7532 SvUV_set(sv, SvUVX(sv) - 1);
7535 if (SvIVX(sv) == IV_MIN) {
7536 sv_setnv(sv, (NV)IV_MIN);
7540 (void)SvIOK_only(sv);
7541 SvIV_set(sv, SvIVX(sv) - 1);
7546 if (flags & SVp_NOK) {
7549 const NV was = SvNVX(sv);
7550 if (NV_OVERFLOWS_INTEGERS_AT &&
7551 was <= -NV_OVERFLOWS_INTEGERS_AT) {
7552 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7553 "Lost precision when decrementing %" NVff " by 1",
7556 (void)SvNOK_only(sv);
7557 SvNV_set(sv, was - 1.0);
7561 if (!(flags & SVp_POK)) {
7562 if ((flags & SVTYPEMASK) < SVt_PVIV)
7563 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
7565 (void)SvIOK_only(sv);
7568 #ifdef PERL_PRESERVE_IVUV
7570 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7571 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7572 /* Need to try really hard to see if it's an integer.
7573 9.22337203685478e+18 is an integer.
7574 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7575 so $a="9.22337203685478e+18"; $a+0; $a--
7576 needs to be the same as $a="9.22337203685478e+18"; $a--
7583 /* sv_2iv *should* have made this an NV */
7584 if (flags & SVp_NOK) {
7585 (void)SvNOK_only(sv);
7586 SvNV_set(sv, SvNVX(sv) - 1.0);
7589 /* I don't think we can get here. Maybe I should assert this
7590 And if we do get here I suspect that sv_setnv will croak. NWC
7592 #if defined(USE_LONG_DOUBLE)
7593 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",
7594 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7596 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7597 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7601 #endif /* PERL_PRESERVE_IVUV */
7602 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
7605 /* this define is used to eliminate a chunk of duplicated but shared logic
7606 * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
7607 * used anywhere but here - yves
7609 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
7612 PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
7616 =for apidoc sv_mortalcopy
7618 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7619 The new SV is marked as mortal. It will be destroyed "soon", either by an
7620 explicit call to FREETMPS, or by an implicit call at places such as
7621 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7626 /* Make a string that will exist for the duration of the expression
7627 * evaluation. Actually, it may have to last longer than that, but
7628 * hopefully we won't free it until it has been assigned to a
7629 * permanent location. */
7632 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
7638 sv_setsv(sv,oldstr);
7639 PUSH_EXTEND_MORTAL__SV_C(sv);
7645 =for apidoc sv_newmortal
7647 Creates a new null SV which is mortal. The reference count of the SV is
7648 set to 1. It will be destroyed "soon", either by an explicit call to
7649 FREETMPS, or by an implicit call at places such as statement boundaries.
7650 See also C<sv_mortalcopy> and C<sv_2mortal>.
7656 Perl_sv_newmortal(pTHX)
7662 SvFLAGS(sv) = SVs_TEMP;
7663 PUSH_EXTEND_MORTAL__SV_C(sv);
7669 =for apidoc newSVpvn_flags
7671 Creates a new SV and copies a string into it. The reference count for the
7672 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7673 string. You are responsible for ensuring that the source string is at least
7674 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7675 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
7676 If C<SVs_TEMP> is set, then C<sv2mortal()> is called on the result before
7677 returning. If C<SVf_UTF8> is set, then it will be set on the new SV.
7678 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
7680 #define newSVpvn_utf8(s, len, u) \
7681 newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
7687 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
7692 /* All the flags we don't support must be zero.
7693 And we're new code so I'm going to assert this from the start. */
7694 assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
7696 sv_setpvn(sv,s,len);
7698 /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal()
7699 * and do what it does outselves here.
7700 * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags
7701 * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which
7702 * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we
7703 * eleminate quite a few steps than it looks - Yves (explaining patch by gfx)
7706 SvFLAGS(sv) |= flags;
7708 if(flags & SVs_TEMP){
7709 PUSH_EXTEND_MORTAL__SV_C(sv);
7716 =for apidoc sv_2mortal
7718 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7719 by an explicit call to FREETMPS, or by an implicit call at places such as
7720 statement boundaries. SvTEMP() is turned on which means that the SV's
7721 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7722 and C<sv_mortalcopy>.
7728 Perl_sv_2mortal(pTHX_ register SV *const sv)
7733 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7735 PUSH_EXTEND_MORTAL__SV_C(sv);
7743 Creates a new SV and copies a string into it. The reference count for the
7744 SV is set to 1. If C<len> is zero, Perl will compute the length using
7745 strlen(). For efficiency, consider using C<newSVpvn> instead.
7751 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
7757 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
7762 =for apidoc newSVpvn
7764 Creates a new SV and copies a string into it. The reference count for the
7765 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7766 string. You are responsible for ensuring that the source string is at least
7767 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7773 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
7779 sv_setpvn(sv,s,len);
7784 =for apidoc newSVhek
7786 Creates a new SV from the hash key structure. It will generate scalars that
7787 point to the shared string table where possible. Returns a new (undefined)
7788 SV if the hek is NULL.
7794 Perl_newSVhek(pTHX_ const HEK *const hek)
7804 if (HEK_LEN(hek) == HEf_SVKEY) {
7805 return newSVsv(*(SV**)HEK_KEY(hek));
7807 const int flags = HEK_FLAGS(hek);
7808 if (flags & HVhek_WASUTF8) {
7810 Andreas would like keys he put in as utf8 to come back as utf8
7812 STRLEN utf8_len = HEK_LEN(hek);
7813 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7814 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7817 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7819 } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
7820 /* We don't have a pointer to the hv, so we have to replicate the
7821 flag into every HEK. This hv is using custom a hasing
7822 algorithm. Hence we can't return a shared string scalar, as
7823 that would contain the (wrong) hash value, and might get passed
7824 into an hv routine with a regular hash.
7825 Similarly, a hash that isn't using shared hash keys has to have
7826 the flag in every key so that we know not to try to call
7827 share_hek_kek on it. */
7829 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7834 /* This will be overwhelminly the most common case. */
7836 /* Inline most of newSVpvn_share(), because share_hek_hek() is far
7837 more efficient than sharepvn(). */
7841 sv_upgrade(sv, SVt_PV);
7842 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
7843 SvCUR_set(sv, HEK_LEN(hek));
7856 =for apidoc newSVpvn_share
7858 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7859 table. If the string does not already exist in the table, it is created
7860 first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
7861 value is used; otherwise the hash is computed. The string's hash can be later
7862 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
7863 that as the string table is used for shared hash keys these strings will have
7864 SvPVX_const == HeKEY and hash lookup will avoid string compare.
7870 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7874 bool is_utf8 = FALSE;
7875 const char *const orig_src = src;
7878 STRLEN tmplen = -len;
7880 /* See the note in hv.c:hv_fetch() --jhi */
7881 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7885 PERL_HASH(hash, src, len);
7887 /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
7888 changes here, update it there too. */
7889 sv_upgrade(sv, SVt_PV);
7890 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7898 if (src != orig_src)
7904 #if defined(PERL_IMPLICIT_CONTEXT)
7906 /* pTHX_ magic can't cope with varargs, so this is a no-context
7907 * version of the main function, (which may itself be aliased to us).
7908 * Don't access this version directly.
7912 Perl_newSVpvf_nocontext(const char *const pat, ...)
7918 PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
7920 va_start(args, pat);
7921 sv = vnewSVpvf(pat, &args);
7928 =for apidoc newSVpvf
7930 Creates a new SV and initializes it with the string formatted like
7937 Perl_newSVpvf(pTHX_ const char *const pat, ...)
7942 PERL_ARGS_ASSERT_NEWSVPVF;
7944 va_start(args, pat);
7945 sv = vnewSVpvf(pat, &args);
7950 /* backend for newSVpvf() and newSVpvf_nocontext() */
7953 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
7958 PERL_ARGS_ASSERT_VNEWSVPVF;
7961 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7968 Creates a new SV and copies a floating point value into it.
7969 The reference count for the SV is set to 1.
7975 Perl_newSVnv(pTHX_ const NV n)
7988 Creates a new SV and copies an integer into it. The reference count for the
7995 Perl_newSViv(pTHX_ const IV i)
8008 Creates a new SV and copies an unsigned integer into it.
8009 The reference count for the SV is set to 1.
8015 Perl_newSVuv(pTHX_ const UV u)
8026 =for apidoc newSV_type
8028 Creates a new SV, of the type specified. The reference count for the new SV
8035 Perl_newSV_type(pTHX_ const svtype type)
8040 sv_upgrade(sv, type);
8045 =for apidoc newRV_noinc
8047 Creates an RV wrapper for an SV. The reference count for the original
8048 SV is B<not> incremented.
8054 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
8057 register SV *sv = newSV_type(SVt_IV);
8059 PERL_ARGS_ASSERT_NEWRV_NOINC;
8062 SvRV_set(sv, tmpRef);
8067 /* newRV_inc is the official function name to use now.
8068 * newRV_inc is in fact #defined to newRV in sv.h
8072 Perl_newRV(pTHX_ SV *const sv)
8076 PERL_ARGS_ASSERT_NEWRV;
8078 return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
8084 Creates a new SV which is an exact duplicate of the original SV.
8091 Perl_newSVsv(pTHX_ register SV *const old)
8098 if (SvTYPE(old) == SVTYPEMASK) {
8099 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
8103 /* SV_GMAGIC is the default for sv_setv()
8104 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
8105 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
8106 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
8111 =for apidoc sv_reset
8113 Underlying implementation for the C<reset> Perl function.
8114 Note that the perl-level function is vaguely deprecated.
8120 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
8123 char todo[PERL_UCHAR_MAX+1];
8125 PERL_ARGS_ASSERT_SV_RESET;
8130 if (!*s) { /* reset ?? searches */
8131 MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
8133 const U32 count = mg->mg_len / sizeof(PMOP**);
8134 PMOP **pmp = (PMOP**) mg->mg_ptr;
8135 PMOP *const *const end = pmp + count;
8139 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
8141 (*pmp)->op_pmflags &= ~PMf_USED;
8149 /* reset variables */
8151 if (!HvARRAY(stash))
8154 Zero(todo, 256, char);
8157 I32 i = (unsigned char)*s;
8161 max = (unsigned char)*s++;
8162 for ( ; i <= max; i++) {
8165 for (i = 0; i <= (I32) HvMAX(stash); i++) {
8167 for (entry = HvARRAY(stash)[i];
8169 entry = HeNEXT(entry))
8174 if (!todo[(U8)*HeKEY(entry)])
8176 gv = MUTABLE_GV(HeVAL(entry));
8179 if (SvTHINKFIRST(sv)) {
8180 if (!SvREADONLY(sv) && SvROK(sv))
8182 /* XXX Is this continue a bug? Why should THINKFIRST
8183 exempt us from resetting arrays and hashes? */
8187 if (SvTYPE(sv) >= SVt_PV) {
8189 if (SvPVX_const(sv) != NULL)
8197 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8199 Perl_die(aTHX_ "Can't reset %%ENV on this system");
8202 # if defined(USE_ENVIRON_ARRAY)
8205 # endif /* USE_ENVIRON_ARRAY */
8216 Using various gambits, try to get an IO from an SV: the IO slot if its a
8217 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8218 named after the PV if we're a string.
8224 Perl_sv_2io(pTHX_ SV *const sv)
8229 PERL_ARGS_ASSERT_SV_2IO;
8231 switch (SvTYPE(sv)) {
8233 io = MUTABLE_IO(sv);
8236 if (isGV_with_GP(sv)) {
8237 gv = MUTABLE_GV(sv);
8240 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8246 Perl_croak(aTHX_ PL_no_usym, "filehandle");
8248 return sv_2io(SvRV(sv));
8249 gv = gv_fetchsv(sv, 0, SVt_PVIO);
8255 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
8264 Using various gambits, try to get a CV from an SV; in addition, try if
8265 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8266 The flags in C<lref> are passed to gv_fetchsv.
8272 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8278 PERL_ARGS_ASSERT_SV_2CV;
8285 switch (SvTYPE(sv)) {
8289 return MUTABLE_CV(sv);
8296 if (isGV_with_GP(sv)) {
8297 gv = MUTABLE_GV(sv);
8306 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
8308 tryAMAGICunDEREF(to_cv);
8311 if (SvTYPE(sv) == SVt_PVCV) {
8312 cv = MUTABLE_CV(sv);
8317 else if(isGV_with_GP(sv))
8318 gv = MUTABLE_GV(sv);
8320 Perl_croak(aTHX_ "Not a subroutine reference");
8322 else if (isGV_with_GP(sv)) {
8324 gv = MUTABLE_GV(sv);
8327 gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
8333 /* Some flags to gv_fetchsv mean don't really create the GV */
8334 if (!isGV_with_GP(gv)) {
8340 if (lref && !GvCVu(gv)) {
8344 gv_efullname3(tmpsv, gv, NULL);
8345 /* XXX this is probably not what they think they're getting.
8346 * It has the same effect as "sub name;", i.e. just a forward
8348 newSUB(start_subparse(FALSE, 0),
8349 newSVOP(OP_CONST, 0, tmpsv),
8353 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8354 SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8363 Returns true if the SV has a true value by Perl's rules.
8364 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8365 instead use an in-line version.
8371 Perl_sv_true(pTHX_ register SV *const sv)
8376 register const XPV* const tXpv = (XPV*)SvANY(sv);
8378 (tXpv->xpv_cur > 1 ||
8379 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
8386 return SvIVX(sv) != 0;
8389 return SvNVX(sv) != 0.0;
8391 return sv_2bool(sv);
8397 =for apidoc sv_pvn_force
8399 Get a sensible string out of the SV somehow.
8400 A private implementation of the C<SvPV_force> macro for compilers which
8401 can't cope with complex macro expressions. Always use the macro instead.
8403 =for apidoc sv_pvn_force_flags
8405 Get a sensible string out of the SV somehow.
8406 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8407 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8408 implemented in terms of this function.
8409 You normally want to use the various wrapper macros instead: see
8410 C<SvPV_force> and C<SvPV_force_nomg>
8416 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
8420 PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
8422 if (SvTHINKFIRST(sv) && !SvROK(sv))
8423 sv_force_normal_flags(sv, 0);
8433 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8434 const char * const ref = sv_reftype(sv,0);
8436 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8437 ref, OP_NAME(PL_op));
8439 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
8441 if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
8442 || isGV_with_GP(sv))
8443 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8445 s = sv_2pv_flags(sv, &len, flags);
8449 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
8452 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8453 SvGROW(sv, len + 1);
8454 Move(s,SvPVX(sv),len,char);
8456 SvPVX(sv)[len] = '\0';
8459 SvPOK_on(sv); /* validate pointer */
8461 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8462 PTR2UV(sv),SvPVX_const(sv)));
8465 return SvPVX_mutable(sv);
8469 =for apidoc sv_pvbyten_force
8471 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
8477 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
8479 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
8481 sv_pvn_force(sv,lp);
8482 sv_utf8_downgrade(sv,0);
8488 =for apidoc sv_pvutf8n_force
8490 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
8496 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
8498 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
8500 sv_pvn_force(sv,lp);
8501 sv_utf8_upgrade(sv);
8507 =for apidoc sv_reftype
8509 Returns a string describing what the SV is a reference to.
8515 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
8517 PERL_ARGS_ASSERT_SV_REFTYPE;
8519 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8520 inside return suggests a const propagation bug in g++. */
8521 if (ob && SvOBJECT(sv)) {
8522 char * const name = HvNAME_get(SvSTASH(sv));
8523 return name ? name : (char *) "__ANON__";
8526 switch (SvTYPE(sv)) {
8541 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
8542 /* tied lvalues should appear to be
8543 * scalars for backwards compatitbility */
8544 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8545 ? "SCALAR" : "LVALUE");
8546 case SVt_PVAV: return "ARRAY";
8547 case SVt_PVHV: return "HASH";
8548 case SVt_PVCV: return "CODE";
8549 case SVt_PVGV: return (char *) (isGV_with_GP(sv)
8550 ? "GLOB" : "SCALAR");
8551 case SVt_PVFM: return "FORMAT";
8552 case SVt_PVIO: return "IO";
8553 case SVt_BIND: return "BIND";
8554 case SVt_REGEXP: return "REGEXP";
8555 default: return "UNKNOWN";
8561 =for apidoc sv_isobject
8563 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8564 object. If the SV is not an RV, or if the object is not blessed, then this
8571 Perl_sv_isobject(pTHX_ SV *sv)
8587 Returns a boolean indicating whether the SV is blessed into the specified
8588 class. This does not check for subtypes; use C<sv_derived_from> to verify
8589 an inheritance relationship.
8595 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
8599 PERL_ARGS_ASSERT_SV_ISA;
8609 hvname = HvNAME_get(SvSTASH(sv));
8613 return strEQ(hvname, name);
8619 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8620 it will be upgraded to one. If C<classname> is non-null then the new SV will
8621 be blessed in the specified package. The new SV is returned and its
8622 reference count is 1.
8628 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
8633 PERL_ARGS_ASSERT_NEWSVRV;
8637 SV_CHECK_THINKFIRST_COW_DROP(rv);
8638 (void)SvAMAGIC_off(rv);
8640 if (SvTYPE(rv) >= SVt_PVMG) {
8641 const U32 refcnt = SvREFCNT(rv);
8645 SvREFCNT(rv) = refcnt;
8647 sv_upgrade(rv, SVt_IV);
8648 } else if (SvROK(rv)) {
8649 SvREFCNT_dec(SvRV(rv));
8651 prepare_SV_for_RV(rv);
8659 HV* const stash = gv_stashpv(classname, GV_ADD);
8660 (void)sv_bless(rv, stash);
8666 =for apidoc sv_setref_pv
8668 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8669 argument will be upgraded to an RV. That RV will be modified to point to
8670 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8671 into the SV. The C<classname> argument indicates the package for the
8672 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8673 will have a reference count of 1, and the RV will be returned.
8675 Do not use with other Perl types such as HV, AV, SV, CV, because those
8676 objects will become corrupted by the pointer copy process.
8678 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8684 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
8688 PERL_ARGS_ASSERT_SV_SETREF_PV;
8691 sv_setsv(rv, &PL_sv_undef);
8695 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8700 =for apidoc sv_setref_iv
8702 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8703 argument will be upgraded to an RV. That RV will be modified to point to
8704 the new SV. The C<classname> argument indicates the package for the
8705 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8706 will have a reference count of 1, and the RV will be returned.
8712 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
8714 PERL_ARGS_ASSERT_SV_SETREF_IV;
8716 sv_setiv(newSVrv(rv,classname), iv);
8721 =for apidoc sv_setref_uv
8723 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8724 argument will be upgraded to an RV. That RV will be modified to point to
8725 the new SV. The C<classname> argument indicates the package for the
8726 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8727 will have a reference count of 1, and the RV will be returned.
8733 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
8735 PERL_ARGS_ASSERT_SV_SETREF_UV;
8737 sv_setuv(newSVrv(rv,classname), uv);
8742 =for apidoc sv_setref_nv
8744 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8745 argument will be upgraded to an RV. That RV will be modified to point to
8746 the new SV. The C<classname> argument indicates the package for the
8747 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8748 will have a reference count of 1, and the RV will be returned.
8754 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
8756 PERL_ARGS_ASSERT_SV_SETREF_NV;
8758 sv_setnv(newSVrv(rv,classname), nv);
8763 =for apidoc sv_setref_pvn
8765 Copies a string into a new SV, optionally blessing the SV. The length of the
8766 string must be specified with C<n>. The C<rv> argument will be upgraded to
8767 an RV. That RV will be modified to point to the new SV. The C<classname>
8768 argument indicates the package for the blessing. Set C<classname> to
8769 C<NULL> to avoid the blessing. The new SV will have a reference count
8770 of 1, and the RV will be returned.
8772 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8778 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
8779 const char *const pv, const STRLEN n)
8781 PERL_ARGS_ASSERT_SV_SETREF_PVN;
8783 sv_setpvn(newSVrv(rv,classname), pv, n);
8788 =for apidoc sv_bless
8790 Blesses an SV into a specified package. The SV must be an RV. The package
8791 must be designated by its stash (see C<gv_stashpv()>). The reference count
8792 of the SV is unaffected.
8798 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
8803 PERL_ARGS_ASSERT_SV_BLESS;
8806 Perl_croak(aTHX_ "Can't bless non-reference value");
8808 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8809 if (SvIsCOW(tmpRef))
8810 sv_force_normal_flags(tmpRef, 0);
8811 if (SvREADONLY(tmpRef))
8812 Perl_croak(aTHX_ "%s", PL_no_modify);
8813 if (SvOBJECT(tmpRef)) {
8814 if (SvTYPE(tmpRef) != SVt_PVIO)
8816 SvREFCNT_dec(SvSTASH(tmpRef));
8819 SvOBJECT_on(tmpRef);
8820 if (SvTYPE(tmpRef) != SVt_PVIO)
8822 SvUPGRADE(tmpRef, SVt_PVMG);
8823 SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
8828 (void)SvAMAGIC_off(sv);
8830 if(SvSMAGICAL(tmpRef))
8831 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8839 /* Downgrades a PVGV to a PVMG.
8843 S_sv_unglob(pTHX_ SV *const sv)
8848 SV * const temp = sv_newmortal();
8850 PERL_ARGS_ASSERT_SV_UNGLOB;
8852 assert(SvTYPE(sv) == SVt_PVGV);
8854 gv_efullname3(temp, MUTABLE_GV(sv), "*");
8857 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
8858 && HvNAME_get(stash))
8859 mro_method_changed_in(stash);
8860 gp_free(MUTABLE_GV(sv));
8863 sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
8867 if (GvNAME_HEK(sv)) {
8868 unshare_hek(GvNAME_HEK(sv));
8870 isGV_with_GP_off(sv);
8872 /* need to keep SvANY(sv) in the right arena */
8873 xpvmg = new_XPVMG();
8874 StructCopy(SvANY(sv), xpvmg, XPVMG);
8875 del_XPVGV(SvANY(sv));
8878 SvFLAGS(sv) &= ~SVTYPEMASK;
8879 SvFLAGS(sv) |= SVt_PVMG;
8881 /* Intentionally not calling any local SET magic, as this isn't so much a
8882 set operation as merely an internal storage change. */
8883 sv_setsv_flags(sv, temp, 0);
8887 =for apidoc sv_unref_flags
8889 Unsets the RV status of the SV, and decrements the reference count of
8890 whatever was being referenced by the RV. This can almost be thought of
8891 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8892 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8893 (otherwise the decrementing is conditional on the reference count being
8894 different from one or the reference being a readonly SV).
8901 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
8903 SV* const target = SvRV(ref);
8905 PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
8907 if (SvWEAKREF(ref)) {
8908 sv_del_backref(target, ref);
8910 SvRV_set(ref, NULL);
8913 SvRV_set(ref, NULL);
8915 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8916 assigned to as BEGIN {$a = \"Foo"} will fail. */
8917 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8918 SvREFCNT_dec(target);
8919 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8920 sv_2mortal(target); /* Schedule for freeing later */
8924 =for apidoc sv_untaint
8926 Untaint an SV. Use C<SvTAINTED_off> instead.
8931 Perl_sv_untaint(pTHX_ SV *const sv)
8933 PERL_ARGS_ASSERT_SV_UNTAINT;
8935 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8936 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8943 =for apidoc sv_tainted
8945 Test an SV for taintedness. Use C<SvTAINTED> instead.
8950 Perl_sv_tainted(pTHX_ SV *const sv)
8952 PERL_ARGS_ASSERT_SV_TAINTED;
8954 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8955 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8956 if (mg && (mg->mg_len & 1) )
8963 =for apidoc sv_setpviv
8965 Copies an integer into the given SV, also updating its string value.
8966 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8972 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
8974 char buf[TYPE_CHARS(UV)];
8976 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8978 PERL_ARGS_ASSERT_SV_SETPVIV;
8980 sv_setpvn(sv, ptr, ebuf - ptr);
8984 =for apidoc sv_setpviv_mg
8986 Like C<sv_setpviv>, but also handles 'set' magic.
8992 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
8994 PERL_ARGS_ASSERT_SV_SETPVIV_MG;
9000 #if defined(PERL_IMPLICIT_CONTEXT)
9002 /* pTHX_ magic can't cope with varargs, so this is a no-context
9003 * version of the main function, (which may itself be aliased to us).
9004 * Don't access this version directly.
9008 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
9013 PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
9015 va_start(args, pat);
9016 sv_vsetpvf(sv, pat, &args);
9020 /* pTHX_ magic can't cope with varargs, so this is a no-context
9021 * version of the main function, (which may itself be aliased to us).
9022 * Don't access this version directly.
9026 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9031 PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
9033 va_start(args, pat);
9034 sv_vsetpvf_mg(sv, pat, &args);
9040 =for apidoc sv_setpvf
9042 Works like C<sv_catpvf> but copies the text into the SV instead of
9043 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
9049 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
9053 PERL_ARGS_ASSERT_SV_SETPVF;
9055 va_start(args, pat);
9056 sv_vsetpvf(sv, pat, &args);
9061 =for apidoc sv_vsetpvf
9063 Works like C<sv_vcatpvf> but copies the text into the SV instead of
9064 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
9066 Usually used via its frontend C<sv_setpvf>.
9072 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9074 PERL_ARGS_ASSERT_SV_VSETPVF;
9076 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9080 =for apidoc sv_setpvf_mg
9082 Like C<sv_setpvf>, but also handles 'set' magic.
9088 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9092 PERL_ARGS_ASSERT_SV_SETPVF_MG;
9094 va_start(args, pat);
9095 sv_vsetpvf_mg(sv, pat, &args);
9100 =for apidoc sv_vsetpvf_mg
9102 Like C<sv_vsetpvf>, but also handles 'set' magic.
9104 Usually used via its frontend C<sv_setpvf_mg>.
9110 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9112 PERL_ARGS_ASSERT_SV_VSETPVF_MG;
9114 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9118 #if defined(PERL_IMPLICIT_CONTEXT)
9120 /* pTHX_ magic can't cope with varargs, so this is a no-context
9121 * version of the main function, (which may itself be aliased to us).
9122 * Don't access this version directly.
9126 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
9131 PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
9133 va_start(args, pat);
9134 sv_vcatpvf(sv, pat, &args);
9138 /* pTHX_ magic can't cope with varargs, so this is a no-context
9139 * version of the main function, (which may itself be aliased to us).
9140 * Don't access this version directly.
9144 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9149 PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9151 va_start(args, pat);
9152 sv_vcatpvf_mg(sv, pat, &args);
9158 =for apidoc sv_catpvf
9160 Processes its arguments like C<sprintf> and appends the formatted
9161 output to an SV. If the appended data contains "wide" characters
9162 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9163 and characters >255 formatted with %c), the original SV might get
9164 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
9165 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9166 valid UTF-8; if the original SV was bytes, the pattern should be too.
9171 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9175 PERL_ARGS_ASSERT_SV_CATPVF;
9177 va_start(args, pat);
9178 sv_vcatpvf(sv, pat, &args);
9183 =for apidoc sv_vcatpvf
9185 Processes its arguments like C<vsprintf> and appends the formatted output
9186 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
9188 Usually used via its frontend C<sv_catpvf>.
9194 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9196 PERL_ARGS_ASSERT_SV_VCATPVF;
9198 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9202 =for apidoc sv_catpvf_mg
9204 Like C<sv_catpvf>, but also handles 'set' magic.
9210 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9214 PERL_ARGS_ASSERT_SV_CATPVF_MG;
9216 va_start(args, pat);
9217 sv_vcatpvf_mg(sv, pat, &args);
9222 =for apidoc sv_vcatpvf_mg
9224 Like C<sv_vcatpvf>, but also handles 'set' magic.
9226 Usually used via its frontend C<sv_catpvf_mg>.
9232 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9234 PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9236 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9241 =for apidoc sv_vsetpvfn
9243 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9246 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9252 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9253 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9255 PERL_ARGS_ASSERT_SV_VSETPVFN;
9258 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9263 * Warn of missing argument to sprintf, and then return a defined value
9264 * to avoid inappropriate "use of uninit" warnings [perl #71000].
9266 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
9268 S_vcatpvfn_missing_argument(pTHX) {
9269 if (ckWARN(WARN_MISSING)) {
9270 Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
9271 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
9278 S_expect_number(pTHX_ char **const pattern)
9283 PERL_ARGS_ASSERT_EXPECT_NUMBER;
9285 switch (**pattern) {
9286 case '1': case '2': case '3':
9287 case '4': case '5': case '6':
9288 case '7': case '8': case '9':
9289 var = *(*pattern)++ - '0';
9290 while (isDIGIT(**pattern)) {
9291 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
9293 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn"));
9301 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
9303 const int neg = nv < 0;
9306 PERL_ARGS_ASSERT_F0CONVERT;
9314 if (uv & 1 && uv == nv)
9315 uv--; /* Round to even */
9317 const unsigned dig = uv % 10;
9330 =for apidoc sv_vcatpvfn
9332 Processes its arguments like C<vsprintf> and appends the formatted output
9333 to an SV. Uses an array of SVs if the C style variable argument list is
9334 missing (NULL). When running with taint checks enabled, indicates via
9335 C<maybe_tainted> if results are untrustworthy (often due to the use of
9338 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9344 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
9345 vecstr = (U8*)SvPV_const(vecsv,veclen);\
9346 vec_utf8 = DO_UTF8(vecsv);
9348 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9351 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9352 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9360 static const char nullstr[] = "(null)";
9362 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
9363 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9365 /* Times 4: a decimal digit takes more than 3 binary digits.
9366 * NV_DIG: mantissa takes than many decimal digits.
9367 * Plus 32: Playing safe. */
9368 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9369 /* large enough for "%#.#f" --chip */
9370 /* what about long double NVs? --jhi */
9372 PERL_ARGS_ASSERT_SV_VCATPVFN;
9373 PERL_UNUSED_ARG(maybe_tainted);
9375 /* no matter what, this is a string now */
9376 (void)SvPV_force(sv, origlen);
9378 /* special-case "", "%s", and "%-p" (SVf - see below) */
9381 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9383 const char * const s = va_arg(*args, char*);
9384 sv_catpv(sv, s ? s : nullstr);
9386 else if (svix < svmax) {
9387 sv_catsv(sv, *svargs);
9391 if (args && patlen == 3 && pat[0] == '%' &&
9392 pat[1] == '-' && pat[2] == 'p') {
9393 argsv = MUTABLE_SV(va_arg(*args, void*));
9394 sv_catsv(sv, argsv);
9398 #ifndef USE_LONG_DOUBLE
9399 /* special-case "%.<number>[gf]" */
9400 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9401 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9402 unsigned digits = 0;
9406 while (*pp >= '0' && *pp <= '9')
9407 digits = 10 * digits + (*pp++ - '0');
9408 if (pp - pat == (int)patlen - 1) {
9416 /* Add check for digits != 0 because it seems that some
9417 gconverts are buggy in this case, and we don't yet have
9418 a Configure test for this. */
9419 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9420 /* 0, point, slack */
9421 Gconvert(nv, (int)digits, 0, ebuf);
9423 if (*ebuf) /* May return an empty string for digits==0 */
9426 } else if (!digits) {
9429 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9430 sv_catpvn(sv, p, l);
9436 #endif /* !USE_LONG_DOUBLE */
9438 if (!args && svix < svmax && DO_UTF8(*svargs))
9441 patend = (char*)pat + patlen;
9442 for (p = (char*)pat; p < patend; p = q) {
9445 bool vectorize = FALSE;
9446 bool vectorarg = FALSE;
9447 bool vec_utf8 = FALSE;
9453 bool has_precis = FALSE;
9455 const I32 osvix = svix;
9456 bool is_utf8 = FALSE; /* is this item utf8? */
9457 #ifdef HAS_LDBL_SPRINTF_BUG
9458 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9459 with sfio - Allen <allens@cpan.org> */
9460 bool fix_ldbl_sprintf_bug = FALSE;
9464 U8 utf8buf[UTF8_MAXBYTES+1];
9465 STRLEN esignlen = 0;
9467 const char *eptr = NULL;
9468 const char *fmtstart;
9471 const U8 *vecstr = NULL;
9478 /* we need a long double target in case HAS_LONG_DOUBLE but
9481 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9489 const char *dotstr = ".";
9490 STRLEN dotstrlen = 1;
9491 I32 efix = 0; /* explicit format parameter index */
9492 I32 ewix = 0; /* explicit width index */
9493 I32 epix = 0; /* explicit precision index */
9494 I32 evix = 0; /* explicit vector index */
9495 bool asterisk = FALSE;
9497 /* echo everything up to the next format specification */
9498 for (q = p; q < patend && *q != '%'; ++q) ;
9500 if (has_utf8 && !pat_utf8)
9501 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9503 sv_catpvn(sv, p, q - p);
9512 We allow format specification elements in this order:
9513 \d+\$ explicit format parameter index
9515 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9516 0 flag (as above): repeated to allow "v02"
9517 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9518 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9520 [%bcdefginopsuxDFOUX] format (mandatory)
9525 As of perl5.9.3, printf format checking is on by default.
9526 Internally, perl uses %p formats to provide an escape to
9527 some extended formatting. This block deals with those
9528 extensions: if it does not match, (char*)q is reset and
9529 the normal format processing code is used.
9531 Currently defined extensions are:
9532 %p include pointer address (standard)
9533 %-p (SVf) include an SV (previously %_)
9534 %-<num>p include an SV with precision <num>
9535 %<num>p reserved for future extensions
9537 Robin Barker 2005-07-14
9539 %1p (VDf) removed. RMB 2007-10-19
9546 n = expect_number(&q);
9553 argsv = MUTABLE_SV(va_arg(*args, void*));
9554 eptr = SvPV_const(argsv, elen);
9560 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
9561 "internal %%<num>p might conflict with future printf extensions");
9567 if ( (width = expect_number(&q)) ) {
9582 if (plus == '+' && *q == ' ') /* '+' over ' ' */
9611 if ( (ewix = expect_number(&q)) )
9620 if ((vectorarg = asterisk)) {
9633 width = expect_number(&q);
9639 vecsv = va_arg(*args, SV*);
9641 vecsv = (evix > 0 && evix <= svmax)
9642 ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
9644 vecsv = svix < svmax
9645 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
9647 dotstr = SvPV_const(vecsv, dotstrlen);
9648 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
9649 bad with tied or overloaded values that return UTF8. */
9652 else if (has_utf8) {
9653 vecsv = sv_mortalcopy(vecsv);
9654 sv_utf8_upgrade(vecsv);
9655 dotstr = SvPV_const(vecsv, dotstrlen);
9662 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
9663 vecsv = svargs[efix ? efix-1 : svix++];
9664 vecstr = (U8*)SvPV_const(vecsv,veclen);
9665 vec_utf8 = DO_UTF8(vecsv);
9667 /* if this is a version object, we need to convert
9668 * back into v-string notation and then let the
9669 * vectorize happen normally
9671 if (sv_derived_from(vecsv, "version")) {
9672 char *version = savesvpv(vecsv);
9673 if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
9674 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9675 "vector argument not supported with alpha versions");
9678 vecsv = sv_newmortal();
9679 scan_vstring(version, version + veclen, vecsv);
9680 vecstr = (U8*)SvPV_const(vecsv, veclen);
9681 vec_utf8 = DO_UTF8(vecsv);
9693 i = va_arg(*args, int);
9695 i = (ewix ? ewix <= svmax : svix < svmax) ?
9696 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9698 width = (i < 0) ? -i : i;
9708 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
9710 /* XXX: todo, support specified precision parameter */
9714 i = va_arg(*args, int);
9716 i = (ewix ? ewix <= svmax : svix < svmax)
9717 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9719 has_precis = !(i < 0);
9724 precis = precis * 10 + (*q++ - '0');
9733 case 'I': /* Ix, I32x, and I64x */
9735 if (q[1] == '6' && q[2] == '4') {
9741 if (q[1] == '3' && q[2] == '2') {
9751 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9762 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9763 if (*(q + 1) == 'l') { /* lld, llf */
9789 if (!vectorize && !args) {
9791 const I32 i = efix-1;
9792 argsv = (i >= 0 && i < svmax)
9793 ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
9795 argsv = (svix >= 0 && svix < svmax)
9796 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
9807 uv = (args) ? va_arg(*args, int) : SvIV(argsv);
9809 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9811 eptr = (char*)utf8buf;
9812 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9826 eptr = va_arg(*args, char*);
9828 elen = strlen(eptr);
9830 eptr = (char *)nullstr;
9831 elen = sizeof nullstr - 1;
9835 eptr = SvPV_const(argsv, elen);
9836 if (DO_UTF8(argsv)) {
9837 STRLEN old_precis = precis;
9838 if (has_precis && precis < elen) {
9839 STRLEN ulen = sv_len_utf8(argsv);
9840 I32 p = precis > ulen ? ulen : precis;
9841 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9844 if (width) { /* fudge width (can't fudge elen) */
9845 if (has_precis && precis < elen)
9846 width += precis - old_precis;
9848 width += elen - sv_len_utf8(argsv);
9855 if (has_precis && precis < elen)
9862 if (alt || vectorize)
9864 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9885 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9894 esignbuf[esignlen++] = plus;
9898 case 'h': iv = (short)va_arg(*args, int); break;
9899 case 'l': iv = va_arg(*args, long); break;
9900 case 'V': iv = va_arg(*args, IV); break;
9901 default: iv = va_arg(*args, int); break;
9904 iv = va_arg(*args, Quad_t); break;
9911 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
9913 case 'h': iv = (short)tiv; break;
9914 case 'l': iv = (long)tiv; break;
9916 default: iv = tiv; break;
9919 iv = (Quad_t)tiv; break;
9925 if ( !vectorize ) /* we already set uv above */
9930 esignbuf[esignlen++] = plus;
9934 esignbuf[esignlen++] = '-';
9978 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9989 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9990 case 'l': uv = va_arg(*args, unsigned long); break;
9991 case 'V': uv = va_arg(*args, UV); break;
9992 default: uv = va_arg(*args, unsigned); break;
9995 uv = va_arg(*args, Uquad_t); break;
10002 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
10004 case 'h': uv = (unsigned short)tuv; break;
10005 case 'l': uv = (unsigned long)tuv; break;
10007 default: uv = tuv; break;
10010 uv = (Uquad_t)tuv; break;
10019 char *ptr = ebuf + sizeof ebuf;
10020 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
10026 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
10030 } while (uv >>= 4);
10032 esignbuf[esignlen++] = '0';
10033 esignbuf[esignlen++] = c; /* 'x' or 'X' */
10039 *--ptr = '0' + dig;
10040 } while (uv >>= 3);
10041 if (alt && *ptr != '0')
10047 *--ptr = '0' + dig;
10048 } while (uv >>= 1);
10050 esignbuf[esignlen++] = '0';
10051 esignbuf[esignlen++] = c;
10054 default: /* it had better be ten or less */
10057 *--ptr = '0' + dig;
10058 } while (uv /= base);
10061 elen = (ebuf + sizeof ebuf) - ptr;
10065 zeros = precis - elen;
10066 else if (precis == 0 && elen == 1 && *eptr == '0'
10067 && !(base == 8 && alt)) /* "%#.0o" prints "0" */
10070 /* a precision nullifies the 0 flag. */
10077 /* FLOATING POINT */
10080 c = 'f'; /* maybe %F isn't supported here */
10082 case 'e': case 'E':
10084 case 'g': case 'G':
10088 /* This is evil, but floating point is even more evil */
10090 /* for SV-style calling, we can only get NV
10091 for C-style calling, we assume %f is double;
10092 for simplicity we allow any of %Lf, %llf, %qf for long double
10096 #if defined(USE_LONG_DOUBLE)
10100 /* [perl #20339] - we should accept and ignore %lf rather than die */
10104 #if defined(USE_LONG_DOUBLE)
10105 intsize = args ? 0 : 'q';
10109 #if defined(HAS_LONG_DOUBLE)
10118 /* now we need (long double) if intsize == 'q', else (double) */
10120 #if LONG_DOUBLESIZE > DOUBLESIZE
10122 va_arg(*args, long double) :
10123 va_arg(*args, double)
10125 va_arg(*args, double)
10130 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
10131 else. frexp() has some unspecified behaviour for those three */
10132 if (c != 'e' && c != 'E' && (nv * 0) == 0) {
10134 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
10135 will cast our (long double) to (double) */
10136 (void)Perl_frexp(nv, &i);
10137 if (i == PERL_INT_MIN)
10138 Perl_die(aTHX_ "panic: frexp");
10140 need = BIT_DIGITS(i);
10142 need += has_precis ? precis : 6; /* known default */
10147 #ifdef HAS_LDBL_SPRINTF_BUG
10148 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10149 with sfio - Allen <allens@cpan.org> */
10152 # define MY_DBL_MAX DBL_MAX
10153 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
10154 # if DOUBLESIZE >= 8
10155 # define MY_DBL_MAX 1.7976931348623157E+308L
10157 # define MY_DBL_MAX 3.40282347E+38L
10161 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10162 # define MY_DBL_MAX_BUG 1L
10164 # define MY_DBL_MAX_BUG MY_DBL_MAX
10168 # define MY_DBL_MIN DBL_MIN
10169 # else /* XXX guessing! -Allen */
10170 # if DOUBLESIZE >= 8
10171 # define MY_DBL_MIN 2.2250738585072014E-308L
10173 # define MY_DBL_MIN 1.17549435E-38L
10177 if ((intsize == 'q') && (c == 'f') &&
10178 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10179 (need < DBL_DIG)) {
10180 /* it's going to be short enough that
10181 * long double precision is not needed */
10183 if ((nv <= 0L) && (nv >= -0L))
10184 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10186 /* would use Perl_fp_class as a double-check but not
10187 * functional on IRIX - see perl.h comments */
10189 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10190 /* It's within the range that a double can represent */
10191 #if defined(DBL_MAX) && !defined(DBL_MIN)
10192 if ((nv >= ((long double)1/DBL_MAX)) ||
10193 (nv <= (-(long double)1/DBL_MAX)))
10195 fix_ldbl_sprintf_bug = TRUE;
10198 if (fix_ldbl_sprintf_bug == TRUE) {
10208 # undef MY_DBL_MAX_BUG
10211 #endif /* HAS_LDBL_SPRINTF_BUG */
10213 need += 20; /* fudge factor */
10214 if (PL_efloatsize < need) {
10215 Safefree(PL_efloatbuf);
10216 PL_efloatsize = need + 20; /* more fudge */
10217 Newx(PL_efloatbuf, PL_efloatsize, char);
10218 PL_efloatbuf[0] = '\0';
10221 if ( !(width || left || plus || alt) && fill != '0'
10222 && has_precis && intsize != 'q' ) { /* Shortcuts */
10223 /* See earlier comment about buggy Gconvert when digits,
10225 if ( c == 'g' && precis) {
10226 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10227 /* May return an empty string for digits==0 */
10228 if (*PL_efloatbuf) {
10229 elen = strlen(PL_efloatbuf);
10230 goto float_converted;
10232 } else if ( c == 'f' && !precis) {
10233 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10238 char *ptr = ebuf + sizeof ebuf;
10241 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10242 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10243 if (intsize == 'q') {
10244 /* Copy the one or more characters in a long double
10245 * format before the 'base' ([efgEFG]) character to
10246 * the format string. */
10247 static char const prifldbl[] = PERL_PRIfldbl;
10248 char const *p = prifldbl + sizeof(prifldbl) - 3;
10249 while (p >= prifldbl) { *--ptr = *p--; }
10254 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10259 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10271 /* No taint. Otherwise we are in the strange situation
10272 * where printf() taints but print($float) doesn't.
10274 #if defined(HAS_LONG_DOUBLE)
10275 elen = ((intsize == 'q')
10276 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
10277 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
10279 elen = my_sprintf(PL_efloatbuf, ptr, nv);
10283 eptr = PL_efloatbuf;
10291 i = SvCUR(sv) - origlen;
10294 case 'h': *(va_arg(*args, short*)) = i; break;
10295 default: *(va_arg(*args, int*)) = i; break;
10296 case 'l': *(va_arg(*args, long*)) = i; break;
10297 case 'V': *(va_arg(*args, IV*)) = i; break;
10300 *(va_arg(*args, Quad_t*)) = i; break;
10307 sv_setuv_mg(argsv, (UV)i);
10308 continue; /* not "break" */
10315 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
10316 && ckWARN(WARN_PRINTF))
10318 SV * const msg = sv_newmortal();
10319 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10320 (PL_op->op_type == OP_PRTF) ? "" : "s");
10321 if (fmtstart < patend) {
10322 const char * const fmtend = q < patend ? q : patend;
10324 sv_catpvs(msg, "\"%");
10325 for (f = fmtstart; f < fmtend; f++) {
10327 sv_catpvn(msg, f, 1);
10329 Perl_sv_catpvf(aTHX_ msg,
10330 "\\%03"UVof, (UV)*f & 0xFF);
10333 sv_catpvs(msg, "\"");
10335 sv_catpvs(msg, "end of string");
10337 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
10340 /* output mangled stuff ... */
10346 /* ... right here, because formatting flags should not apply */
10347 SvGROW(sv, SvCUR(sv) + elen + 1);
10349 Copy(eptr, p, elen, char);
10352 SvCUR_set(sv, p - SvPVX_const(sv));
10354 continue; /* not "break" */
10357 if (is_utf8 != has_utf8) {
10360 sv_utf8_upgrade(sv);
10363 const STRLEN old_elen = elen;
10364 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
10365 sv_utf8_upgrade(nsv);
10366 eptr = SvPVX_const(nsv);
10369 if (width) { /* fudge width (can't fudge elen) */
10370 width += elen - old_elen;
10376 have = esignlen + zeros + elen;
10378 Perl_croak_nocontext("%s", PL_memory_wrap);
10380 need = (have > width ? have : width);
10383 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
10384 Perl_croak_nocontext("%s", PL_memory_wrap);
10385 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10387 if (esignlen && fill == '0') {
10389 for (i = 0; i < (int)esignlen; i++)
10390 *p++ = esignbuf[i];
10392 if (gap && !left) {
10393 memset(p, fill, gap);
10396 if (esignlen && fill != '0') {
10398 for (i = 0; i < (int)esignlen; i++)
10399 *p++ = esignbuf[i];
10403 for (i = zeros; i; i--)
10407 Copy(eptr, p, elen, char);
10411 memset(p, ' ', gap);
10416 Copy(dotstr, p, dotstrlen, char);
10420 vectorize = FALSE; /* done iterating over vecstr */
10427 SvCUR_set(sv, p - SvPVX_const(sv));
10435 /* =========================================================================
10437 =head1 Cloning an interpreter
10439 All the macros and functions in this section are for the private use of
10440 the main function, perl_clone().
10442 The foo_dup() functions make an exact copy of an existing foo thingy.
10443 During the course of a cloning, a hash table is used to map old addresses
10444 to new addresses. The table is created and manipulated with the
10445 ptr_table_* functions.
10449 * =========================================================================*/
10452 #if defined(USE_ITHREADS)
10454 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
10455 #ifndef GpREFCNT_inc
10456 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10460 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
10461 that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
10462 If this changes, please unmerge ss_dup.
10463 Likewise, sv_dup_inc_multiple() relies on this fact. */
10464 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10465 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t))
10466 #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
10467 #define av_dup_inc(s,t) MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10468 #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
10469 #define hv_dup_inc(s,t) MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10470 #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
10471 #define cv_dup_inc(s,t) MUTABLE_CV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10472 #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
10473 #define io_dup_inc(s,t) MUTABLE_IO(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10474 #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
10475 #define gv_dup_inc(s,t) MUTABLE_GV(SvREFCNT_inc(sv_dup((const SV *)s,t)))
10476 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
10477 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
10479 /* clone a parser */
10482 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
10486 PERL_ARGS_ASSERT_PARSER_DUP;
10491 /* look for it in the table first */
10492 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
10496 /* create anew and remember what it is */
10497 Newxz(parser, 1, yy_parser);
10498 ptr_table_store(PL_ptr_table, proto, parser);
10500 parser->yyerrstatus = 0;
10501 parser->yychar = YYEMPTY; /* Cause a token to be read. */
10503 /* XXX these not yet duped */
10504 parser->old_parser = NULL;
10505 parser->stack = NULL;
10507 parser->stack_size = 0;
10508 /* XXX parser->stack->state = 0; */
10510 /* XXX eventually, just Copy() most of the parser struct ? */
10512 parser->lex_brackets = proto->lex_brackets;
10513 parser->lex_casemods = proto->lex_casemods;
10514 parser->lex_brackstack = savepvn(proto->lex_brackstack,
10515 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
10516 parser->lex_casestack = savepvn(proto->lex_casestack,
10517 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
10518 parser->lex_defer = proto->lex_defer;
10519 parser->lex_dojoin = proto->lex_dojoin;
10520 parser->lex_expect = proto->lex_expect;
10521 parser->lex_formbrack = proto->lex_formbrack;
10522 parser->lex_inpat = proto->lex_inpat;
10523 parser->lex_inwhat = proto->lex_inwhat;
10524 parser->lex_op = proto->lex_op;
10525 parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
10526 parser->lex_starts = proto->lex_starts;
10527 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
10528 parser->multi_close = proto->multi_close;
10529 parser->multi_open = proto->multi_open;
10530 parser->multi_start = proto->multi_start;
10531 parser->multi_end = proto->multi_end;
10532 parser->pending_ident = proto->pending_ident;
10533 parser->preambled = proto->preambled;
10534 parser->sublex_info = proto->sublex_info; /* XXX not quite right */
10535 parser->linestr = sv_dup_inc(proto->linestr, param);
10536 parser->expect = proto->expect;
10537 parser->copline = proto->copline;
10538 parser->last_lop_op = proto->last_lop_op;
10539 parser->lex_state = proto->lex_state;
10540 parser->rsfp = fp_dup(proto->rsfp, '<', param);
10541 /* rsfp_filters entries have fake IoDIRP() */
10542 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
10543 parser->in_my = proto->in_my;
10544 parser->in_my_stash = hv_dup(proto->in_my_stash, param);
10545 parser->error_count = proto->error_count;
10548 parser->linestr = sv_dup_inc(proto->linestr, param);
10551 char * const ols = SvPVX(proto->linestr);
10552 char * const ls = SvPVX(parser->linestr);
10554 parser->bufptr = ls + (proto->bufptr >= ols ?
10555 proto->bufptr - ols : 0);
10556 parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
10557 proto->oldbufptr - ols : 0);
10558 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
10559 proto->oldoldbufptr - ols : 0);
10560 parser->linestart = ls + (proto->linestart >= ols ?
10561 proto->linestart - ols : 0);
10562 parser->last_uni = ls + (proto->last_uni >= ols ?
10563 proto->last_uni - ols : 0);
10564 parser->last_lop = ls + (proto->last_lop >= ols ?
10565 proto->last_lop - ols : 0);
10567 parser->bufend = ls + SvCUR(parser->linestr);
10570 Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
10574 parser->endwhite = proto->endwhite;
10575 parser->faketokens = proto->faketokens;
10576 parser->lasttoke = proto->lasttoke;
10577 parser->nextwhite = proto->nextwhite;
10578 parser->realtokenstart = proto->realtokenstart;
10579 parser->skipwhite = proto->skipwhite;
10580 parser->thisclose = proto->thisclose;
10581 parser->thismad = proto->thismad;
10582 parser->thisopen = proto->thisopen;
10583 parser->thisstuff = proto->thisstuff;
10584 parser->thistoken = proto->thistoken;
10585 parser->thiswhite = proto->thiswhite;
10587 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
10588 parser->curforce = proto->curforce;
10590 Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
10591 Copy(proto->nexttype, parser->nexttype, 5, I32);
10592 parser->nexttoke = proto->nexttoke;
10595 /* XXX should clone saved_curcop here, but we aren't passed
10596 * proto_perl; so do it in perl_clone_using instead */
10602 /* duplicate a file handle */
10605 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
10609 PERL_ARGS_ASSERT_FP_DUP;
10610 PERL_UNUSED_ARG(type);
10613 return (PerlIO*)NULL;
10615 /* look for it in the table first */
10616 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10620 /* create anew and remember what it is */
10621 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10622 ptr_table_store(PL_ptr_table, fp, ret);
10626 /* duplicate a directory handle */
10629 Perl_dirp_dup(pTHX_ DIR *const dp)
10631 PERL_UNUSED_CONTEXT;
10638 /* duplicate a typeglob */
10641 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
10645 PERL_ARGS_ASSERT_GP_DUP;
10649 /* look for it in the table first */
10650 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10654 /* create anew and remember what it is */
10656 ptr_table_store(PL_ptr_table, gp, ret);
10659 /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
10660 on Newxz() to do this for us. */
10661 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10662 ret->gp_io = io_dup_inc(gp->gp_io, param);
10663 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10664 ret->gp_av = av_dup_inc(gp->gp_av, param);
10665 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10666 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10667 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10668 ret->gp_cvgen = gp->gp_cvgen;
10669 ret->gp_line = gp->gp_line;
10670 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
10674 /* duplicate a chain of magic */
10677 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
10679 MAGIC *mgret = NULL;
10680 MAGIC **mgprev_p = &mgret;
10682 PERL_ARGS_ASSERT_MG_DUP;
10684 for (; mg; mg = mg->mg_moremagic) {
10686 Newx(nmg, 1, MAGIC);
10688 mgprev_p = &(nmg->mg_moremagic);
10690 /* There was a comment "XXX copy dynamic vtable?" but as we don't have
10691 dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
10692 from the original commit adding Perl_mg_dup() - revision 4538.
10693 Similarly there is the annotation "XXX random ptr?" next to the
10694 assignment to nmg->mg_ptr. */
10697 /* FIXME for plugins
10698 if (nmg->mg_type == PERL_MAGIC_qr) {
10699 nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
10703 if(nmg->mg_type == PERL_MAGIC_backref) {
10704 /* The backref AV has its reference count deliberately bumped by
10707 = SvREFCNT_inc(av_dup_inc((const AV *) nmg->mg_obj, param));
10710 nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
10711 ? sv_dup_inc(nmg->mg_obj, param)
10712 : sv_dup(nmg->mg_obj, param);
10715 if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
10716 if (nmg->mg_len > 0) {
10717 nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
10718 if (nmg->mg_type == PERL_MAGIC_overload_table &&
10719 AMT_AMAGIC((AMT*)nmg->mg_ptr))
10721 AMT * const namtp = (AMT*)nmg->mg_ptr;
10722 sv_dup_inc_multiple((SV**)(namtp->table),
10723 (SV**)(namtp->table), NofAMmeth, param);
10726 else if (nmg->mg_len == HEf_SVKEY)
10727 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
10729 if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
10730 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10736 #endif /* USE_ITHREADS */
10738 /* create a new pointer-mapping table */
10741 Perl_ptr_table_new(pTHX)
10744 PERL_UNUSED_CONTEXT;
10746 Newx(tbl, 1, PTR_TBL_t);
10747 tbl->tbl_max = 511;
10748 tbl->tbl_items = 0;
10749 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10753 #define PTR_TABLE_HASH(ptr) \
10754 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
10757 we use the PTE_SVSLOT 'reservation' made above, both here (in the
10758 following define) and at call to new_body_inline made below in
10759 Perl_ptr_table_store()
10762 #define del_pte(p) del_body_type(p, PTE_SVSLOT)
10764 /* map an existing pointer using a table */
10766 STATIC PTR_TBL_ENT_t *
10767 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
10769 PTR_TBL_ENT_t *tblent;
10770 const UV hash = PTR_TABLE_HASH(sv);
10772 PERL_ARGS_ASSERT_PTR_TABLE_FIND;
10774 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10775 for (; tblent; tblent = tblent->next) {
10776 if (tblent->oldval == sv)
10783 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
10785 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
10787 PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
10788 PERL_UNUSED_CONTEXT;
10790 return tblent ? tblent->newval : NULL;
10793 /* add a new entry to a pointer-mapping table */
10796 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
10798 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
10800 PERL_ARGS_ASSERT_PTR_TABLE_STORE;
10801 PERL_UNUSED_CONTEXT;
10804 tblent->newval = newsv;
10806 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
10808 new_body_inline(tblent, PTE_SVSLOT);
10810 tblent->oldval = oldsv;
10811 tblent->newval = newsv;
10812 tblent->next = tbl->tbl_ary[entry];
10813 tbl->tbl_ary[entry] = tblent;
10815 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
10816 ptr_table_split(tbl);
10820 /* double the hash bucket size of an existing ptr table */
10823 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
10825 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10826 const UV oldsize = tbl->tbl_max + 1;
10827 UV newsize = oldsize * 2;
10830 PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
10831 PERL_UNUSED_CONTEXT;
10833 Renew(ary, newsize, PTR_TBL_ENT_t*);
10834 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10835 tbl->tbl_max = --newsize;
10836 tbl->tbl_ary = ary;
10837 for (i=0; i < oldsize; i++, ary++) {
10838 PTR_TBL_ENT_t **curentp, **entp, *ent;
10841 curentp = ary + oldsize;
10842 for (entp = ary, ent = *ary; ent; ent = *entp) {
10843 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10845 ent->next = *curentp;
10855 /* remove all the entries from a ptr table */
10858 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
10860 if (tbl && tbl->tbl_items) {
10861 register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary;
10862 UV riter = tbl->tbl_max;
10865 PTR_TBL_ENT_t *entry = array[riter];
10868 PTR_TBL_ENT_t * const oentry = entry;
10869 entry = entry->next;
10874 tbl->tbl_items = 0;
10878 /* clear and free a ptr table */
10881 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
10886 ptr_table_clear(tbl);
10887 Safefree(tbl->tbl_ary);
10891 #if defined(USE_ITHREADS)
10894 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
10896 PERL_ARGS_ASSERT_RVPV_DUP;
10899 SvRV_set(dstr, SvWEAKREF(sstr)
10900 ? sv_dup(SvRV_const(sstr), param)
10901 : sv_dup_inc(SvRV_const(sstr), param));
10904 else if (SvPVX_const(sstr)) {
10905 /* Has something there */
10907 /* Normal PV - clone whole allocated space */
10908 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10909 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10910 /* Not that normal - actually sstr is copy on write.
10911 But we are a true, independant SV, so: */
10912 SvREADONLY_off(dstr);
10917 /* Special case - not normally malloced for some reason */
10918 if (isGV_with_GP(sstr)) {
10919 /* Don't need to do anything here. */
10921 else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10922 /* A "shared" PV - clone it as "shared" PV */
10924 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10928 /* Some other special case - random pointer */
10929 SvPV_set(dstr, (char *) SvPVX_const(sstr));
10934 /* Copy the NULL */
10935 SvPV_set(dstr, NULL);
10939 /* duplicate a list of SVs. source and dest may point to the same memory. */
10941 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
10942 SSize_t items, CLONE_PARAMS *const param)
10944 PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
10946 while (items-- > 0) {
10947 *dest++ = sv_dup_inc(*source++, param);
10953 /* duplicate an SV of any type (including AV, HV etc) */
10956 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
10961 PERL_ARGS_ASSERT_SV_DUP;
10965 if (SvTYPE(sstr) == SVTYPEMASK) {
10966 #ifdef DEBUG_LEAKING_SCALARS_ABORT
10971 /* look for it in the table first */
10972 dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
10976 if(param->flags & CLONEf_JOIN_IN) {
10977 /** We are joining here so we don't want do clone
10978 something that is bad **/
10979 if (SvTYPE(sstr) == SVt_PVHV) {
10980 const HEK * const hvname = HvNAME_HEK(sstr);
10982 /** don't clone stashes if they already exist **/
10983 return MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
10987 /* create anew and remember what it is */
10990 #ifdef DEBUG_LEAKING_SCALARS
10991 dstr->sv_debug_optype = sstr->sv_debug_optype;
10992 dstr->sv_debug_line = sstr->sv_debug_line;
10993 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10994 dstr->sv_debug_cloned = 1;
10995 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10998 ptr_table_store(PL_ptr_table, sstr, dstr);
11001 SvFLAGS(dstr) = SvFLAGS(sstr);
11002 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
11003 SvREFCNT(dstr) = 0; /* must be before any other dups! */
11006 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
11007 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
11008 (void*)PL_watch_pvx, SvPVX_const(sstr));
11011 /* don't clone objects whose class has asked us not to */
11012 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
11017 switch (SvTYPE(sstr)) {
11019 SvANY(dstr) = NULL;
11022 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
11024 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11026 SvIV_set(dstr, SvIVX(sstr));
11030 SvANY(dstr) = new_XNV();
11031 SvNV_set(dstr, SvNVX(sstr));
11033 /* case SVt_BIND: */
11036 /* These are all the types that need complex bodies allocating. */
11038 const svtype sv_type = SvTYPE(sstr);
11039 const struct body_details *const sv_type_details
11040 = bodies_by_type + sv_type;
11044 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11059 assert(sv_type_details->body_size);
11060 if (sv_type_details->arena) {
11061 new_body_inline(new_body, sv_type);
11063 = (void*)((char*)new_body - sv_type_details->offset);
11065 new_body = new_NOARENA(sv_type_details);
11069 SvANY(dstr) = new_body;
11072 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
11073 ((char*)SvANY(dstr)) + sv_type_details->offset,
11074 sv_type_details->copy, char);
11076 Copy(((char*)SvANY(sstr)),
11077 ((char*)SvANY(dstr)),
11078 sv_type_details->body_size + sv_type_details->offset, char);
11081 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
11082 && !isGV_with_GP(dstr))
11083 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11085 /* The Copy above means that all the source (unduplicated) pointers
11086 are now in the destination. We can check the flags and the
11087 pointers in either, but it's possible that there's less cache
11088 missing by always going for the destination.
11089 FIXME - instrument and check that assumption */
11090 if (sv_type >= SVt_PVMG) {
11091 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
11092 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
11093 } else if (SvMAGIC(dstr))
11094 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
11096 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
11099 /* The cast silences a GCC warning about unhandled types. */
11100 switch ((int)sv_type) {
11110 /* FIXME for plugins */
11111 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
11114 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
11115 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
11116 LvTARG(dstr) = dstr;
11117 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
11118 LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
11120 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
11122 if(isGV_with_GP(sstr)) {
11123 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
11124 /* Don't call sv_add_backref here as it's going to be
11125 created as part of the magic cloning of the symbol
11126 table--unless this is during a join and the stash
11127 is not actually being cloned. */
11128 /* Danger Will Robinson - GvGP(dstr) isn't initialised
11129 at the point of this comment. */
11130 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
11131 if(param->flags & CLONEf_JOIN_IN) {
11132 const HEK * const hvname
11133 = HvNAME_HEK(GvSTASH(dstr));
11135 && GvSTASH(dstr) == gv_stashpvn(
11136 HEK_KEY(hvname), HEK_LEN(hvname), 0
11139 Perl_sv_add_backref(
11140 aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr
11143 GvGP(dstr) = gp_dup(GvGP(sstr), param);
11144 (void)GpREFCNT_inc(GvGP(dstr));
11146 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11149 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
11150 if (IoOFP(dstr) == IoIFP(sstr))
11151 IoOFP(dstr) = IoIFP(dstr);
11153 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
11154 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
11155 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
11156 /* I have no idea why fake dirp (rsfps)
11157 should be treated differently but otherwise
11158 we end up with leaks -- sky*/
11159 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
11160 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
11161 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
11163 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
11164 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
11165 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
11166 if (IoDIRP(dstr)) {
11167 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
11170 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
11173 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
11174 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
11175 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
11178 /* avoid cloning an empty array */
11179 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
11180 SV **dst_ary, **src_ary;
11181 SSize_t items = AvFILLp((const AV *)sstr) + 1;
11183 src_ary = AvARRAY((const AV *)sstr);
11184 Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
11185 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
11186 AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
11187 AvALLOC((const AV *)dstr) = dst_ary;
11188 if (AvREAL((const AV *)sstr)) {
11189 dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
11193 while (items-- > 0)
11194 *dst_ary++ = sv_dup(*src_ary++, param);
11195 if (!(param->flags & CLONEf_COPY_STACKS)
11198 av_reify(MUTABLE_AV(dstr)); /* #41138 */
11201 items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
11202 while (items-- > 0) {
11203 *dst_ary++ = &PL_sv_undef;
11207 AvARRAY(MUTABLE_AV(dstr)) = NULL;
11208 AvALLOC((const AV *)dstr) = (SV**)NULL;
11209 AvMAX( (const AV *)dstr) = -1;
11210 AvFILLp((const AV *)dstr) = -1;
11214 if (HvARRAY((const HV *)sstr)) {
11216 const bool sharekeys = !!HvSHAREKEYS(sstr);
11217 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
11218 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
11220 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
11221 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
11223 HvARRAY(dstr) = (HE**)darray;
11224 while (i <= sxhv->xhv_max) {
11225 const HE * const source = HvARRAY(sstr)[i];
11226 HvARRAY(dstr)[i] = source
11227 ? he_dup(source, sharekeys, param) : 0;
11232 const struct xpvhv_aux * const saux = HvAUX(sstr);
11233 struct xpvhv_aux * const daux = HvAUX(dstr);
11234 /* This flag isn't copied. */
11235 /* SvOOK_on(hv) attacks the IV flags. */
11236 SvFLAGS(dstr) |= SVf_OOK;
11238 hvname = saux->xhv_name;
11239 daux->xhv_name = hek_dup(hvname, param);
11241 daux->xhv_riter = saux->xhv_riter;
11242 daux->xhv_eiter = saux->xhv_eiter
11243 ? he_dup(saux->xhv_eiter,
11244 (bool)!!HvSHAREKEYS(sstr), param) : 0;
11245 /* backref array needs refcnt=2; see sv_add_backref */
11246 daux->xhv_backreferences =
11247 saux->xhv_backreferences
11248 ? MUTABLE_AV(SvREFCNT_inc(
11249 sv_dup_inc((const SV *)saux->xhv_backreferences, param)))
11252 daux->xhv_mro_meta = saux->xhv_mro_meta
11253 ? mro_meta_dup(saux->xhv_mro_meta, param)
11256 /* Record stashes for possible cloning in Perl_clone(). */
11258 av_push(param->stashes, dstr);
11262 HvARRAY(MUTABLE_HV(dstr)) = NULL;
11265 if (!(param->flags & CLONEf_COPY_STACKS)) {
11269 /* NOTE: not refcounted */
11270 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
11272 if (!CvISXSUB(dstr))
11273 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
11275 if (CvCONST(dstr) && CvISXSUB(dstr)) {
11276 CvXSUBANY(dstr).any_ptr =
11277 sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
11279 /* don't dup if copying back - CvGV isn't refcounted, so the
11280 * duped GV may never be freed. A bit of a hack! DAPM */
11281 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
11282 NULL : gv_dup(CvGV(dstr), param) ;
11283 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
11285 CvWEAKOUTSIDE(sstr)
11286 ? cv_dup( CvOUTSIDE(dstr), param)
11287 : cv_dup_inc(CvOUTSIDE(dstr), param);
11288 if (!CvISXSUB(dstr))
11289 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
11295 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11301 /* duplicate a context */
11304 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11306 PERL_CONTEXT *ncxs;
11308 PERL_ARGS_ASSERT_CX_DUP;
11311 return (PERL_CONTEXT*)NULL;
11313 /* look for it in the table first */
11314 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11318 /* create anew and remember what it is */
11319 Newx(ncxs, max + 1, PERL_CONTEXT);
11320 ptr_table_store(PL_ptr_table, cxs, ncxs);
11321 Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
11324 PERL_CONTEXT * const ncx = &ncxs[ix];
11325 if (CxTYPE(ncx) == CXt_SUBST) {
11326 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11329 switch (CxTYPE(ncx)) {
11331 ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
11332 ? cv_dup_inc(ncx->blk_sub.cv, param)
11333 : cv_dup(ncx->blk_sub.cv,param));
11334 ncx->blk_sub.argarray = (CxHASARGS(ncx)
11335 ? av_dup_inc(ncx->blk_sub.argarray,
11338 ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
11340 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
11341 ncx->blk_sub.oldcomppad);
11344 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
11346 ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
11348 case CXt_LOOP_LAZYSV:
11349 ncx->blk_loop.state_u.lazysv.end
11350 = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
11351 /* We are taking advantage of av_dup_inc and sv_dup_inc
11352 actually being the same function, and order equivalance of
11354 We can assert the later [but only at run time :-(] */
11355 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
11356 (void *) &ncx->blk_loop.state_u.lazysv.cur);
11358 ncx->blk_loop.state_u.ary.ary
11359 = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
11360 case CXt_LOOP_LAZYIV:
11361 case CXt_LOOP_PLAIN:
11362 if (CxPADLOOP(ncx)) {
11363 ncx->blk_loop.oldcomppad
11364 = (PAD*)ptr_table_fetch(PL_ptr_table,
11365 ncx->blk_loop.oldcomppad);
11367 ncx->blk_loop.oldcomppad
11368 = (PAD*)gv_dup((const GV *)ncx->blk_loop.oldcomppad,
11373 ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
11374 ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
11375 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
11388 /* duplicate a stack info structure */
11391 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11395 PERL_ARGS_ASSERT_SI_DUP;
11398 return (PERL_SI*)NULL;
11400 /* look for it in the table first */
11401 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11405 /* create anew and remember what it is */
11406 Newxz(nsi, 1, PERL_SI);
11407 ptr_table_store(PL_ptr_table, si, nsi);
11409 nsi->si_stack = av_dup_inc(si->si_stack, param);
11410 nsi->si_cxix = si->si_cxix;
11411 nsi->si_cxmax = si->si_cxmax;
11412 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11413 nsi->si_type = si->si_type;
11414 nsi->si_prev = si_dup(si->si_prev, param);
11415 nsi->si_next = si_dup(si->si_next, param);
11416 nsi->si_markoff = si->si_markoff;
11421 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
11422 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
11423 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
11424 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
11425 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
11426 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
11427 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
11428 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
11429 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
11430 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
11431 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
11432 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
11433 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11434 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11437 #define pv_dup_inc(p) SAVEPV(p)
11438 #define pv_dup(p) SAVEPV(p)
11439 #define svp_dup_inc(p,pp) any_dup(p,pp)
11441 /* map any object to the new equivent - either something in the
11442 * ptr table, or something in the interpreter structure
11446 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
11450 PERL_ARGS_ASSERT_ANY_DUP;
11453 return (void*)NULL;
11455 /* look for it in the table first */
11456 ret = ptr_table_fetch(PL_ptr_table, v);
11460 /* see if it is part of the interpreter structure */
11461 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11462 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11470 /* duplicate the save stack */
11473 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11476 ANY * const ss = proto_perl->Isavestack;
11477 const I32 max = proto_perl->Isavestack_max;
11478 I32 ix = proto_perl->Isavestack_ix;
11491 void (*dptr) (void*);
11492 void (*dxptr) (pTHX_ void*);
11494 PERL_ARGS_ASSERT_SS_DUP;
11496 Newxz(nss, max, ANY);
11499 const I32 type = POPINT(ss,ix);
11500 TOPINT(nss,ix) = type;
11502 case SAVEt_HELEM: /* hash element */
11503 sv = (const SV *)POPPTR(ss,ix);
11504 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11506 case SAVEt_ITEM: /* normal string */
11507 case SAVEt_SV: /* scalar reference */
11508 sv = (const SV *)POPPTR(ss,ix);
11509 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11512 case SAVEt_MORTALIZESV:
11513 sv = (const SV *)POPPTR(ss,ix);
11514 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11516 case SAVEt_SHARED_PVREF: /* char* in shared space */
11517 c = (char*)POPPTR(ss,ix);
11518 TOPPTR(nss,ix) = savesharedpv(c);
11519 ptr = POPPTR(ss,ix);
11520 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11522 case SAVEt_GENERIC_SVREF: /* generic sv */
11523 case SAVEt_SVREF: /* scalar reference */
11524 sv = (const SV *)POPPTR(ss,ix);
11525 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11526 ptr = POPPTR(ss,ix);
11527 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11529 case SAVEt_HV: /* hash reference */
11530 case SAVEt_AV: /* array reference */
11531 sv = (const SV *) POPPTR(ss,ix);
11532 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11534 case SAVEt_COMPPAD:
11536 sv = (const SV *) POPPTR(ss,ix);
11537 TOPPTR(nss,ix) = sv_dup(sv, param);
11539 case SAVEt_INT: /* int reference */
11540 ptr = POPPTR(ss,ix);
11541 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11542 intval = (int)POPINT(ss,ix);
11543 TOPINT(nss,ix) = intval;
11545 case SAVEt_LONG: /* long reference */
11546 ptr = POPPTR(ss,ix);
11547 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11549 case SAVEt_CLEARSV:
11550 longval = (long)POPLONG(ss,ix);
11551 TOPLONG(nss,ix) = longval;
11553 case SAVEt_I32: /* I32 reference */
11554 case SAVEt_I16: /* I16 reference */
11555 case SAVEt_I8: /* I8 reference */
11556 case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
11557 ptr = POPPTR(ss,ix);
11558 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11560 TOPINT(nss,ix) = i;
11562 case SAVEt_IV: /* IV reference */
11563 ptr = POPPTR(ss,ix);
11564 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11566 TOPIV(nss,ix) = iv;
11568 case SAVEt_HPTR: /* HV* reference */
11569 case SAVEt_APTR: /* AV* reference */
11570 case SAVEt_SPTR: /* SV* reference */
11571 ptr = POPPTR(ss,ix);
11572 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11573 sv = (const SV *)POPPTR(ss,ix);
11574 TOPPTR(nss,ix) = sv_dup(sv, param);
11576 case SAVEt_VPTR: /* random* reference */
11577 ptr = POPPTR(ss,ix);
11578 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11579 ptr = POPPTR(ss,ix);
11580 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11582 case SAVEt_GENERIC_PVREF: /* generic char* */
11583 case SAVEt_PPTR: /* char* reference */
11584 ptr = POPPTR(ss,ix);
11585 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11586 c = (char*)POPPTR(ss,ix);
11587 TOPPTR(nss,ix) = pv_dup(c);
11589 case SAVEt_GP: /* scalar reference */
11590 gp = (GP*)POPPTR(ss,ix);
11591 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11592 (void)GpREFCNT_inc(gp);
11593 gv = (const GV *)POPPTR(ss,ix);
11594 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11597 ptr = POPPTR(ss,ix);
11598 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11599 /* these are assumed to be refcounted properly */
11601 switch (((OP*)ptr)->op_type) {
11603 case OP_LEAVESUBLV:
11607 case OP_LEAVEWRITE:
11608 TOPPTR(nss,ix) = ptr;
11611 (void) OpREFCNT_inc(o);
11615 TOPPTR(nss,ix) = NULL;
11620 TOPPTR(nss,ix) = NULL;
11623 hv = (const HV *)POPPTR(ss,ix);
11624 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11626 TOPINT(nss,ix) = i;
11629 c = (char*)POPPTR(ss,ix);
11630 TOPPTR(nss,ix) = pv_dup_inc(c);
11632 case SAVEt_STACK_POS: /* Position on Perl stack */
11634 TOPINT(nss,ix) = i;
11636 case SAVEt_DESTRUCTOR:
11637 ptr = POPPTR(ss,ix);
11638 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11639 dptr = POPDPTR(ss,ix);
11640 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
11641 any_dup(FPTR2DPTR(void *, dptr),
11644 case SAVEt_DESTRUCTOR_X:
11645 ptr = POPPTR(ss,ix);
11646 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11647 dxptr = POPDXPTR(ss,ix);
11648 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
11649 any_dup(FPTR2DPTR(void *, dxptr),
11652 case SAVEt_REGCONTEXT:
11655 TOPINT(nss,ix) = i;
11658 case SAVEt_AELEM: /* array element */
11659 sv = (const SV *)POPPTR(ss,ix);
11660 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11662 TOPINT(nss,ix) = i;
11663 av = (const AV *)POPPTR(ss,ix);
11664 TOPPTR(nss,ix) = av_dup_inc(av, param);
11667 ptr = POPPTR(ss,ix);
11668 TOPPTR(nss,ix) = ptr;
11671 ptr = POPPTR(ss,ix);
11674 ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
11675 HINTS_REFCNT_UNLOCK;
11677 TOPPTR(nss,ix) = ptr;
11679 TOPINT(nss,ix) = i;
11680 if (i & HINT_LOCALIZE_HH) {
11681 hv = (const HV *)POPPTR(ss,ix);
11682 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11685 case SAVEt_PADSV_AND_MORTALIZE:
11686 longval = (long)POPLONG(ss,ix);
11687 TOPLONG(nss,ix) = longval;
11688 ptr = POPPTR(ss,ix);
11689 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11690 sv = (const SV *)POPPTR(ss,ix);
11691 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11694 ptr = POPPTR(ss,ix);
11695 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11696 longval = (long)POPBOOL(ss,ix);
11697 TOPBOOL(nss,ix) = (bool)longval;
11699 case SAVEt_SET_SVFLAGS:
11701 TOPINT(nss,ix) = i;
11703 TOPINT(nss,ix) = i;
11704 sv = (const SV *)POPPTR(ss,ix);
11705 TOPPTR(nss,ix) = sv_dup(sv, param);
11707 case SAVEt_RE_STATE:
11709 const struct re_save_state *const old_state
11710 = (struct re_save_state *)
11711 (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11712 struct re_save_state *const new_state
11713 = (struct re_save_state *)
11714 (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11716 Copy(old_state, new_state, 1, struct re_save_state);
11717 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11719 new_state->re_state_bostr
11720 = pv_dup(old_state->re_state_bostr);
11721 new_state->re_state_reginput
11722 = pv_dup(old_state->re_state_reginput);
11723 new_state->re_state_regeol
11724 = pv_dup(old_state->re_state_regeol);
11725 new_state->re_state_regoffs
11726 = (regexp_paren_pair*)
11727 any_dup(old_state->re_state_regoffs, proto_perl);
11728 new_state->re_state_reglastparen
11729 = (U32*) any_dup(old_state->re_state_reglastparen,
11731 new_state->re_state_reglastcloseparen
11732 = (U32*)any_dup(old_state->re_state_reglastcloseparen,
11734 /* XXX This just has to be broken. The old save_re_context
11735 code did SAVEGENERICPV(PL_reg_start_tmp);
11736 PL_reg_start_tmp is char **.
11737 Look above to what the dup code does for
11738 SAVEt_GENERIC_PVREF
11739 It can never have worked.
11740 So this is merely a faithful copy of the exiting bug: */
11741 new_state->re_state_reg_start_tmp
11742 = (char **) pv_dup((char *)
11743 old_state->re_state_reg_start_tmp);
11744 /* I assume that it only ever "worked" because no-one called
11745 (pseudo)fork while the regexp engine had re-entered itself.
11747 #ifdef PERL_OLD_COPY_ON_WRITE
11748 new_state->re_state_nrs
11749 = sv_dup(old_state->re_state_nrs, param);
11751 new_state->re_state_reg_magic
11752 = (MAGIC*) any_dup(old_state->re_state_reg_magic,
11754 new_state->re_state_reg_oldcurpm
11755 = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
11757 new_state->re_state_reg_curpm
11758 = (PMOP*) any_dup(old_state->re_state_reg_curpm,
11760 new_state->re_state_reg_oldsaved
11761 = pv_dup(old_state->re_state_reg_oldsaved);
11762 new_state->re_state_reg_poscache
11763 = pv_dup(old_state->re_state_reg_poscache);
11764 new_state->re_state_reg_starttry
11765 = pv_dup(old_state->re_state_reg_starttry);
11768 case SAVEt_COMPILE_WARNINGS:
11769 ptr = POPPTR(ss,ix);
11770 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
11773 ptr = POPPTR(ss,ix);
11774 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
11778 "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
11786 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11787 * flag to the result. This is done for each stash before cloning starts,
11788 * so we know which stashes want their objects cloned */
11791 do_mark_cloneable_stash(pTHX_ SV *const sv)
11793 const HEK * const hvname = HvNAME_HEK((const HV *)sv);
11795 GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
11796 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11797 if (cloner && GvCV(cloner)) {
11804 mXPUSHs(newSVhek(hvname));
11806 call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
11813 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11821 =for apidoc perl_clone
11823 Create and return a new interpreter by cloning the current one.
11825 perl_clone takes these flags as parameters:
11827 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11828 without it we only clone the data and zero the stacks,
11829 with it we copy the stacks and the new perl interpreter is
11830 ready to run at the exact same point as the previous one.
11831 The pseudo-fork code uses COPY_STACKS while the
11832 threads->create doesn't.
11834 CLONEf_KEEP_PTR_TABLE
11835 perl_clone keeps a ptr_table with the pointer of the old
11836 variable as a key and the new variable as a value,
11837 this allows it to check if something has been cloned and not
11838 clone it again but rather just use the value and increase the
11839 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11840 the ptr_table using the function
11841 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11842 reason to keep it around is if you want to dup some of your own
11843 variable who are outside the graph perl scans, example of this
11844 code is in threads.xs create
11847 This is a win32 thing, it is ignored on unix, it tells perls
11848 win32host code (which is c++) to clone itself, this is needed on
11849 win32 if you want to run two threads at the same time,
11850 if you just want to do some stuff in a separate perl interpreter
11851 and then throw it away and return to the original one,
11852 you don't need to do anything.
11857 /* XXX the above needs expanding by someone who actually understands it ! */
11858 EXTERN_C PerlInterpreter *
11859 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11862 perl_clone(PerlInterpreter *proto_perl, UV flags)
11865 #ifdef PERL_IMPLICIT_SYS
11867 PERL_ARGS_ASSERT_PERL_CLONE;
11869 /* perlhost.h so we need to call into it
11870 to clone the host, CPerlHost should have a c interface, sky */
11872 if (flags & CLONEf_CLONE_HOST) {
11873 return perl_clone_host(proto_perl,flags);
11875 return perl_clone_using(proto_perl, flags,
11877 proto_perl->IMemShared,
11878 proto_perl->IMemParse,
11880 proto_perl->IStdIO,
11884 proto_perl->IProc);
11888 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11889 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11890 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11891 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11892 struct IPerlDir* ipD, struct IPerlSock* ipS,
11893 struct IPerlProc* ipP)
11895 /* XXX many of the string copies here can be optimized if they're
11896 * constants; they need to be allocated as common memory and just
11897 * their pointers copied. */
11900 CLONE_PARAMS clone_params;
11901 CLONE_PARAMS* const param = &clone_params;
11903 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11905 PERL_ARGS_ASSERT_PERL_CLONE_USING;
11906 #else /* !PERL_IMPLICIT_SYS */
11908 CLONE_PARAMS clone_params;
11909 CLONE_PARAMS* param = &clone_params;
11910 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11912 PERL_ARGS_ASSERT_PERL_CLONE;
11913 #endif /* PERL_IMPLICIT_SYS */
11915 /* for each stash, determine whether its objects should be cloned */
11916 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11917 PERL_SET_THX(my_perl);
11920 PoisonNew(my_perl, 1, PerlInterpreter);
11925 PL_scopestack_name = 0;
11927 PL_savestack_ix = 0;
11928 PL_savestack_max = -1;
11929 PL_sig_pending = 0;
11931 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11932 # ifdef DEBUG_LEAKING_SCALARS
11933 PL_sv_serial = (((U32)my_perl >> 2) & 0xfff) * 1000000;
11935 #else /* !DEBUGGING */
11936 Zero(my_perl, 1, PerlInterpreter);
11937 #endif /* DEBUGGING */
11939 #ifdef PERL_IMPLICIT_SYS
11940 /* host pointers */
11942 PL_MemShared = ipMS;
11943 PL_MemParse = ipMP;
11950 #endif /* PERL_IMPLICIT_SYS */
11952 param->flags = flags;
11953 param->proto_perl = proto_perl;
11955 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
11957 PL_body_arenas = NULL;
11958 Zero(&PL_body_roots, 1, PL_body_roots);
11960 PL_nice_chunk = NULL;
11961 PL_nice_chunk_size = 0;
11963 PL_sv_objcount = 0;
11965 PL_sv_arenaroot = NULL;
11967 PL_debug = proto_perl->Idebug;
11969 PL_hash_seed = proto_perl->Ihash_seed;
11970 PL_rehash_seed = proto_perl->Irehash_seed;
11972 #ifdef USE_REENTRANT_API
11973 /* XXX: things like -Dm will segfault here in perlio, but doing
11974 * PERL_SET_CONTEXT(proto_perl);
11975 * breaks too many other things
11977 Perl_reentrant_init(aTHX);
11980 /* create SV map for pointer relocation */
11981 PL_ptr_table = ptr_table_new();
11983 /* initialize these special pointers as early as possible */
11984 SvANY(&PL_sv_undef) = NULL;
11985 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11986 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11987 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11989 SvANY(&PL_sv_no) = new_XPVNV();
11990 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11991 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11992 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11993 SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
11994 SvCUR_set(&PL_sv_no, 0);
11995 SvLEN_set(&PL_sv_no, 1);
11996 SvIV_set(&PL_sv_no, 0);
11997 SvNV_set(&PL_sv_no, 0);
11998 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
12000 SvANY(&PL_sv_yes) = new_XPVNV();
12001 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
12002 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12003 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12004 SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
12005 SvCUR_set(&PL_sv_yes, 1);
12006 SvLEN_set(&PL_sv_yes, 2);
12007 SvIV_set(&PL_sv_yes, 1);
12008 SvNV_set(&PL_sv_yes, 1);
12009 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
12011 /* dbargs array probably holds garbage; give the child a clean array */
12012 PL_dbargs = newAV();
12013 ptr_table_store(PL_ptr_table, proto_perl->Idbargs, PL_dbargs);
12015 /* create (a non-shared!) shared string table */
12016 PL_strtab = newHV();
12017 HvSHAREKEYS_off(PL_strtab);
12018 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
12019 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
12021 PL_compiling = proto_perl->Icompiling;
12023 /* These two PVs will be free'd special way so must set them same way op.c does */
12024 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
12025 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
12027 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
12028 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
12030 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
12031 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
12032 if (PL_compiling.cop_hints_hash) {
12034 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
12035 HINTS_REFCNT_UNLOCK;
12037 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
12038 #ifdef PERL_DEBUG_READONLY_OPS
12043 /* pseudo environmental stuff */
12044 PL_origargc = proto_perl->Iorigargc;
12045 PL_origargv = proto_perl->Iorigargv;
12047 param->stashes = newAV(); /* Setup array of objects to call clone on */
12049 /* Set tainting stuff before PerlIO_debug can possibly get called */
12050 PL_tainting = proto_perl->Itainting;
12051 PL_taint_warn = proto_perl->Itaint_warn;
12053 #ifdef PERLIO_LAYERS
12054 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
12055 PerlIO_clone(aTHX_ proto_perl, param);
12058 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
12059 PL_incgv = gv_dup(proto_perl->Iincgv, param);
12060 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
12061 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
12062 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
12063 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
12066 PL_minus_c = proto_perl->Iminus_c;
12067 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
12068 PL_localpatches = proto_perl->Ilocalpatches;
12069 PL_splitstr = proto_perl->Isplitstr;
12070 PL_minus_n = proto_perl->Iminus_n;
12071 PL_minus_p = proto_perl->Iminus_p;
12072 PL_minus_l = proto_perl->Iminus_l;
12073 PL_minus_a = proto_perl->Iminus_a;
12074 PL_minus_E = proto_perl->Iminus_E;
12075 PL_minus_F = proto_perl->Iminus_F;
12076 PL_doswitches = proto_perl->Idoswitches;
12077 PL_dowarn = proto_perl->Idowarn;
12078 PL_doextract = proto_perl->Idoextract;
12079 PL_sawampersand = proto_perl->Isawampersand;
12080 PL_unsafe = proto_perl->Iunsafe;
12081 PL_inplace = SAVEPV(proto_perl->Iinplace);
12082 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
12083 PL_perldb = proto_perl->Iperldb;
12084 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
12085 PL_exit_flags = proto_perl->Iexit_flags;
12087 /* magical thingies */
12088 /* XXX time(&PL_basetime) when asked for? */
12089 PL_basetime = proto_perl->Ibasetime;
12090 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
12092 PL_maxsysfd = proto_perl->Imaxsysfd;
12093 PL_statusvalue = proto_perl->Istatusvalue;
12095 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
12097 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
12099 PL_encoding = sv_dup(proto_perl->Iencoding, param);
12101 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
12102 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
12103 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
12106 /* RE engine related */
12107 Zero(&PL_reg_state, 1, struct re_save_state);
12108 PL_reginterp_cnt = 0;
12109 PL_regmatch_slab = NULL;
12111 /* Clone the regex array */
12112 /* ORANGE FIXME for plugins, probably in the SV dup code.
12113 newSViv(PTR2IV(CALLREGDUPE(
12114 INT2PTR(REGEXP *, SvIVX(regex)), param))))
12116 PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
12117 PL_regex_pad = AvARRAY(PL_regex_padav);
12119 /* shortcuts to various I/O objects */
12120 PL_ofsgv = gv_dup(proto_perl->Iofsgv, param);
12121 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
12122 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
12123 PL_defgv = gv_dup(proto_perl->Idefgv, param);
12124 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
12125 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
12126 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
12128 /* shortcuts to regexp stuff */
12129 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
12131 /* shortcuts to misc objects */
12132 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
12134 /* shortcuts to debugging objects */
12135 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
12136 PL_DBline = gv_dup(proto_perl->IDBline, param);
12137 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
12138 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
12139 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
12140 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
12142 /* symbol tables */
12143 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
12144 PL_curstash = hv_dup(proto_perl->Icurstash, param);
12145 PL_debstash = hv_dup(proto_perl->Idebstash, param);
12146 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
12147 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
12149 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
12150 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
12151 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
12152 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
12153 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
12154 PL_endav = av_dup_inc(proto_perl->Iendav, param);
12155 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
12156 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
12158 PL_sub_generation = proto_perl->Isub_generation;
12159 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
12161 /* funky return mechanisms */
12162 PL_forkprocess = proto_perl->Iforkprocess;
12164 /* subprocess state */
12165 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
12167 /* internal state */
12168 PL_maxo = proto_perl->Imaxo;
12169 if (proto_perl->Iop_mask)
12170 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
12173 /* PL_asserting = proto_perl->Iasserting; */
12175 /* current interpreter roots */
12176 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
12178 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
12180 PL_main_start = proto_perl->Imain_start;
12181 PL_eval_root = proto_perl->Ieval_root;
12182 PL_eval_start = proto_perl->Ieval_start;
12184 /* runtime control stuff */
12185 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
12187 PL_filemode = proto_perl->Ifilemode;
12188 PL_lastfd = proto_perl->Ilastfd;
12189 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
12192 PL_gensym = proto_perl->Igensym;
12193 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
12194 PL_laststatval = proto_perl->Ilaststatval;
12195 PL_laststype = proto_perl->Ilaststype;
12198 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
12200 /* interpreter atexit processing */
12201 PL_exitlistlen = proto_perl->Iexitlistlen;
12202 if (PL_exitlistlen) {
12203 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12204 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12207 PL_exitlist = (PerlExitListEntry*)NULL;
12209 PL_my_cxt_size = proto_perl->Imy_cxt_size;
12210 if (PL_my_cxt_size) {
12211 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
12212 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
12213 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12214 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
12215 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
12219 PL_my_cxt_list = (void**)NULL;
12220 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12221 PL_my_cxt_keys = (const char**)NULL;
12224 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
12225 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
12226 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
12228 PL_profiledata = NULL;
12230 PL_compcv = cv_dup(proto_perl->Icompcv, param);
12232 PAD_CLONE_VARS(proto_perl, param);
12234 #ifdef HAVE_INTERP_INTERN
12235 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
12238 /* more statics moved here */
12239 PL_generation = proto_perl->Igeneration;
12240 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
12242 PL_in_clean_objs = proto_perl->Iin_clean_objs;
12243 PL_in_clean_all = proto_perl->Iin_clean_all;
12245 PL_uid = proto_perl->Iuid;
12246 PL_euid = proto_perl->Ieuid;
12247 PL_gid = proto_perl->Igid;
12248 PL_egid = proto_perl->Iegid;
12249 PL_nomemok = proto_perl->Inomemok;
12250 PL_an = proto_perl->Ian;
12251 PL_evalseq = proto_perl->Ievalseq;
12252 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
12253 PL_origalen = proto_perl->Iorigalen;
12254 #ifdef PERL_USES_PL_PIDSTATUS
12255 PL_pidstatus = newHV(); /* XXX flag for cloning? */
12257 PL_osname = SAVEPV(proto_perl->Iosname);
12258 PL_sighandlerp = proto_perl->Isighandlerp;
12260 PL_runops = proto_perl->Irunops;
12262 PL_parser = parser_dup(proto_perl->Iparser, param);
12264 /* XXX this only works if the saved cop has already been cloned */
12265 if (proto_perl->Iparser) {
12266 PL_parser->saved_curcop = (COP*)any_dup(
12267 proto_perl->Iparser->saved_curcop,
12271 PL_subline = proto_perl->Isubline;
12272 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
12275 PL_cryptseen = proto_perl->Icryptseen;
12278 PL_hints = proto_perl->Ihints;
12280 PL_amagic_generation = proto_perl->Iamagic_generation;
12282 #ifdef USE_LOCALE_COLLATE
12283 PL_collation_ix = proto_perl->Icollation_ix;
12284 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
12285 PL_collation_standard = proto_perl->Icollation_standard;
12286 PL_collxfrm_base = proto_perl->Icollxfrm_base;
12287 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
12288 #endif /* USE_LOCALE_COLLATE */
12290 #ifdef USE_LOCALE_NUMERIC
12291 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
12292 PL_numeric_standard = proto_perl->Inumeric_standard;
12293 PL_numeric_local = proto_perl->Inumeric_local;
12294 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12295 #endif /* !USE_LOCALE_NUMERIC */
12297 /* utf8 character classes */
12298 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12299 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12300 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12301 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
12302 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12303 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
12304 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
12305 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
12306 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
12307 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
12308 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
12309 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12310 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
12311 PL_utf8_X_begin = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
12312 PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
12313 PL_utf8_X_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
12314 PL_utf8_X_non_hangul = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
12315 PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
12316 PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
12317 PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
12318 PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
12319 PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
12320 PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
12321 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12322 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12323 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12324 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12325 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12326 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12328 /* Did the locale setup indicate UTF-8? */
12329 PL_utf8locale = proto_perl->Iutf8locale;
12330 /* Unicode features (see perlrun/-C) */
12331 PL_unicode = proto_perl->Iunicode;
12333 /* Pre-5.8 signals control */
12334 PL_signals = proto_perl->Isignals;
12336 /* times() ticks per second */
12337 PL_clocktick = proto_perl->Iclocktick;
12339 /* Recursion stopper for PerlIO_find_layer */
12340 PL_in_load_module = proto_perl->Iin_load_module;
12342 /* sort() routine */
12343 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
12345 /* Not really needed/useful since the reenrant_retint is "volatile",
12346 * but do it for consistency's sake. */
12347 PL_reentrant_retint = proto_perl->Ireentrant_retint;
12349 /* Hooks to shared SVs and locks. */
12350 PL_sharehook = proto_perl->Isharehook;
12351 PL_lockhook = proto_perl->Ilockhook;
12352 PL_unlockhook = proto_perl->Iunlockhook;
12353 PL_threadhook = proto_perl->Ithreadhook;
12354 PL_destroyhook = proto_perl->Idestroyhook;
12356 #ifdef THREADS_HAVE_PIDS
12357 PL_ppid = proto_perl->Ippid;
12361 PL_last_swash_hv = NULL; /* reinits on demand */
12362 PL_last_swash_klen = 0;
12363 PL_last_swash_key[0]= '\0';
12364 PL_last_swash_tmps = (U8*)NULL;
12365 PL_last_swash_slen = 0;
12367 PL_glob_index = proto_perl->Iglob_index;
12368 PL_srand_called = proto_perl->Isrand_called;
12370 if (proto_perl->Ipsig_pend) {
12371 Newxz(PL_psig_pend, SIG_SIZE, int);
12374 PL_psig_pend = (int*)NULL;
12377 if (proto_perl->Ipsig_name) {
12378 Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
12379 sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
12381 PL_psig_ptr = PL_psig_name + SIG_SIZE;
12384 PL_psig_ptr = (SV**)NULL;
12385 PL_psig_name = (SV**)NULL;
12388 /* intrpvar.h stuff */
12390 if (flags & CLONEf_COPY_STACKS) {
12391 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12392 PL_tmps_ix = proto_perl->Itmps_ix;
12393 PL_tmps_max = proto_perl->Itmps_max;
12394 PL_tmps_floor = proto_perl->Itmps_floor;
12395 Newx(PL_tmps_stack, PL_tmps_max, SV*);
12396 sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
12397 PL_tmps_ix+1, param);
12399 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12400 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
12401 Newxz(PL_markstack, i, I32);
12402 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
12403 - proto_perl->Imarkstack);
12404 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
12405 - proto_perl->Imarkstack);
12406 Copy(proto_perl->Imarkstack, PL_markstack,
12407 PL_markstack_ptr - PL_markstack + 1, I32);
12409 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12410 * NOTE: unlike the others! */
12411 PL_scopestack_ix = proto_perl->Iscopestack_ix;
12412 PL_scopestack_max = proto_perl->Iscopestack_max;
12413 Newxz(PL_scopestack, PL_scopestack_max, I32);
12414 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
12417 Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
12418 Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
12420 /* NOTE: si_dup() looks at PL_markstack */
12421 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
12423 /* PL_curstack = PL_curstackinfo->si_stack; */
12424 PL_curstack = av_dup(proto_perl->Icurstack, param);
12425 PL_mainstack = av_dup(proto_perl->Imainstack, param);
12427 /* next PUSHs() etc. set *(PL_stack_sp+1) */
12428 PL_stack_base = AvARRAY(PL_curstack);
12429 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
12430 - proto_perl->Istack_base);
12431 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
12433 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12434 * NOTE: unlike the others! */
12435 PL_savestack_ix = proto_perl->Isavestack_ix;
12436 PL_savestack_max = proto_perl->Isavestack_max;
12437 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
12438 PL_savestack = ss_dup(proto_perl, param);
12442 ENTER; /* perl_destruct() wants to LEAVE; */
12444 /* although we're not duplicating the tmps stack, we should still
12445 * add entries for any SVs on the tmps stack that got cloned by a
12446 * non-refcount means (eg a temp in @_); otherwise they will be
12449 for (i = 0; i<= proto_perl->Itmps_ix; i++) {
12450 SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table,
12451 proto_perl->Itmps_stack[i]));
12452 if (nsv && !SvREFCNT(nsv)) {
12453 PUSH_EXTEND_MORTAL__SV_C(SvREFCNT_inc_simple(nsv));
12458 PL_start_env = proto_perl->Istart_env; /* XXXXXX */
12459 PL_top_env = &PL_start_env;
12461 PL_op = proto_perl->Iop;
12464 PL_Xpv = (XPV*)NULL;
12465 my_perl->Ina = proto_perl->Ina;
12467 PL_statbuf = proto_perl->Istatbuf;
12468 PL_statcache = proto_perl->Istatcache;
12469 PL_statgv = gv_dup(proto_perl->Istatgv, param);
12470 PL_statname = sv_dup_inc(proto_perl->Istatname, param);
12472 PL_timesbuf = proto_perl->Itimesbuf;
12475 PL_tainted = proto_perl->Itainted;
12476 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
12477 PL_rs = sv_dup_inc(proto_perl->Irs, param);
12478 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
12479 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
12480 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
12481 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
12482 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
12483 PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
12485 PL_restartop = proto_perl->Irestartop;
12486 PL_in_eval = proto_perl->Iin_eval;
12487 PL_delaymagic = proto_perl->Idelaymagic;
12488 PL_dirty = proto_perl->Idirty;
12489 PL_localizing = proto_perl->Ilocalizing;
12491 PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
12492 PL_hv_fetch_ent_mh = NULL;
12493 PL_modcount = proto_perl->Imodcount;
12494 PL_lastgotoprobe = NULL;
12495 PL_dumpindent = proto_perl->Idumpindent;
12497 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
12498 PL_sortstash = hv_dup(proto_perl->Isortstash, param);
12499 PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
12500 PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
12501 PL_efloatbuf = NULL; /* reinits on demand */
12502 PL_efloatsize = 0; /* reinits on demand */
12506 PL_screamfirst = NULL;
12507 PL_screamnext = NULL;
12508 PL_maxscream = -1; /* reinits on demand */
12509 PL_lastscream = NULL;
12512 PL_regdummy = proto_perl->Iregdummy;
12513 PL_colorset = 0; /* reinits PL_colors[] */
12514 /*PL_colors[6] = {0,0,0,0,0,0};*/
12518 /* Pluggable optimizer */
12519 PL_peepp = proto_perl->Ipeepp;
12520 /* op_free() hook */
12521 PL_opfreehook = proto_perl->Iopfreehook;
12523 PL_stashcache = newHV();
12525 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
12526 proto_perl->Iwatchaddr);
12527 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
12528 if (PL_debug && PL_watchaddr) {
12529 PerlIO_printf(Perl_debug_log,
12530 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
12531 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
12532 PTR2UV(PL_watchok));
12535 PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
12537 /* Call the ->CLONE method, if it exists, for each of the stashes
12538 identified by sv_dup() above.
12540 while(av_len(param->stashes) != -1) {
12541 HV* const stash = MUTABLE_HV(av_shift(param->stashes));
12542 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12543 if (cloner && GvCV(cloner)) {
12548 mXPUSHs(newSVhek(HvNAME_HEK(stash)));
12550 call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
12556 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12557 ptr_table_free(PL_ptr_table);
12558 PL_ptr_table = NULL;
12562 SvREFCNT_dec(param->stashes);
12564 /* orphaned? eg threads->new inside BEGIN or use */
12565 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12566 SvREFCNT_inc_simple_void(PL_compcv);
12567 SAVEFREESV(PL_compcv);
12573 #endif /* USE_ITHREADS */
12576 =head1 Unicode Support
12578 =for apidoc sv_recode_to_utf8
12580 The encoding is assumed to be an Encode object, on entry the PV
12581 of the sv is assumed to be octets in that encoding, and the sv
12582 will be converted into Unicode (and UTF-8).
12584 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12585 is not a reference, nothing is done to the sv. If the encoding is not
12586 an C<Encode::XS> Encoding object, bad things will happen.
12587 (See F<lib/encoding.pm> and L<Encode>).
12589 The PV of the sv is returned.
12594 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12598 PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
12600 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12614 Passing sv_yes is wrong - it needs to be or'ed set of constants
12615 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12616 remove converted chars from source.
12618 Both will default the value - let them.
12620 XPUSHs(&PL_sv_yes);
12623 call_method("decode", G_SCALAR);
12627 s = SvPV_const(uni, len);
12628 if (s != SvPVX_const(sv)) {
12629 SvGROW(sv, len + 1);
12630 Move(s, SvPVX(sv), len + 1, char);
12631 SvCUR_set(sv, len);
12638 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12642 =for apidoc sv_cat_decode
12644 The encoding is assumed to be an Encode object, the PV of the ssv is
12645 assumed to be octets in that encoding and decoding the input starts
12646 from the position which (PV + *offset) pointed to. The dsv will be
12647 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12648 when the string tstr appears in decoding output or the input ends on
12649 the PV of the ssv. The value which the offset points will be modified
12650 to the last input position on the ssv.
12652 Returns TRUE if the terminator was found, else returns FALSE.
12657 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12658 SV *ssv, int *offset, char *tstr, int tlen)
12663 PERL_ARGS_ASSERT_SV_CAT_DECODE;
12665 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12676 offsv = newSViv(*offset);
12678 mXPUSHp(tstr, tlen);
12680 call_method("cat_decode", G_SCALAR);
12682 ret = SvTRUE(TOPs);
12683 *offset = SvIV(offsv);
12689 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12694 /* ---------------------------------------------------------------------
12696 * support functions for report_uninit()
12699 /* the maxiumum size of array or hash where we will scan looking
12700 * for the undefined element that triggered the warning */
12702 #define FUV_MAX_SEARCH_SIZE 1000
12704 /* Look for an entry in the hash whose value has the same SV as val;
12705 * If so, return a mortal copy of the key. */
12708 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
12711 register HE **array;
12714 PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
12716 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
12717 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
12720 array = HvARRAY(hv);
12722 for (i=HvMAX(hv); i>0; i--) {
12723 register HE *entry;
12724 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
12725 if (HeVAL(entry) != val)
12727 if ( HeVAL(entry) == &PL_sv_undef ||
12728 HeVAL(entry) == &PL_sv_placeholder)
12732 if (HeKLEN(entry) == HEf_SVKEY)
12733 return sv_mortalcopy(HeKEY_sv(entry));
12734 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
12740 /* Look for an entry in the array whose value has the same SV as val;
12741 * If so, return the index, otherwise return -1. */
12744 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
12748 PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
12750 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
12751 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
12754 if (val != &PL_sv_undef) {
12755 SV ** const svp = AvARRAY(av);
12758 for (i=AvFILLp(av); i>=0; i--)
12765 /* S_varname(): return the name of a variable, optionally with a subscript.
12766 * If gv is non-zero, use the name of that global, along with gvtype (one
12767 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
12768 * targ. Depending on the value of the subscript_type flag, return:
12771 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
12772 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
12773 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
12774 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
12777 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
12778 const SV *const keyname, I32 aindex, int subscript_type)
12781 SV * const name = sv_newmortal();
12784 buffer[0] = gvtype;
12787 /* as gv_fullname4(), but add literal '^' for $^FOO names */
12789 gv_fullname4(name, gv, buffer, 0);
12791 if ((unsigned int)SvPVX(name)[1] <= 26) {
12793 buffer[1] = SvPVX(name)[1] + 'A' - 1;
12795 /* Swap the 1 unprintable control character for the 2 byte pretty
12796 version - ie substr($name, 1, 1) = $buffer; */
12797 sv_insert(name, 1, 1, buffer, 2);
12801 CV * const cv = find_runcv(NULL);
12805 if (!cv || !CvPADLIST(cv))
12807 av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
12808 sv = *av_fetch(av, targ, FALSE);
12809 sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
12812 if (subscript_type == FUV_SUBSCRIPT_HASH) {
12813 SV * const sv = newSV(0);
12814 *SvPVX(name) = '$';
12815 Perl_sv_catpvf(aTHX_ name, "{%s}",
12816 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
12819 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
12820 *SvPVX(name) = '$';
12821 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
12823 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
12824 /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
12825 Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
12833 =for apidoc find_uninit_var
12835 Find the name of the undefined variable (if any) that caused the operator o
12836 to issue a "Use of uninitialized value" warning.
12837 If match is true, only return a name if it's value matches uninit_sv.
12838 So roughly speaking, if a unary operator (such as OP_COS) generates a
12839 warning, then following the direct child of the op may yield an
12840 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
12841 other hand, with OP_ADD there are two branches to follow, so we only print
12842 the variable name if we get an exact match.
12844 The name is returned as a mortal SV.
12846 Assumes that PL_op is the op that originally triggered the error, and that
12847 PL_comppad/PL_curpad points to the currently executing pad.
12853 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
12859 const OP *o, *o2, *kid;
12861 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
12862 uninit_sv == &PL_sv_placeholder)))
12865 switch (obase->op_type) {
12872 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
12873 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
12876 int subscript_type = FUV_SUBSCRIPT_WITHIN;
12878 if (pad) { /* @lex, %lex */
12879 sv = PAD_SVl(obase->op_targ);
12883 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
12884 /* @global, %global */
12885 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
12888 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
12890 else /* @{expr}, %{expr} */
12891 return find_uninit_var(cUNOPx(obase)->op_first,
12895 /* attempt to find a match within the aggregate */
12897 keysv = find_hash_subscript((const HV*)sv, uninit_sv);
12899 subscript_type = FUV_SUBSCRIPT_HASH;
12902 index = find_array_subscript((const AV *)sv, uninit_sv);
12904 subscript_type = FUV_SUBSCRIPT_ARRAY;
12907 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
12910 return varname(gv, hash ? '%' : '@', obase->op_targ,
12911 keysv, index, subscript_type);
12915 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
12917 return varname(NULL, '$', obase->op_targ,
12918 NULL, 0, FUV_SUBSCRIPT_NONE);
12921 gv = cGVOPx_gv(obase);
12922 if (!gv || (match && GvSV(gv) != uninit_sv))
12924 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
12927 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
12930 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
12931 if (!av || SvRMAGICAL(av))
12933 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12934 if (!svp || *svp != uninit_sv)
12937 return varname(NULL, '$', obase->op_targ,
12938 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12941 gv = cGVOPx_gv(obase);
12946 AV *const av = GvAV(gv);
12947 if (!av || SvRMAGICAL(av))
12949 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12950 if (!svp || *svp != uninit_sv)
12953 return varname(gv, '$', 0,
12954 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12959 o = cUNOPx(obase)->op_first;
12960 if (!o || o->op_type != OP_NULL ||
12961 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
12963 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
12967 if (PL_op == obase)
12968 /* $a[uninit_expr] or $h{uninit_expr} */
12969 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
12972 o = cBINOPx(obase)->op_first;
12973 kid = cBINOPx(obase)->op_last;
12975 /* get the av or hv, and optionally the gv */
12977 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
12978 sv = PAD_SV(o->op_targ);
12980 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
12981 && cUNOPo->op_first->op_type == OP_GV)
12983 gv = cGVOPx_gv(cUNOPo->op_first);
12987 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
12992 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
12993 /* index is constant */
12997 if (obase->op_type == OP_HELEM) {
12998 HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
12999 if (!he || HeVAL(he) != uninit_sv)
13003 SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
13004 if (!svp || *svp != uninit_sv)
13008 if (obase->op_type == OP_HELEM)
13009 return varname(gv, '%', o->op_targ,
13010 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
13012 return varname(gv, '@', o->op_targ, NULL,
13013 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
13016 /* index is an expression;
13017 * attempt to find a match within the aggregate */
13018 if (obase->op_type == OP_HELEM) {
13019 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13021 return varname(gv, '%', o->op_targ,
13022 keysv, 0, FUV_SUBSCRIPT_HASH);
13026 = find_array_subscript((const AV *)sv, uninit_sv);
13028 return varname(gv, '@', o->op_targ,
13029 NULL, index, FUV_SUBSCRIPT_ARRAY);
13034 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
13036 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
13041 /* only examine RHS */
13042 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
13045 o = cUNOPx(obase)->op_first;
13046 if (o->op_type == OP_PUSHMARK)
13049 if (!o->op_sibling) {
13050 /* one-arg version of open is highly magical */
13052 if (o->op_type == OP_GV) { /* open FOO; */
13054 if (match && GvSV(gv) != uninit_sv)
13056 return varname(gv, '$', 0,
13057 NULL, 0, FUV_SUBSCRIPT_NONE);
13059 /* other possibilities not handled are:
13060 * open $x; or open my $x; should return '${*$x}'
13061 * open expr; should return '$'.expr ideally
13067 /* ops where $_ may be an implicit arg */
13071 if ( !(obase->op_flags & OPf_STACKED)) {
13072 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
13073 ? PAD_SVl(obase->op_targ)
13076 sv = sv_newmortal();
13077 sv_setpvs(sv, "$_");
13086 match = 1; /* print etc can return undef on defined args */
13087 /* skip filehandle as it can't produce 'undef' warning */
13088 o = cUNOPx(obase)->op_first;
13089 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
13090 o = o->op_sibling->op_sibling;
13094 case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
13096 case OP_CUSTOM: /* XS or custom code could trigger random warnings */
13098 /* the following ops are capable of returning PL_sv_undef even for
13099 * defined arg(s) */
13118 case OP_GETPEERNAME:
13166 case OP_SMARTMATCH:
13175 /* XXX tmp hack: these two may call an XS sub, and currently
13176 XS subs don't have a SUB entry on the context stack, so CV and
13177 pad determination goes wrong, and BAD things happen. So, just
13178 don't try to determine the value under those circumstances.
13179 Need a better fix at dome point. DAPM 11/2007 */
13185 GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
13186 if (gv && GvSV(gv) == uninit_sv)
13187 return newSVpvs_flags("$.", SVs_TEMP);
13192 /* def-ness of rval pos() is independent of the def-ness of its arg */
13193 if ( !(obase->op_flags & OPf_MOD))
13198 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
13199 return newSVpvs_flags("${$/}", SVs_TEMP);
13204 if (!(obase->op_flags & OPf_KIDS))
13206 o = cUNOPx(obase)->op_first;
13212 /* if all except one arg are constant, or have no side-effects,
13213 * or are optimized away, then it's unambiguous */
13215 for (kid=o; kid; kid = kid->op_sibling) {
13217 const OPCODE type = kid->op_type;
13218 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
13219 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
13220 || (type == OP_PUSHMARK)
13224 if (o2) { /* more than one found */
13231 return find_uninit_var(o2, uninit_sv, match);
13233 /* scan all args */
13235 sv = find_uninit_var(o, uninit_sv, 1);
13247 =for apidoc report_uninit
13249 Print appropriate "Use of uninitialized variable" warning
13255 Perl_report_uninit(pTHX_ const SV *uninit_sv)
13259 SV* varname = NULL;
13261 varname = find_uninit_var(PL_op, uninit_sv,0);
13263 sv_insert(varname, 0, 0, " ", 1);
13265 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13266 varname ? SvPV_nolen_const(varname) : "",
13267 " in ", OP_DESC(PL_op));
13270 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13276 * c-indentation-style: bsd
13277 * c-basic-offset: 4
13278 * indent-tabs-mode: t
13281 * ex: set ts=8 sts=4 sw=4 noet:
projects / p5sagit/p5-mst-13.2.git / blob