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 do_clean_named_io_objs()
128 Attempt to free all objects pointed to by RVs,
129 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
130 try to do the same for all objects indirectly
131 referenced by typeglobs too. Called once from
132 perl_destruct(), prior to calling sv_clean_all()
135 sv_clean_all() / do_clean_all()
136 SvREFCNT_dec(sv) each remaining SV, possibly
137 triggering an sv_free(). It also sets the
138 SVf_BREAK flag on the SV to indicate that the
139 refcnt has been artificially lowered, and thus
140 stopping sv_free() from giving spurious warnings
141 about SVs which unexpectedly have a refcnt
142 of zero. called repeatedly from perl_destruct()
143 until there are no SVs left.
145 =head2 Arena allocator API Summary
147 Private API to rest of sv.c
151 new_XPVNV(), del_XPVGV(),
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 # define MEM_LOG_NEW_SV(sv, file, line, func) \
168 Perl_mem_log_new_sv(sv, file, line, func)
169 # define MEM_LOG_DEL_SV(sv, file, line, func) \
170 Perl_mem_log_del_sv(sv, file, line, func)
172 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
173 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
176 #ifdef DEBUG_LEAKING_SCALARS
177 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
178 # define DEBUG_SV_SERIAL(sv) \
179 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
180 PTR2UV(sv), (long)(sv)->sv_debug_serial))
182 # define FREE_SV_DEBUG_FILE(sv)
183 # define DEBUG_SV_SERIAL(sv) NOOP
187 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
188 # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
189 /* Whilst I'd love to do this, it seems that things like to check on
191 # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
193 # define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
194 PoisonNew(&SvREFCNT(sv), 1, U32)
196 # define SvARENA_CHAIN(sv) SvANY(sv)
197 # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
198 # define POSION_SV_HEAD(sv)
201 /* Mark an SV head as unused, and add to free list.
203 * If SVf_BREAK is set, skip adding it to the free list, as this SV had
204 * its refcount artificially decremented during global destruction, so
205 * there may be dangling pointers to it. The last thing we want in that
206 * case is for it to be reused. */
208 #define plant_SV(p) \
210 const U32 old_flags = SvFLAGS(p); \
211 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
212 DEBUG_SV_SERIAL(p); \
213 FREE_SV_DEBUG_FILE(p); \
215 SvFLAGS(p) = SVTYPEMASK; \
216 if (!(old_flags & SVf_BREAK)) { \
217 SvARENA_CHAIN_SET(p, PL_sv_root); \
223 #define uproot_SV(p) \
226 PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
231 /* make some more SVs by adding another arena */
238 char *chunk; /* must use New here to match call to */
239 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
240 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
245 /* new_SV(): return a new, empty SV head */
247 #ifdef DEBUG_LEAKING_SCALARS
248 /* provide a real function for a debugger to play with */
250 S_new_SV(pTHX_ const char *file, int line, const char *func)
257 sv = S_more_sv(aTHX);
261 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
262 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
268 sv->sv_debug_inpad = 0;
269 sv->sv_debug_parent = NULL;
270 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
272 sv->sv_debug_serial = PL_sv_serial++;
274 MEM_LOG_NEW_SV(sv, file, line, func);
275 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
276 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
280 # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
288 (p) = S_more_sv(aTHX); \
292 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
297 /* del_SV(): return an empty SV head to the free list */
310 S_del_sv(pTHX_ SV *p)
314 PERL_ARGS_ASSERT_DEL_SV;
319 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
320 const SV * const sv = sva + 1;
321 const SV * const svend = &sva[SvREFCNT(sva)];
322 if (p >= sv && p < svend) {
328 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
329 "Attempt to free non-arena SV: 0x%"UVxf
330 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
337 #else /* ! DEBUGGING */
339 #define del_SV(p) plant_SV(p)
341 #endif /* DEBUGGING */
345 =head1 SV Manipulation Functions
347 =for apidoc sv_add_arena
349 Given a chunk of memory, link it to the head of the list of arenas,
350 and split it into a list of free SVs.
356 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
359 SV *const sva = MUTABLE_SV(ptr);
363 PERL_ARGS_ASSERT_SV_ADD_ARENA;
365 /* The first SV in an arena isn't an SV. */
366 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
367 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
368 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
370 PL_sv_arenaroot = sva;
371 PL_sv_root = sva + 1;
373 svend = &sva[SvREFCNT(sva) - 1];
376 SvARENA_CHAIN_SET(sv, (sv + 1));
380 /* Must always set typemask because it's always checked in on cleanup
381 when the arenas are walked looking for objects. */
382 SvFLAGS(sv) = SVTYPEMASK;
385 SvARENA_CHAIN_SET(sv, 0);
389 SvFLAGS(sv) = SVTYPEMASK;
392 /* visit(): call the named function for each non-free SV in the arenas
393 * whose flags field matches the flags/mask args. */
396 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
402 PERL_ARGS_ASSERT_VISIT;
404 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
405 register const SV * const svend = &sva[SvREFCNT(sva)];
407 for (sv = sva + 1; sv < svend; ++sv) {
408 if (SvTYPE(sv) != SVTYPEMASK
409 && (sv->sv_flags & mask) == flags
422 /* called by sv_report_used() for each live SV */
425 do_report_used(pTHX_ SV *const sv)
427 if (SvTYPE(sv) != SVTYPEMASK) {
428 PerlIO_printf(Perl_debug_log, "****\n");
435 =for apidoc sv_report_used
437 Dump the contents of all SVs not yet freed. (Debugging aid).
443 Perl_sv_report_used(pTHX)
446 visit(do_report_used, 0, 0);
452 /* called by sv_clean_objs() for each live SV */
455 do_clean_objs(pTHX_ SV *const ref)
460 SV * const target = SvRV(ref);
461 if (SvOBJECT(target)) {
462 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
463 if (SvWEAKREF(ref)) {
464 sv_del_backref(target, ref);
470 SvREFCNT_dec(target);
475 /* XXX Might want to check arrays, etc. */
479 #ifndef DISABLE_DESTRUCTOR_KLUDGE
481 /* clear any slots in a GV which hold objects - except IO;
482 * called by sv_clean_objs() for each live GV */
485 do_clean_named_objs(pTHX_ SV *const sv)
489 assert(SvTYPE(sv) == SVt_PVGV);
490 assert(isGV_with_GP(sv));
494 /* freeing GP entries may indirectly free the current GV;
495 * hold onto it while we mess with the GP slots */
498 if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
499 DEBUG_D((PerlIO_printf(Perl_debug_log,
500 "Cleaning named glob SV object:\n "), sv_dump(obj)));
504 if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
505 DEBUG_D((PerlIO_printf(Perl_debug_log,
506 "Cleaning named glob AV object:\n "), sv_dump(obj)));
510 if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
511 DEBUG_D((PerlIO_printf(Perl_debug_log,
512 "Cleaning named glob HV object:\n "), sv_dump(obj)));
516 if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
517 DEBUG_D((PerlIO_printf(Perl_debug_log,
518 "Cleaning named glob CV object:\n "), sv_dump(obj)));
522 SvREFCNT_dec(sv); /* undo the inc above */
525 /* clear any IO slots in a GV which hold objects (except stderr, defout);
526 * called by sv_clean_objs() for each live GV */
529 do_clean_named_io_objs(pTHX_ SV *const sv)
533 assert(SvTYPE(sv) == SVt_PVGV);
534 assert(isGV_with_GP(sv));
535 if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
539 if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
540 DEBUG_D((PerlIO_printf(Perl_debug_log,
541 "Cleaning named glob IO object:\n "), sv_dump(obj)));
545 SvREFCNT_dec(sv); /* undo the inc above */
550 =for apidoc sv_clean_objs
552 Attempt to destroy all objects not yet freed
558 Perl_sv_clean_objs(pTHX)
562 PL_in_clean_objs = TRUE;
563 visit(do_clean_objs, SVf_ROK, SVf_ROK);
564 #ifndef DISABLE_DESTRUCTOR_KLUDGE
565 /* Some barnacles may yet remain, clinging to typeglobs.
566 * Run the non-IO destructors first: they may want to output
567 * error messages, close files etc */
568 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
569 visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
570 olddef = PL_defoutgv;
571 PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
572 if (olddef && isGV_with_GP(olddef))
573 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
574 olderr = PL_stderrgv;
575 PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
576 if (olderr && isGV_with_GP(olderr))
577 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
578 SvREFCNT_dec(olddef);
580 PL_in_clean_objs = FALSE;
583 /* called by sv_clean_all() for each live SV */
586 do_clean_all(pTHX_ SV *const sv)
589 if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
590 /* don't clean pid table and strtab */
593 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
594 SvFLAGS(sv) |= SVf_BREAK;
599 =for apidoc sv_clean_all
601 Decrement the refcnt of each remaining SV, possibly triggering a
602 cleanup. This function may have to be called multiple times to free
603 SVs which are in complex self-referential hierarchies.
609 Perl_sv_clean_all(pTHX)
613 PL_in_clean_all = TRUE;
614 cleaned = visit(do_clean_all, 0,0);
619 ARENASETS: a meta-arena implementation which separates arena-info
620 into struct arena_set, which contains an array of struct
621 arena_descs, each holding info for a single arena. By separating
622 the meta-info from the arena, we recover the 1st slot, formerly
623 borrowed for list management. The arena_set is about the size of an
624 arena, avoiding the needless malloc overhead of a naive linked-list.
626 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
627 memory in the last arena-set (1/2 on average). In trade, we get
628 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
629 smaller types). The recovery of the wasted space allows use of
630 small arenas for large, rare body types, by changing array* fields
631 in body_details_by_type[] below.
634 char *arena; /* the raw storage, allocated aligned */
635 size_t size; /* its size ~4k typ */
636 svtype utype; /* bodytype stored in arena */
641 /* Get the maximum number of elements in set[] such that struct arena_set
642 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
643 therefore likely to be 1 aligned memory page. */
645 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
646 - 2 * sizeof(int)) / sizeof (struct arena_desc))
649 struct arena_set* next;
650 unsigned int set_size; /* ie ARENAS_PER_SET */
651 unsigned int curr; /* index of next available arena-desc */
652 struct arena_desc set[ARENAS_PER_SET];
656 =for apidoc sv_free_arenas
658 Deallocate the memory used by all arenas. Note that all the individual SV
659 heads and bodies within the arenas must already have been freed.
664 Perl_sv_free_arenas(pTHX)
671 /* Free arenas here, but be careful about fake ones. (We assume
672 contiguity of the fake ones with the corresponding real ones.) */
674 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
675 svanext = MUTABLE_SV(SvANY(sva));
676 while (svanext && SvFAKE(svanext))
677 svanext = MUTABLE_SV(SvANY(svanext));
684 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
687 struct arena_set *current = aroot;
690 assert(aroot->set[i].arena);
691 Safefree(aroot->set[i].arena);
699 i = PERL_ARENA_ROOTS_SIZE;
701 PL_body_roots[i] = 0;
708 Here are mid-level routines that manage the allocation of bodies out
709 of the various arenas. There are 5 kinds of arenas:
711 1. SV-head arenas, which are discussed and handled above
712 2. regular body arenas
713 3. arenas for reduced-size bodies
716 Arena types 2 & 3 are chained by body-type off an array of
717 arena-root pointers, which is indexed by svtype. Some of the
718 larger/less used body types are malloced singly, since a large
719 unused block of them is wasteful. Also, several svtypes dont have
720 bodies; the data fits into the sv-head itself. The arena-root
721 pointer thus has a few unused root-pointers (which may be hijacked
722 later for arena types 4,5)
724 3 differs from 2 as an optimization; some body types have several
725 unused fields in the front of the structure (which are kept in-place
726 for consistency). These bodies can be allocated in smaller chunks,
727 because the leading fields arent accessed. Pointers to such bodies
728 are decremented to point at the unused 'ghost' memory, knowing that
729 the pointers are used with offsets to the real memory.
732 =head1 SV-Body Allocation
734 Allocation of SV-bodies is similar to SV-heads, differing as follows;
735 the allocation mechanism is used for many body types, so is somewhat
736 more complicated, it uses arena-sets, and has no need for still-live
739 At the outermost level, (new|del)_X*V macros return bodies of the
740 appropriate type. These macros call either (new|del)_body_type or
741 (new|del)_body_allocated macro pairs, depending on specifics of the
742 type. Most body types use the former pair, the latter pair is used to
743 allocate body types with "ghost fields".
745 "ghost fields" are fields that are unused in certain types, and
746 consequently don't need to actually exist. They are declared because
747 they're part of a "base type", which allows use of functions as
748 methods. The simplest examples are AVs and HVs, 2 aggregate types
749 which don't use the fields which support SCALAR semantics.
751 For these types, the arenas are carved up into appropriately sized
752 chunks, we thus avoid wasted memory for those unaccessed members.
753 When bodies are allocated, we adjust the pointer back in memory by the
754 size of the part not allocated, so it's as if we allocated the full
755 structure. (But things will all go boom if you write to the part that
756 is "not there", because you'll be overwriting the last members of the
757 preceding structure in memory.)
759 We calculate the correction using the STRUCT_OFFSET macro on the first
760 member present. If the allocated structure is smaller (no initial NV
761 actually allocated) then the net effect is to subtract the size of the NV
762 from the pointer, to return a new pointer as if an initial NV were actually
763 allocated. (We were using structures named *_allocated for this, but
764 this turned out to be a subtle bug, because a structure without an NV
765 could have a lower alignment constraint, but the compiler is allowed to
766 optimised accesses based on the alignment constraint of the actual pointer
767 to the full structure, for example, using a single 64 bit load instruction
768 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
770 This is the same trick as was used for NV and IV bodies. Ironically it
771 doesn't need to be used for NV bodies any more, because NV is now at
772 the start of the structure. IV bodies don't need it either, because
773 they are no longer allocated.
775 In turn, the new_body_* allocators call S_new_body(), which invokes
776 new_body_inline macro, which takes a lock, and takes a body off the
777 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
778 necessary to refresh an empty list. Then the lock is released, and
779 the body is returned.
781 Perl_more_bodies allocates a new arena, and carves it up into an array of N
782 bodies, which it strings into a linked list. It looks up arena-size
783 and body-size from the body_details table described below, thus
784 supporting the multiple body-types.
786 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
787 the (new|del)_X*V macros are mapped directly to malloc/free.
789 For each sv-type, struct body_details bodies_by_type[] carries
790 parameters which control these aspects of SV handling:
792 Arena_size determines whether arenas are used for this body type, and if
793 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
794 zero, forcing individual mallocs and frees.
796 Body_size determines how big a body is, and therefore how many fit into
797 each arena. Offset carries the body-pointer adjustment needed for
798 "ghost fields", and is used in *_allocated macros.
800 But its main purpose is to parameterize info needed in
801 Perl_sv_upgrade(). The info here dramatically simplifies the function
802 vs the implementation in 5.8.8, making it table-driven. All fields
803 are used for this, except for arena_size.
805 For the sv-types that have no bodies, arenas are not used, so those
806 PL_body_roots[sv_type] are unused, and can be overloaded. In
807 something of a special case, SVt_NULL is borrowed for HE arenas;
808 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
809 bodies_by_type[SVt_NULL] slot is not used, as the table is not
814 struct body_details {
815 U8 body_size; /* Size to allocate */
816 U8 copy; /* Size of structure to copy (may be shorter) */
818 unsigned int type : 4; /* We have space for a sanity check. */
819 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
820 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
821 unsigned int arena : 1; /* Allocated from an arena */
822 size_t arena_size; /* Size of arena to allocate */
830 /* With -DPURFIY we allocate everything directly, and don't use arenas.
831 This seems a rather elegant way to simplify some of the code below. */
832 #define HASARENA FALSE
834 #define HASARENA TRUE
836 #define NOARENA FALSE
838 /* Size the arenas to exactly fit a given number of bodies. A count
839 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
840 simplifying the default. If count > 0, the arena is sized to fit
841 only that many bodies, allowing arenas to be used for large, rare
842 bodies (XPVFM, XPVIO) without undue waste. The arena size is
843 limited by PERL_ARENA_SIZE, so we can safely oversize the
846 #define FIT_ARENA0(body_size) \
847 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
848 #define FIT_ARENAn(count,body_size) \
849 ( count * body_size <= PERL_ARENA_SIZE) \
850 ? count * body_size \
851 : FIT_ARENA0 (body_size)
852 #define FIT_ARENA(count,body_size) \
854 ? FIT_ARENAn (count, body_size) \
855 : FIT_ARENA0 (body_size)
857 /* Calculate the length to copy. Specifically work out the length less any
858 final padding the compiler needed to add. See the comment in sv_upgrade
859 for why copying the padding proved to be a bug. */
861 #define copy_length(type, last_member) \
862 STRUCT_OFFSET(type, last_member) \
863 + sizeof (((type*)SvANY((const SV *)0))->last_member)
865 static const struct body_details bodies_by_type[] = {
866 /* HEs use this offset for their arena. */
867 { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
869 /* The bind placeholder pretends to be an RV for now.
870 Also it's marked as "can't upgrade" to stop anyone using it before it's
872 { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
874 /* IVs are in the head, so the allocation size is 0. */
876 sizeof(IV), /* This is used to copy out the IV body. */
877 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
878 NOARENA /* IVS don't need an arena */, 0
881 /* 8 bytes on most ILP32 with IEEE doubles */
882 { sizeof(NV), sizeof(NV),
883 STRUCT_OFFSET(XPVNV, xnv_u),
884 SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
886 /* 8 bytes on most ILP32 with IEEE doubles */
887 { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
888 copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
889 + STRUCT_OFFSET(XPV, xpv_cur),
890 SVt_PV, FALSE, NONV, HASARENA,
891 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
894 { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
895 copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
896 + STRUCT_OFFSET(XPV, xpv_cur),
897 SVt_PVIV, FALSE, NONV, HASARENA,
898 FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
901 { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
902 copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
903 + STRUCT_OFFSET(XPV, xpv_cur),
904 SVt_PVNV, FALSE, HADNV, HASARENA,
905 FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
908 { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
909 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
915 SVt_REGEXP, FALSE, NONV, HASARENA,
916 FIT_ARENA(0, sizeof(regexp))
920 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
921 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
924 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
925 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
928 copy_length(XPVAV, xav_alloc),
930 SVt_PVAV, TRUE, NONV, HASARENA,
931 FIT_ARENA(0, sizeof(XPVAV)) },
934 copy_length(XPVHV, xhv_max),
936 SVt_PVHV, TRUE, NONV, HASARENA,
937 FIT_ARENA(0, sizeof(XPVHV)) },
943 SVt_PVCV, TRUE, NONV, HASARENA,
944 FIT_ARENA(0, sizeof(XPVCV)) },
949 SVt_PVFM, TRUE, NONV, NOARENA,
950 FIT_ARENA(20, sizeof(XPVFM)) },
952 /* XPVIO is 84 bytes, fits 48x */
956 SVt_PVIO, TRUE, NONV, HASARENA,
957 FIT_ARENA(24, sizeof(XPVIO)) },
960 #define new_body_allocated(sv_type) \
961 (void *)((char *)S_new_body(aTHX_ sv_type) \
962 - bodies_by_type[sv_type].offset)
964 /* return a thing to the free list */
966 #define del_body(thing, root) \
968 void ** const thing_copy = (void **)thing; \
969 *thing_copy = *root; \
970 *root = (void*)thing_copy; \
975 #define new_XNV() safemalloc(sizeof(XPVNV))
976 #define new_XPVNV() safemalloc(sizeof(XPVNV))
977 #define new_XPVMG() safemalloc(sizeof(XPVMG))
979 #define del_XPVGV(p) safefree(p)
983 #define new_XNV() new_body_allocated(SVt_NV)
984 #define new_XPVNV() new_body_allocated(SVt_PVNV)
985 #define new_XPVMG() new_body_allocated(SVt_PVMG)
987 #define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \
988 &PL_body_roots[SVt_PVGV])
992 /* no arena for you! */
994 #define new_NOARENA(details) \
995 safemalloc((details)->body_size + (details)->offset)
996 #define new_NOARENAZ(details) \
997 safecalloc((details)->body_size + (details)->offset, 1)
1000 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1001 const size_t arena_size)
1004 void ** const root = &PL_body_roots[sv_type];
1005 struct arena_desc *adesc;
1006 struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1010 const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1011 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1012 static bool done_sanity_check;
1014 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1015 * variables like done_sanity_check. */
1016 if (!done_sanity_check) {
1017 unsigned int i = SVt_LAST;
1019 done_sanity_check = TRUE;
1022 assert (bodies_by_type[i].type == i);
1028 /* may need new arena-set to hold new arena */
1029 if (!aroot || aroot->curr >= aroot->set_size) {
1030 struct arena_set *newroot;
1031 Newxz(newroot, 1, struct arena_set);
1032 newroot->set_size = ARENAS_PER_SET;
1033 newroot->next = aroot;
1035 PL_body_arenas = (void *) newroot;
1036 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1039 /* ok, now have arena-set with at least 1 empty/available arena-desc */
1040 curr = aroot->curr++;
1041 adesc = &(aroot->set[curr]);
1042 assert(!adesc->arena);
1044 Newx(adesc->arena, good_arena_size, char);
1045 adesc->size = good_arena_size;
1046 adesc->utype = sv_type;
1047 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
1048 curr, (void*)adesc->arena, (UV)good_arena_size));
1050 start = (char *) adesc->arena;
1052 /* Get the address of the byte after the end of the last body we can fit.
1053 Remember, this is integer division: */
1054 end = start + good_arena_size / body_size * body_size;
1056 /* computed count doesnt reflect the 1st slot reservation */
1057 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1058 DEBUG_m(PerlIO_printf(Perl_debug_log,
1059 "arena %p end %p arena-size %d (from %d) type %d "
1061 (void*)start, (void*)end, (int)good_arena_size,
1062 (int)arena_size, sv_type, (int)body_size,
1063 (int)good_arena_size / (int)body_size));
1065 DEBUG_m(PerlIO_printf(Perl_debug_log,
1066 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1067 (void*)start, (void*)end,
1068 (int)arena_size, sv_type, (int)body_size,
1069 (int)good_arena_size / (int)body_size));
1071 *root = (void *)start;
1074 /* Where the next body would start: */
1075 char * const next = start + body_size;
1078 /* This is the last body: */
1079 assert(next == end);
1081 *(void **)start = 0;
1085 *(void**) start = (void *)next;
1090 /* grab a new thing from the free list, allocating more if necessary.
1091 The inline version is used for speed in hot routines, and the
1092 function using it serves the rest (unless PURIFY).
1094 #define new_body_inline(xpv, sv_type) \
1096 void ** const r3wt = &PL_body_roots[sv_type]; \
1097 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1098 ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1099 bodies_by_type[sv_type].body_size,\
1100 bodies_by_type[sv_type].arena_size)); \
1101 *(r3wt) = *(void**)(xpv); \
1107 S_new_body(pTHX_ const svtype sv_type)
1111 new_body_inline(xpv, sv_type);
1117 static const struct body_details fake_rv =
1118 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1121 =for apidoc sv_upgrade
1123 Upgrade an SV to a more complex form. Generally adds a new body type to the
1124 SV, then copies across as much information as possible from the old body.
1125 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1131 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1136 const svtype old_type = SvTYPE(sv);
1137 const struct body_details *new_type_details;
1138 const struct body_details *old_type_details
1139 = bodies_by_type + old_type;
1140 SV *referant = NULL;
1142 PERL_ARGS_ASSERT_SV_UPGRADE;
1144 if (old_type == new_type)
1147 /* This clause was purposefully added ahead of the early return above to
1148 the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1149 inference by Nick I-S that it would fix other troublesome cases. See
1150 changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1152 Given that shared hash key scalars are no longer PVIV, but PV, there is
1153 no longer need to unshare so as to free up the IVX slot for its proper
1154 purpose. So it's safe to move the early return earlier. */
1156 if (new_type != SVt_PV && SvIsCOW(sv)) {
1157 sv_force_normal_flags(sv, 0);
1160 old_body = SvANY(sv);
1162 /* Copying structures onto other structures that have been neatly zeroed
1163 has a subtle gotcha. Consider XPVMG
1165 +------+------+------+------+------+-------+-------+
1166 | NV | CUR | LEN | IV | MAGIC | STASH |
1167 +------+------+------+------+------+-------+-------+
1168 0 4 8 12 16 20 24 28
1170 where NVs are aligned to 8 bytes, so that sizeof that structure is
1171 actually 32 bytes long, with 4 bytes of padding at the end:
1173 +------+------+------+------+------+-------+-------+------+
1174 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1175 +------+------+------+------+------+-------+-------+------+
1176 0 4 8 12 16 20 24 28 32
1178 so what happens if you allocate memory for this structure:
1180 +------+------+------+------+------+-------+-------+------+------+...
1181 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1182 +------+------+------+------+------+-------+-------+------+------+...
1183 0 4 8 12 16 20 24 28 32 36
1185 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1186 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1187 started out as zero once, but it's quite possible that it isn't. So now,
1188 rather than a nicely zeroed GP, you have it pointing somewhere random.
1191 (In fact, GP ends up pointing at a previous GP structure, because the
1192 principle cause of the padding in XPVMG getting garbage is a copy of
1193 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1194 this happens to be moot because XPVGV has been re-ordered, with GP
1195 no longer after STASH)
1197 So we are careful and work out the size of used parts of all the
1205 referant = SvRV(sv);
1206 old_type_details = &fake_rv;
1207 if (new_type == SVt_NV)
1208 new_type = SVt_PVNV;
1210 if (new_type < SVt_PVIV) {
1211 new_type = (new_type == SVt_NV)
1212 ? SVt_PVNV : SVt_PVIV;
1217 if (new_type < SVt_PVNV) {
1218 new_type = SVt_PVNV;
1222 assert(new_type > SVt_PV);
1223 assert(SVt_IV < SVt_PV);
1224 assert(SVt_NV < SVt_PV);
1231 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1232 there's no way that it can be safely upgraded, because perl.c
1233 expects to Safefree(SvANY(PL_mess_sv)) */
1234 assert(sv != PL_mess_sv);
1235 /* This flag bit is used to mean other things in other scalar types.
1236 Given that it only has meaning inside the pad, it shouldn't be set
1237 on anything that can get upgraded. */
1238 assert(!SvPAD_TYPED(sv));
1241 if (old_type_details->cant_upgrade)
1242 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1243 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1246 if (old_type > new_type)
1247 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1248 (int)old_type, (int)new_type);
1250 new_type_details = bodies_by_type + new_type;
1252 SvFLAGS(sv) &= ~SVTYPEMASK;
1253 SvFLAGS(sv) |= new_type;
1255 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1256 the return statements above will have triggered. */
1257 assert (new_type != SVt_NULL);
1260 assert(old_type == SVt_NULL);
1261 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1265 assert(old_type == SVt_NULL);
1266 SvANY(sv) = new_XNV();
1271 assert(new_type_details->body_size);
1274 assert(new_type_details->arena);
1275 assert(new_type_details->arena_size);
1276 /* This points to the start of the allocated area. */
1277 new_body_inline(new_body, new_type);
1278 Zero(new_body, new_type_details->body_size, char);
1279 new_body = ((char *)new_body) - new_type_details->offset;
1281 /* We always allocated the full length item with PURIFY. To do this
1282 we fake things so that arena is false for all 16 types.. */
1283 new_body = new_NOARENAZ(new_type_details);
1285 SvANY(sv) = new_body;
1286 if (new_type == SVt_PVAV) {
1290 if (old_type_details->body_size) {
1293 /* It will have been zeroed when the new body was allocated.
1294 Lets not write to it, in case it confuses a write-back
1300 #ifndef NODEFAULT_SHAREKEYS
1301 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1303 HvMAX(sv) = 7; /* (start with 8 buckets) */
1306 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1307 The target created by newSVrv also is, and it can have magic.
1308 However, it never has SvPVX set.
1310 if (old_type == SVt_IV) {
1312 } else if (old_type >= SVt_PV) {
1313 assert(SvPVX_const(sv) == 0);
1316 if (old_type >= SVt_PVMG) {
1317 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1318 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1320 sv->sv_u.svu_array = NULL; /* or svu_hash */
1326 /* This ensures that SvTHINKFIRST(sv) is true, and hence that
1327 sv_force_normal_flags(sv) is called. */
1330 /* XXX Is this still needed? Was it ever needed? Surely as there is
1331 no route from NV to PVIV, NOK can never be true */
1332 assert(!SvNOKp(sv));
1343 assert(new_type_details->body_size);
1344 /* We always allocated the full length item with PURIFY. To do this
1345 we fake things so that arena is false for all 16 types.. */
1346 if(new_type_details->arena) {
1347 /* This points to the start of the allocated area. */
1348 new_body_inline(new_body, new_type);
1349 Zero(new_body, new_type_details->body_size, char);
1350 new_body = ((char *)new_body) - new_type_details->offset;
1352 new_body = new_NOARENAZ(new_type_details);
1354 SvANY(sv) = new_body;
1356 if (old_type_details->copy) {
1357 /* There is now the potential for an upgrade from something without
1358 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1359 int offset = old_type_details->offset;
1360 int length = old_type_details->copy;
1362 if (new_type_details->offset > old_type_details->offset) {
1363 const int difference
1364 = new_type_details->offset - old_type_details->offset;
1365 offset += difference;
1366 length -= difference;
1368 assert (length >= 0);
1370 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1374 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1375 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1376 * correct 0.0 for us. Otherwise, if the old body didn't have an
1377 * NV slot, but the new one does, then we need to initialise the
1378 * freshly created NV slot with whatever the correct bit pattern is
1380 if (old_type_details->zero_nv && !new_type_details->zero_nv
1381 && !isGV_with_GP(sv))
1385 if (new_type == SVt_PVIO) {
1386 IO * const io = MUTABLE_IO(sv);
1387 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1390 /* Clear the stashcache because a new IO could overrule a package
1392 hv_clear(PL_stashcache);
1394 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1395 IoPAGE_LEN(sv) = 60;
1397 if (old_type < SVt_PV) {
1398 /* referant will be NULL unless the old type was SVt_IV emulating
1400 sv->sv_u.svu_rv = referant;
1404 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1405 (unsigned long)new_type);
1408 if (old_type > SVt_IV) {
1412 /* Note that there is an assumption that all bodies of types that
1413 can be upgraded came from arenas. Only the more complex non-
1414 upgradable types are allowed to be directly malloc()ed. */
1415 assert(old_type_details->arena);
1416 del_body((void*)((char*)old_body + old_type_details->offset),
1417 &PL_body_roots[old_type]);
1423 =for apidoc sv_backoff
1425 Remove any string offset. You should normally use the C<SvOOK_off> macro
1432 Perl_sv_backoff(pTHX_ register SV *const sv)
1435 const char * const s = SvPVX_const(sv);
1437 PERL_ARGS_ASSERT_SV_BACKOFF;
1438 PERL_UNUSED_CONTEXT;
1441 assert(SvTYPE(sv) != SVt_PVHV);
1442 assert(SvTYPE(sv) != SVt_PVAV);
1444 SvOOK_offset(sv, delta);
1446 SvLEN_set(sv, SvLEN(sv) + delta);
1447 SvPV_set(sv, SvPVX(sv) - delta);
1448 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1449 SvFLAGS(sv) &= ~SVf_OOK;
1456 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1457 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1458 Use the C<SvGROW> wrapper instead.
1464 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1468 PERL_ARGS_ASSERT_SV_GROW;
1470 if (PL_madskills && newlen >= 0x100000) {
1471 PerlIO_printf(Perl_debug_log,
1472 "Allocation too large: %"UVxf"\n", (UV)newlen);
1474 #ifdef HAS_64K_LIMIT
1475 if (newlen >= 0x10000) {
1476 PerlIO_printf(Perl_debug_log,
1477 "Allocation too large: %"UVxf"\n", (UV)newlen);
1480 #endif /* HAS_64K_LIMIT */
1483 if (SvTYPE(sv) < SVt_PV) {
1484 sv_upgrade(sv, SVt_PV);
1485 s = SvPVX_mutable(sv);
1487 else if (SvOOK(sv)) { /* pv is offset? */
1489 s = SvPVX_mutable(sv);
1490 if (newlen > SvLEN(sv))
1491 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1492 #ifdef HAS_64K_LIMIT
1493 if (newlen >= 0x10000)
1498 s = SvPVX_mutable(sv);
1500 if (newlen > SvLEN(sv)) { /* need more room? */
1501 STRLEN minlen = SvCUR(sv);
1502 minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1503 if (newlen < minlen)
1505 #ifndef Perl_safesysmalloc_size
1506 newlen = PERL_STRLEN_ROUNDUP(newlen);
1508 if (SvLEN(sv) && s) {
1509 s = (char*)saferealloc(s, newlen);
1512 s = (char*)safemalloc(newlen);
1513 if (SvPVX_const(sv) && SvCUR(sv)) {
1514 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1518 #ifdef Perl_safesysmalloc_size
1519 /* Do this here, do it once, do it right, and then we will never get
1520 called back into sv_grow() unless there really is some growing
1522 SvLEN_set(sv, Perl_safesysmalloc_size(s));
1524 SvLEN_set(sv, newlen);
1531 =for apidoc sv_setiv
1533 Copies an integer into the given SV, upgrading first if necessary.
1534 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1540 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1544 PERL_ARGS_ASSERT_SV_SETIV;
1546 SV_CHECK_THINKFIRST_COW_DROP(sv);
1547 switch (SvTYPE(sv)) {
1550 sv_upgrade(sv, SVt_IV);
1553 sv_upgrade(sv, SVt_PVIV);
1557 if (!isGV_with_GP(sv))
1564 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1568 (void)SvIOK_only(sv); /* validate number */
1574 =for apidoc sv_setiv_mg
1576 Like C<sv_setiv>, but also handles 'set' magic.
1582 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1584 PERL_ARGS_ASSERT_SV_SETIV_MG;
1591 =for apidoc sv_setuv
1593 Copies an unsigned integer into the given SV, upgrading first if necessary.
1594 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1600 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1602 PERL_ARGS_ASSERT_SV_SETUV;
1604 /* With these two if statements:
1605 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1608 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1610 If you wish to remove them, please benchmark to see what the effect is
1612 if (u <= (UV)IV_MAX) {
1613 sv_setiv(sv, (IV)u);
1622 =for apidoc sv_setuv_mg
1624 Like C<sv_setuv>, but also handles 'set' magic.
1630 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1632 PERL_ARGS_ASSERT_SV_SETUV_MG;
1639 =for apidoc sv_setnv
1641 Copies a double into the given SV, upgrading first if necessary.
1642 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1648 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1652 PERL_ARGS_ASSERT_SV_SETNV;
1654 SV_CHECK_THINKFIRST_COW_DROP(sv);
1655 switch (SvTYPE(sv)) {
1658 sv_upgrade(sv, SVt_NV);
1662 sv_upgrade(sv, SVt_PVNV);
1666 if (!isGV_with_GP(sv))
1673 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1678 (void)SvNOK_only(sv); /* validate number */
1683 =for apidoc sv_setnv_mg
1685 Like C<sv_setnv>, but also handles 'set' magic.
1691 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1693 PERL_ARGS_ASSERT_SV_SETNV_MG;
1699 /* Print an "isn't numeric" warning, using a cleaned-up,
1700 * printable version of the offending string
1704 S_not_a_number(pTHX_ SV *const sv)
1711 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1714 dsv = newSVpvs_flags("", SVs_TEMP);
1715 pv = sv_uni_display(dsv, sv, 10, 0);
1718 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1719 /* each *s can expand to 4 chars + "...\0",
1720 i.e. need room for 8 chars */
1722 const char *s = SvPVX_const(sv);
1723 const char * const end = s + SvCUR(sv);
1724 for ( ; s < end && d < limit; s++ ) {
1726 if (ch & 128 && !isPRINT_LC(ch)) {
1735 else if (ch == '\r') {
1739 else if (ch == '\f') {
1743 else if (ch == '\\') {
1747 else if (ch == '\0') {
1751 else if (isPRINT_LC(ch))
1768 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1769 "Argument \"%s\" isn't numeric in %s", pv,
1772 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1773 "Argument \"%s\" isn't numeric", pv);
1777 =for apidoc looks_like_number
1779 Test if the content of an SV looks like a number (or is a number).
1780 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1781 non-numeric warning), even if your atof() doesn't grok them.
1787 Perl_looks_like_number(pTHX_ SV *const sv)
1789 register const char *sbegin;
1792 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1795 sbegin = SvPVX_const(sv);
1798 else if (SvPOKp(sv))
1799 sbegin = SvPV_const(sv, len);
1801 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1802 return grok_number(sbegin, len, NULL);
1806 S_glob_2number(pTHX_ GV * const gv)
1808 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1809 SV *const buffer = sv_newmortal();
1811 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1813 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1816 gv_efullname3(buffer, gv, "*");
1817 SvFLAGS(gv) |= wasfake;
1819 /* We know that all GVs stringify to something that is not-a-number,
1820 so no need to test that. */
1821 if (ckWARN(WARN_NUMERIC))
1822 not_a_number(buffer);
1823 /* We just want something true to return, so that S_sv_2iuv_common
1824 can tail call us and return true. */
1828 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1829 until proven guilty, assume that things are not that bad... */
1834 As 64 bit platforms often have an NV that doesn't preserve all bits of
1835 an IV (an assumption perl has been based on to date) it becomes necessary
1836 to remove the assumption that the NV always carries enough precision to
1837 recreate the IV whenever needed, and that the NV is the canonical form.
1838 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1839 precision as a side effect of conversion (which would lead to insanity
1840 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1841 1) to distinguish between IV/UV/NV slots that have cached a valid
1842 conversion where precision was lost and IV/UV/NV slots that have a
1843 valid conversion which has lost no precision
1844 2) to ensure that if a numeric conversion to one form is requested that
1845 would lose precision, the precise conversion (or differently
1846 imprecise conversion) is also performed and cached, to prevent
1847 requests for different numeric formats on the same SV causing
1848 lossy conversion chains. (lossless conversion chains are perfectly
1853 SvIOKp is true if the IV slot contains a valid value
1854 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1855 SvNOKp is true if the NV slot contains a valid value
1856 SvNOK is true only if the NV value is accurate
1859 while converting from PV to NV, check to see if converting that NV to an
1860 IV(or UV) would lose accuracy over a direct conversion from PV to
1861 IV(or UV). If it would, cache both conversions, return NV, but mark
1862 SV as IOK NOKp (ie not NOK).
1864 While converting from PV to IV, check to see if converting that IV to an
1865 NV would lose accuracy over a direct conversion from PV to NV. If it
1866 would, cache both conversions, flag similarly.
1868 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1869 correctly because if IV & NV were set NV *always* overruled.
1870 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1871 changes - now IV and NV together means that the two are interchangeable:
1872 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1874 The benefit of this is that operations such as pp_add know that if
1875 SvIOK is true for both left and right operands, then integer addition
1876 can be used instead of floating point (for cases where the result won't
1877 overflow). Before, floating point was always used, which could lead to
1878 loss of precision compared with integer addition.
1880 * making IV and NV equal status should make maths accurate on 64 bit
1882 * may speed up maths somewhat if pp_add and friends start to use
1883 integers when possible instead of fp. (Hopefully the overhead in
1884 looking for SvIOK and checking for overflow will not outweigh the
1885 fp to integer speedup)
1886 * will slow down integer operations (callers of SvIV) on "inaccurate"
1887 values, as the change from SvIOK to SvIOKp will cause a call into
1888 sv_2iv each time rather than a macro access direct to the IV slot
1889 * should speed up number->string conversion on integers as IV is
1890 favoured when IV and NV are equally accurate
1892 ####################################################################
1893 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1894 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1895 On the other hand, SvUOK is true iff UV.
1896 ####################################################################
1898 Your mileage will vary depending your CPU's relative fp to integer
1902 #ifndef NV_PRESERVES_UV
1903 # define IS_NUMBER_UNDERFLOW_IV 1
1904 # define IS_NUMBER_UNDERFLOW_UV 2
1905 # define IS_NUMBER_IV_AND_UV 2
1906 # define IS_NUMBER_OVERFLOW_IV 4
1907 # define IS_NUMBER_OVERFLOW_UV 5
1909 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1911 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1913 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1921 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1923 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));
1924 if (SvNVX(sv) < (NV)IV_MIN) {
1925 (void)SvIOKp_on(sv);
1927 SvIV_set(sv, IV_MIN);
1928 return IS_NUMBER_UNDERFLOW_IV;
1930 if (SvNVX(sv) > (NV)UV_MAX) {
1931 (void)SvIOKp_on(sv);
1934 SvUV_set(sv, UV_MAX);
1935 return IS_NUMBER_OVERFLOW_UV;
1937 (void)SvIOKp_on(sv);
1939 /* Can't use strtol etc to convert this string. (See truth table in
1941 if (SvNVX(sv) <= (UV)IV_MAX) {
1942 SvIV_set(sv, I_V(SvNVX(sv)));
1943 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1944 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1946 /* Integer is imprecise. NOK, IOKp */
1948 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1951 SvUV_set(sv, U_V(SvNVX(sv)));
1952 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1953 if (SvUVX(sv) == UV_MAX) {
1954 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1955 possibly be preserved by NV. Hence, it must be overflow.
1957 return IS_NUMBER_OVERFLOW_UV;
1959 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1961 /* Integer is imprecise. NOK, IOKp */
1963 return IS_NUMBER_OVERFLOW_IV;
1965 #endif /* !NV_PRESERVES_UV*/
1968 S_sv_2iuv_common(pTHX_ SV *const sv)
1972 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
1975 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1976 * without also getting a cached IV/UV from it at the same time
1977 * (ie PV->NV conversion should detect loss of accuracy and cache
1978 * IV or UV at same time to avoid this. */
1979 /* IV-over-UV optimisation - choose to cache IV if possible */
1981 if (SvTYPE(sv) == SVt_NV)
1982 sv_upgrade(sv, SVt_PVNV);
1984 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1985 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1986 certainly cast into the IV range at IV_MAX, whereas the correct
1987 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1989 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1990 if (Perl_isnan(SvNVX(sv))) {
1996 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1997 SvIV_set(sv, I_V(SvNVX(sv)));
1998 if (SvNVX(sv) == (NV) SvIVX(sv)
1999 #ifndef NV_PRESERVES_UV
2000 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2001 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2002 /* Don't flag it as "accurately an integer" if the number
2003 came from a (by definition imprecise) NV operation, and
2004 we're outside the range of NV integer precision */
2008 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2010 /* scalar has trailing garbage, eg "42a" */
2012 DEBUG_c(PerlIO_printf(Perl_debug_log,
2013 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2019 /* IV not precise. No need to convert from PV, as NV
2020 conversion would already have cached IV if it detected
2021 that PV->IV would be better than PV->NV->IV
2022 flags already correct - don't set public IOK. */
2023 DEBUG_c(PerlIO_printf(Perl_debug_log,
2024 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2029 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2030 but the cast (NV)IV_MIN rounds to a the value less (more
2031 negative) than IV_MIN which happens to be equal to SvNVX ??
2032 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2033 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2034 (NV)UVX == NVX are both true, but the values differ. :-(
2035 Hopefully for 2s complement IV_MIN is something like
2036 0x8000000000000000 which will be exact. NWC */
2039 SvUV_set(sv, U_V(SvNVX(sv)));
2041 (SvNVX(sv) == (NV) SvUVX(sv))
2042 #ifndef NV_PRESERVES_UV
2043 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2044 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2045 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2046 /* Don't flag it as "accurately an integer" if the number
2047 came from a (by definition imprecise) NV operation, and
2048 we're outside the range of NV integer precision */
2054 DEBUG_c(PerlIO_printf(Perl_debug_log,
2055 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2061 else if (SvPOKp(sv) && SvLEN(sv)) {
2063 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2064 /* We want to avoid a possible problem when we cache an IV/ a UV which
2065 may be later translated to an NV, and the resulting NV is not
2066 the same as the direct translation of the initial string
2067 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2068 be careful to ensure that the value with the .456 is around if the
2069 NV value is requested in the future).
2071 This means that if we cache such an IV/a UV, we need to cache the
2072 NV as well. Moreover, we trade speed for space, and do not
2073 cache the NV if we are sure it's not needed.
2076 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2077 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2078 == IS_NUMBER_IN_UV) {
2079 /* It's definitely an integer, only upgrade to PVIV */
2080 if (SvTYPE(sv) < SVt_PVIV)
2081 sv_upgrade(sv, SVt_PVIV);
2083 } else if (SvTYPE(sv) < SVt_PVNV)
2084 sv_upgrade(sv, SVt_PVNV);
2086 /* If NVs preserve UVs then we only use the UV value if we know that
2087 we aren't going to call atof() below. If NVs don't preserve UVs
2088 then the value returned may have more precision than atof() will
2089 return, even though value isn't perfectly accurate. */
2090 if ((numtype & (IS_NUMBER_IN_UV
2091 #ifdef NV_PRESERVES_UV
2094 )) == IS_NUMBER_IN_UV) {
2095 /* This won't turn off the public IOK flag if it was set above */
2096 (void)SvIOKp_on(sv);
2098 if (!(numtype & IS_NUMBER_NEG)) {
2100 if (value <= (UV)IV_MAX) {
2101 SvIV_set(sv, (IV)value);
2103 /* it didn't overflow, and it was positive. */
2104 SvUV_set(sv, value);
2108 /* 2s complement assumption */
2109 if (value <= (UV)IV_MIN) {
2110 SvIV_set(sv, -(IV)value);
2112 /* Too negative for an IV. This is a double upgrade, but
2113 I'm assuming it will be rare. */
2114 if (SvTYPE(sv) < SVt_PVNV)
2115 sv_upgrade(sv, SVt_PVNV);
2119 SvNV_set(sv, -(NV)value);
2120 SvIV_set(sv, IV_MIN);
2124 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2125 will be in the previous block to set the IV slot, and the next
2126 block to set the NV slot. So no else here. */
2128 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2129 != IS_NUMBER_IN_UV) {
2130 /* It wasn't an (integer that doesn't overflow the UV). */
2131 SvNV_set(sv, Atof(SvPVX_const(sv)));
2133 if (! numtype && ckWARN(WARN_NUMERIC))
2136 #if defined(USE_LONG_DOUBLE)
2137 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2138 PTR2UV(sv), SvNVX(sv)));
2140 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2141 PTR2UV(sv), SvNVX(sv)));
2144 #ifdef NV_PRESERVES_UV
2145 (void)SvIOKp_on(sv);
2147 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2148 SvIV_set(sv, I_V(SvNVX(sv)));
2149 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2152 NOOP; /* Integer is imprecise. NOK, IOKp */
2154 /* UV will not work better than IV */
2156 if (SvNVX(sv) > (NV)UV_MAX) {
2158 /* Integer is inaccurate. NOK, IOKp, is UV */
2159 SvUV_set(sv, UV_MAX);
2161 SvUV_set(sv, U_V(SvNVX(sv)));
2162 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2163 NV preservse UV so can do correct comparison. */
2164 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2167 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
2172 #else /* NV_PRESERVES_UV */
2173 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2174 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2175 /* The IV/UV slot will have been set from value returned by
2176 grok_number above. The NV slot has just been set using
2179 assert (SvIOKp(sv));
2181 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2182 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2183 /* Small enough to preserve all bits. */
2184 (void)SvIOKp_on(sv);
2186 SvIV_set(sv, I_V(SvNVX(sv)));
2187 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2189 /* Assumption: first non-preserved integer is < IV_MAX,
2190 this NV is in the preserved range, therefore: */
2191 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2193 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);
2197 0 0 already failed to read UV.
2198 0 1 already failed to read UV.
2199 1 0 you won't get here in this case. IV/UV
2200 slot set, public IOK, Atof() unneeded.
2201 1 1 already read UV.
2202 so there's no point in sv_2iuv_non_preserve() attempting
2203 to use atol, strtol, strtoul etc. */
2205 sv_2iuv_non_preserve (sv, numtype);
2207 sv_2iuv_non_preserve (sv);
2211 #endif /* NV_PRESERVES_UV */
2212 /* It might be more code efficient to go through the entire logic above
2213 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2214 gets complex and potentially buggy, so more programmer efficient
2215 to do it this way, by turning off the public flags: */
2217 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2221 if (isGV_with_GP(sv))
2222 return glob_2number(MUTABLE_GV(sv));
2224 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2225 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2228 if (SvTYPE(sv) < SVt_IV)
2229 /* Typically the caller expects that sv_any is not NULL now. */
2230 sv_upgrade(sv, SVt_IV);
2231 /* Return 0 from the caller. */
2238 =for apidoc sv_2iv_flags
2240 Return the integer value of an SV, doing any necessary string
2241 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2242 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2248 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2253 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2254 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2255 cache IVs just in case. In practice it seems that they never
2256 actually anywhere accessible by user Perl code, let alone get used
2257 in anything other than a string context. */
2258 if (flags & SV_GMAGIC)
2263 return I_V(SvNVX(sv));
2265 if (SvPOKp(sv) && SvLEN(sv)) {
2268 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2270 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2271 == IS_NUMBER_IN_UV) {
2272 /* It's definitely an integer */
2273 if (numtype & IS_NUMBER_NEG) {
2274 if (value < (UV)IV_MIN)
2277 if (value < (UV)IV_MAX)
2282 if (ckWARN(WARN_NUMERIC))
2285 return I_V(Atof(SvPVX_const(sv)));
2290 assert(SvTYPE(sv) >= SVt_PVMG);
2291 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2292 } else if (SvTHINKFIRST(sv)) {
2297 if (flags & SV_SKIP_OVERLOAD)
2299 tmpstr=AMG_CALLun(sv,numer);
2300 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2301 return SvIV(tmpstr);
2304 return PTR2IV(SvRV(sv));
2307 sv_force_normal_flags(sv, 0);
2309 if (SvREADONLY(sv) && !SvOK(sv)) {
2310 if (ckWARN(WARN_UNINITIALIZED))
2316 if (S_sv_2iuv_common(aTHX_ sv))
2319 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2320 PTR2UV(sv),SvIVX(sv)));
2321 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2325 =for apidoc sv_2uv_flags
2327 Return the unsigned integer value of an SV, doing any necessary string
2328 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2329 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2335 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2340 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2341 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2342 cache IVs just in case. */
2343 if (flags & SV_GMAGIC)
2348 return U_V(SvNVX(sv));
2349 if (SvPOKp(sv) && SvLEN(sv)) {
2352 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2354 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2355 == IS_NUMBER_IN_UV) {
2356 /* It's definitely an integer */
2357 if (!(numtype & IS_NUMBER_NEG))
2361 if (ckWARN(WARN_NUMERIC))
2364 return U_V(Atof(SvPVX_const(sv)));
2369 assert(SvTYPE(sv) >= SVt_PVMG);
2370 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2371 } else if (SvTHINKFIRST(sv)) {
2376 if (flags & SV_SKIP_OVERLOAD)
2378 tmpstr = AMG_CALLun(sv,numer);
2379 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2380 return SvUV(tmpstr);
2383 return PTR2UV(SvRV(sv));
2386 sv_force_normal_flags(sv, 0);
2388 if (SvREADONLY(sv) && !SvOK(sv)) {
2389 if (ckWARN(WARN_UNINITIALIZED))
2395 if (S_sv_2iuv_common(aTHX_ sv))
2399 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2400 PTR2UV(sv),SvUVX(sv)));
2401 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2405 =for apidoc sv_2nv_flags
2407 Return the num value of an SV, doing any necessary string or integer
2408 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2409 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2415 Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
2420 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2421 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2422 cache IVs just in case. */
2423 if (flags & SV_GMAGIC)
2427 if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2428 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2429 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2431 return Atof(SvPVX_const(sv));
2435 return (NV)SvUVX(sv);
2437 return (NV)SvIVX(sv);
2442 assert(SvTYPE(sv) >= SVt_PVMG);
2443 /* This falls through to the report_uninit near the end of the
2445 } else if (SvTHINKFIRST(sv)) {
2450 if (flags & SV_SKIP_OVERLOAD)
2452 tmpstr = AMG_CALLun(sv,numer);
2453 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2454 return SvNV(tmpstr);
2457 return PTR2NV(SvRV(sv));
2460 sv_force_normal_flags(sv, 0);
2462 if (SvREADONLY(sv) && !SvOK(sv)) {
2463 if (ckWARN(WARN_UNINITIALIZED))
2468 if (SvTYPE(sv) < SVt_NV) {
2469 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2470 sv_upgrade(sv, SVt_NV);
2471 #ifdef USE_LONG_DOUBLE
2473 STORE_NUMERIC_LOCAL_SET_STANDARD();
2474 PerlIO_printf(Perl_debug_log,
2475 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2476 PTR2UV(sv), SvNVX(sv));
2477 RESTORE_NUMERIC_LOCAL();
2481 STORE_NUMERIC_LOCAL_SET_STANDARD();
2482 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2483 PTR2UV(sv), SvNVX(sv));
2484 RESTORE_NUMERIC_LOCAL();
2488 else if (SvTYPE(sv) < SVt_PVNV)
2489 sv_upgrade(sv, SVt_PVNV);
2494 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2495 #ifdef NV_PRESERVES_UV
2501 /* Only set the public NV OK flag if this NV preserves the IV */
2502 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2504 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2505 : (SvIVX(sv) == I_V(SvNVX(sv))))
2511 else if (SvPOKp(sv) && SvLEN(sv)) {
2513 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2514 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2516 #ifdef NV_PRESERVES_UV
2517 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2518 == IS_NUMBER_IN_UV) {
2519 /* It's definitely an integer */
2520 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2522 SvNV_set(sv, Atof(SvPVX_const(sv)));
2528 SvNV_set(sv, Atof(SvPVX_const(sv)));
2529 /* Only set the public NV OK flag if this NV preserves the value in
2530 the PV at least as well as an IV/UV would.
2531 Not sure how to do this 100% reliably. */
2532 /* if that shift count is out of range then Configure's test is
2533 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2535 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2536 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2537 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2538 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2539 /* Can't use strtol etc to convert this string, so don't try.
2540 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2543 /* value has been set. It may not be precise. */
2544 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2545 /* 2s complement assumption for (UV)IV_MIN */
2546 SvNOK_on(sv); /* Integer is too negative. */
2551 if (numtype & IS_NUMBER_NEG) {
2552 SvIV_set(sv, -(IV)value);
2553 } else if (value <= (UV)IV_MAX) {
2554 SvIV_set(sv, (IV)value);
2556 SvUV_set(sv, value);
2560 if (numtype & IS_NUMBER_NOT_INT) {
2561 /* I believe that even if the original PV had decimals,
2562 they are lost beyond the limit of the FP precision.
2563 However, neither is canonical, so both only get p
2564 flags. NWC, 2000/11/25 */
2565 /* Both already have p flags, so do nothing */
2567 const NV nv = SvNVX(sv);
2568 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2569 if (SvIVX(sv) == I_V(nv)) {
2572 /* It had no "." so it must be integer. */
2576 /* between IV_MAX and NV(UV_MAX).
2577 Could be slightly > UV_MAX */
2579 if (numtype & IS_NUMBER_NOT_INT) {
2580 /* UV and NV both imprecise. */
2582 const UV nv_as_uv = U_V(nv);
2584 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2593 /* It might be more code efficient to go through the entire logic above
2594 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2595 gets complex and potentially buggy, so more programmer efficient
2596 to do it this way, by turning off the public flags: */
2598 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2599 #endif /* NV_PRESERVES_UV */
2602 if (isGV_with_GP(sv)) {
2603 glob_2number(MUTABLE_GV(sv));
2607 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2609 assert (SvTYPE(sv) >= SVt_NV);
2610 /* Typically the caller expects that sv_any is not NULL now. */
2611 /* XXX Ilya implies that this is a bug in callers that assume this
2612 and ideally should be fixed. */
2615 #if defined(USE_LONG_DOUBLE)
2617 STORE_NUMERIC_LOCAL_SET_STANDARD();
2618 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2619 PTR2UV(sv), SvNVX(sv));
2620 RESTORE_NUMERIC_LOCAL();
2624 STORE_NUMERIC_LOCAL_SET_STANDARD();
2625 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2626 PTR2UV(sv), SvNVX(sv));
2627 RESTORE_NUMERIC_LOCAL();
2636 Return an SV with the numeric value of the source SV, doing any necessary
2637 reference or overload conversion. You must use the C<SvNUM(sv)> macro to
2638 access this function.
2644 Perl_sv_2num(pTHX_ register SV *const sv)
2646 PERL_ARGS_ASSERT_SV_2NUM;
2651 SV * const tmpsv = AMG_CALLun(sv,numer);
2652 TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2653 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2654 return sv_2num(tmpsv);
2656 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2659 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2660 * UV as a string towards the end of buf, and return pointers to start and
2663 * We assume that buf is at least TYPE_CHARS(UV) long.
2667 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2669 char *ptr = buf + TYPE_CHARS(UV);
2670 char * const ebuf = ptr;
2673 PERL_ARGS_ASSERT_UIV_2BUF;
2685 *--ptr = '0' + (char)(uv % 10);
2694 =for apidoc sv_2pv_flags
2696 Returns a pointer to the string value of an SV, and sets *lp to its length.
2697 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2699 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2700 usually end up here too.
2706 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2716 if (SvGMAGICAL(sv)) {
2717 if (flags & SV_GMAGIC)
2722 if (flags & SV_MUTABLE_RETURN)
2723 return SvPVX_mutable(sv);
2724 if (flags & SV_CONST_RETURN)
2725 return (char *)SvPVX_const(sv);
2728 if (SvIOKp(sv) || SvNOKp(sv)) {
2729 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2734 ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2735 : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2737 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2744 #ifdef FIXNEGATIVEZERO
2745 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2751 SvUPGRADE(sv, SVt_PV);
2754 s = SvGROW_mutable(sv, len + 1);
2757 return (char*)memcpy(s, tbuf, len + 1);
2763 assert(SvTYPE(sv) >= SVt_PVMG);
2764 /* This falls through to the report_uninit near the end of the
2766 } else if (SvTHINKFIRST(sv)) {
2771 if (flags & SV_SKIP_OVERLOAD)
2773 tmpstr = AMG_CALLun(sv,string);
2774 TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2775 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2777 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2781 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2782 if (flags & SV_CONST_RETURN) {
2783 pv = (char *) SvPVX_const(tmpstr);
2785 pv = (flags & SV_MUTABLE_RETURN)
2786 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2789 *lp = SvCUR(tmpstr);
2791 pv = sv_2pv_flags(tmpstr, lp, flags);
2804 SV *const referent = SvRV(sv);
2808 retval = buffer = savepvn("NULLREF", len);
2809 } else if (SvTYPE(referent) == SVt_REGEXP) {
2810 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2815 /* If the regex is UTF-8 we want the containing scalar to
2816 have an UTF-8 flag too */
2822 if ((seen_evals = RX_SEEN_EVALS(re)))
2823 PL_reginterp_cnt += seen_evals;
2826 *lp = RX_WRAPLEN(re);
2828 return RX_WRAPPED(re);
2830 const char *const typestr = sv_reftype(referent, 0);
2831 const STRLEN typelen = strlen(typestr);
2832 UV addr = PTR2UV(referent);
2833 const char *stashname = NULL;
2834 STRLEN stashnamelen = 0; /* hush, gcc */
2835 const char *buffer_end;
2837 if (SvOBJECT(referent)) {
2838 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2841 stashname = HEK_KEY(name);
2842 stashnamelen = HEK_LEN(name);
2844 if (HEK_UTF8(name)) {
2850 stashname = "__ANON__";
2853 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2854 + 2 * sizeof(UV) + 2 /* )\0 */;
2856 len = typelen + 3 /* (0x */
2857 + 2 * sizeof(UV) + 2 /* )\0 */;
2860 Newx(buffer, len, char);
2861 buffer_end = retval = buffer + len;
2863 /* Working backwards */
2867 *--retval = PL_hexdigit[addr & 15];
2868 } while (addr >>= 4);
2874 memcpy(retval, typestr, typelen);
2878 retval -= stashnamelen;
2879 memcpy(retval, stashname, stashnamelen);
2881 /* retval may not neccesarily have reached the start of the
2883 assert (retval >= buffer);
2885 len = buffer_end - retval - 1; /* -1 for that \0 */
2893 if (SvREADONLY(sv) && !SvOK(sv)) {
2896 if (flags & SV_UNDEF_RETURNS_NULL)
2898 if (ckWARN(WARN_UNINITIALIZED))
2903 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2904 /* I'm assuming that if both IV and NV are equally valid then
2905 converting the IV is going to be more efficient */
2906 const U32 isUIOK = SvIsUV(sv);
2907 char buf[TYPE_CHARS(UV)];
2911 if (SvTYPE(sv) < SVt_PVIV)
2912 sv_upgrade(sv, SVt_PVIV);
2913 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2915 /* inlined from sv_setpvn */
2916 s = SvGROW_mutable(sv, len + 1);
2917 Move(ptr, s, len, char);
2921 else if (SvNOKp(sv)) {
2923 if (SvTYPE(sv) < SVt_PVNV)
2924 sv_upgrade(sv, SVt_PVNV);
2925 /* The +20 is pure guesswork. Configure test needed. --jhi */
2926 s = SvGROW_mutable(sv, NV_DIG + 20);
2927 /* some Xenix systems wipe out errno here */
2929 if (SvNVX(sv) == 0.0)
2930 my_strlcpy(s, "0", SvLEN(sv));
2934 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2937 #ifdef FIXNEGATIVEZERO
2938 if (*s == '-' && s[1] == '0' && !s[2]) {
2950 if (isGV_with_GP(sv)) {
2951 GV *const gv = MUTABLE_GV(sv);
2952 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
2953 SV *const buffer = sv_newmortal();
2955 /* FAKE globs can get coerced, so need to turn this off temporarily
2958 gv_efullname3(buffer, gv, "*");
2959 SvFLAGS(gv) |= wasfake;
2961 if (SvPOK(buffer)) {
2963 *lp = SvCUR(buffer);
2965 return SvPVX(buffer);
2976 if (flags & SV_UNDEF_RETURNS_NULL)
2978 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2980 if (SvTYPE(sv) < SVt_PV)
2981 /* Typically the caller expects that sv_any is not NULL now. */
2982 sv_upgrade(sv, SVt_PV);
2986 const STRLEN len = s - SvPVX_const(sv);
2992 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2993 PTR2UV(sv),SvPVX_const(sv)));
2994 if (flags & SV_CONST_RETURN)
2995 return (char *)SvPVX_const(sv);
2996 if (flags & SV_MUTABLE_RETURN)
2997 return SvPVX_mutable(sv);
3002 =for apidoc sv_copypv
3004 Copies a stringified representation of the source SV into the
3005 destination SV. Automatically performs any necessary mg_get and
3006 coercion of numeric values into strings. Guaranteed to preserve
3007 UTF8 flag even from overloaded objects. Similar in nature to
3008 sv_2pv[_flags] but operates directly on an SV instead of just the
3009 string. Mostly uses sv_2pv_flags to do its work, except when that
3010 would lose the UTF-8'ness of the PV.
3016 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3019 const char * const s = SvPV_const(ssv,len);
3021 PERL_ARGS_ASSERT_SV_COPYPV;
3023 sv_setpvn(dsv,s,len);
3031 =for apidoc sv_2pvbyte
3033 Return a pointer to the byte-encoded representation of the SV, and set *lp
3034 to its length. May cause the SV to be downgraded from UTF-8 as a
3037 Usually accessed via the C<SvPVbyte> macro.
3043 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3045 PERL_ARGS_ASSERT_SV_2PVBYTE;
3047 sv_utf8_downgrade(sv,0);
3048 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3052 =for apidoc sv_2pvutf8
3054 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3055 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3057 Usually accessed via the C<SvPVutf8> macro.
3063 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3065 PERL_ARGS_ASSERT_SV_2PVUTF8;
3067 sv_utf8_upgrade(sv);
3068 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3073 =for apidoc sv_2bool
3075 This function is only called on magical items, and is only used by
3076 sv_true() or its macro equivalent.
3082 Perl_sv_2bool(pTHX_ register SV *const sv)
3086 PERL_ARGS_ASSERT_SV_2BOOL;
3094 SV * const tmpsv = AMG_CALLun(sv,bool_);
3095 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3096 return cBOOL(SvTRUE(tmpsv));
3098 return SvRV(sv) != 0;
3101 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3103 (*sv->sv_u.svu_pv > '0' ||
3104 Xpvtmp->xpv_cur > 1 ||
3105 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3112 return SvIVX(sv) != 0;
3115 return SvNVX(sv) != 0.0;
3117 if (isGV_with_GP(sv))
3127 =for apidoc sv_utf8_upgrade
3129 Converts the PV of an SV to its UTF-8-encoded form.
3130 Forces the SV to string form if it is not already.
3131 Will C<mg_get> on C<sv> if appropriate.
3132 Always sets the SvUTF8 flag to avoid future validity checks even
3133 if the whole string is the same in UTF-8 as not.
3134 Returns the number of bytes in the converted string
3136 This is not as a general purpose byte encoding to Unicode interface:
3137 use the Encode extension for that.
3139 =for apidoc sv_utf8_upgrade_nomg
3141 Like sv_utf8_upgrade, but doesn't do magic on C<sv>
3143 =for apidoc sv_utf8_upgrade_flags
3145 Converts the PV of an SV to its UTF-8-encoded form.
3146 Forces the SV to string form if it is not already.
3147 Always sets the SvUTF8 flag to avoid future validity checks even
3148 if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
3149 will C<mg_get> on C<sv> if appropriate, else not.
3150 Returns the number of bytes in the converted string
3151 C<sv_utf8_upgrade> and
3152 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3154 This is not as a general purpose byte encoding to Unicode interface:
3155 use the Encode extension for that.
3159 The grow version is currently not externally documented. It adds a parameter,
3160 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3161 have free after it upon return. This allows the caller to reserve extra space
3162 that it intends to fill, to avoid extra grows.
3164 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3165 which can be used to tell this function to not first check to see if there are
3166 any characters that are different in UTF-8 (variant characters) which would
3167 force it to allocate a new string to sv, but to assume there are. Typically
3168 this flag is used by a routine that has already parsed the string to find that
3169 there are such characters, and passes this information on so that the work
3170 doesn't have to be repeated.
3172 (One might think that the calling routine could pass in the position of the
3173 first such variant, so it wouldn't have to be found again. But that is not the
3174 case, because typically when the caller is likely to use this flag, it won't be
3175 calling this routine unless it finds something that won't fit into a byte.
3176 Otherwise it tries to not upgrade and just use bytes. But some things that
3177 do fit into a byte are variants in utf8, and the caller may not have been
3178 keeping track of these.)
3180 If the routine itself changes the string, it adds a trailing NUL. Such a NUL
3181 isn't guaranteed due to having other routines do the work in some input cases,
3182 or if the input is already flagged as being in utf8.
3184 The speed of this could perhaps be improved for many cases if someone wanted to
3185 write a fast function that counts the number of variant characters in a string,
3186 especially if it could return the position of the first one.
3191 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
3195 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3197 if (sv == &PL_sv_undef)
3201 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3202 (void) sv_2pv_flags(sv,&len, flags);
3204 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3208 (void) SvPV_force(sv,len);
3213 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3218 sv_force_normal_flags(sv, 0);
3221 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3222 sv_recode_to_utf8(sv, PL_encoding);
3223 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3227 if (SvCUR(sv) == 0) {
3228 if (extra) SvGROW(sv, extra);
3229 } else { /* Assume Latin-1/EBCDIC */
3230 /* This function could be much more efficient if we
3231 * had a FLAG in SVs to signal if there are any variant
3232 * chars in the PV. Given that there isn't such a flag
3233 * make the loop as fast as possible (although there are certainly ways
3234 * to speed this up, eg. through vectorization) */
3235 U8 * s = (U8 *) SvPVX_const(sv);
3236 U8 * e = (U8 *) SvEND(sv);
3238 STRLEN two_byte_count = 0;
3240 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3242 /* See if really will need to convert to utf8. We mustn't rely on our
3243 * incoming SV being well formed and having a trailing '\0', as certain
3244 * code in pp_formline can send us partially built SVs. */
3248 if (NATIVE_IS_INVARIANT(ch)) continue;
3250 t--; /* t already incremented; re-point to first variant */
3255 /* utf8 conversion not needed because all are invariants. Mark as
3256 * UTF-8 even if no variant - saves scanning loop */
3262 /* Here, the string should be converted to utf8, either because of an
3263 * input flag (two_byte_count = 0), or because a character that
3264 * requires 2 bytes was found (two_byte_count = 1). t points either to
3265 * the beginning of the string (if we didn't examine anything), or to
3266 * the first variant. In either case, everything from s to t - 1 will
3267 * occupy only 1 byte each on output.
3269 * There are two main ways to convert. One is to create a new string
3270 * and go through the input starting from the beginning, appending each
3271 * converted value onto the new string as we go along. It's probably
3272 * best to allocate enough space in the string for the worst possible
3273 * case rather than possibly running out of space and having to
3274 * reallocate and then copy what we've done so far. Since everything
3275 * from s to t - 1 is invariant, the destination can be initialized
3276 * with these using a fast memory copy
3278 * The other way is to figure out exactly how big the string should be
3279 * by parsing the entire input. Then you don't have to make it big
3280 * enough to handle the worst possible case, and more importantly, if
3281 * the string you already have is large enough, you don't have to
3282 * allocate a new string, you can copy the last character in the input
3283 * string to the final position(s) that will be occupied by the
3284 * converted string and go backwards, stopping at t, since everything
3285 * before that is invariant.
3287 * There are advantages and disadvantages to each method.
3289 * In the first method, we can allocate a new string, do the memory
3290 * copy from the s to t - 1, and then proceed through the rest of the
3291 * string byte-by-byte.
3293 * In the second method, we proceed through the rest of the input
3294 * string just calculating how big the converted string will be. Then
3295 * there are two cases:
3296 * 1) if the string has enough extra space to handle the converted
3297 * value. We go backwards through the string, converting until we
3298 * get to the position we are at now, and then stop. If this
3299 * position is far enough along in the string, this method is
3300 * faster than the other method. If the memory copy were the same
3301 * speed as the byte-by-byte loop, that position would be about
3302 * half-way, as at the half-way mark, parsing to the end and back
3303 * is one complete string's parse, the same amount as starting
3304 * over and going all the way through. Actually, it would be
3305 * somewhat less than half-way, as it's faster to just count bytes
3306 * than to also copy, and we don't have the overhead of allocating
3307 * a new string, changing the scalar to use it, and freeing the
3308 * existing one. But if the memory copy is fast, the break-even
3309 * point is somewhere after half way. The counting loop could be
3310 * sped up by vectorization, etc, to move the break-even point
3311 * further towards the beginning.
3312 * 2) if the string doesn't have enough space to handle the converted
3313 * value. A new string will have to be allocated, and one might
3314 * as well, given that, start from the beginning doing the first
3315 * method. We've spent extra time parsing the string and in
3316 * exchange all we've gotten is that we know precisely how big to
3317 * make the new one. Perl is more optimized for time than space,
3318 * so this case is a loser.
3319 * So what I've decided to do is not use the 2nd method unless it is
3320 * guaranteed that a new string won't have to be allocated, assuming
3321 * the worst case. I also decided not to put any more conditions on it
3322 * than this, for now. It seems likely that, since the worst case is
3323 * twice as big as the unknown portion of the string (plus 1), we won't
3324 * be guaranteed enough space, causing us to go to the first method,
3325 * unless the string is short, or the first variant character is near
3326 * the end of it. In either of these cases, it seems best to use the
3327 * 2nd method. The only circumstance I can think of where this would
3328 * be really slower is if the string had once had much more data in it
3329 * than it does now, but there is still a substantial amount in it */
3332 STRLEN invariant_head = t - s;
3333 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3334 if (SvLEN(sv) < size) {
3336 /* Here, have decided to allocate a new string */
3341 Newx(dst, size, U8);
3343 /* If no known invariants at the beginning of the input string,
3344 * set so starts from there. Otherwise, can use memory copy to
3345 * get up to where we are now, and then start from here */
3347 if (invariant_head <= 0) {
3350 Copy(s, dst, invariant_head, char);
3351 d = dst + invariant_head;
3355 const UV uv = NATIVE8_TO_UNI(*t++);
3356 if (UNI_IS_INVARIANT(uv))
3357 *d++ = (U8)UNI_TO_NATIVE(uv);
3359 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3360 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3364 SvPV_free(sv); /* No longer using pre-existing string */
3365 SvPV_set(sv, (char*)dst);
3366 SvCUR_set(sv, d - dst);
3367 SvLEN_set(sv, size);
3370 /* Here, have decided to get the exact size of the string.
3371 * Currently this happens only when we know that there is
3372 * guaranteed enough space to fit the converted string, so
3373 * don't have to worry about growing. If two_byte_count is 0,
3374 * then t points to the first byte of the string which hasn't
3375 * been examined yet. Otherwise two_byte_count is 1, and t
3376 * points to the first byte in the string that will expand to
3377 * two. Depending on this, start examining at t or 1 after t.
3380 U8 *d = t + two_byte_count;
3383 /* Count up the remaining bytes that expand to two */
3386 const U8 chr = *d++;
3387 if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3390 /* The string will expand by just the number of bytes that
3391 * occupy two positions. But we are one afterwards because of
3392 * the increment just above. This is the place to put the
3393 * trailing NUL, and to set the length before we decrement */
3395 d += two_byte_count;
3396 SvCUR_set(sv, d - s);
3400 /* Having decremented d, it points to the position to put the
3401 * very last byte of the expanded string. Go backwards through
3402 * the string, copying and expanding as we go, stopping when we
3403 * get to the part that is invariant the rest of the way down */
3407 const U8 ch = NATIVE8_TO_UNI(*e--);
3408 if (UNI_IS_INVARIANT(ch)) {
3409 *d-- = UNI_TO_NATIVE(ch);
3411 *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3412 *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3419 /* Mark as UTF-8 even if no variant - saves scanning loop */
3425 =for apidoc sv_utf8_downgrade
3427 Attempts to convert the PV of an SV from characters to bytes.
3428 If the PV contains a character that cannot fit
3429 in a byte, this conversion will fail;
3430 in this case, either returns false or, if C<fail_ok> is not
3433 This is not as a general purpose Unicode to byte encoding interface:
3434 use the Encode extension for that.
3440 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3444 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3446 if (SvPOKp(sv) && SvUTF8(sv)) {
3452 sv_force_normal_flags(sv, 0);
3454 s = (U8 *) SvPV(sv, len);
3455 if (!utf8_to_bytes(s, &len)) {
3460 Perl_croak(aTHX_ "Wide character in %s",
3463 Perl_croak(aTHX_ "Wide character");
3474 =for apidoc sv_utf8_encode
3476 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3477 flag off so that it looks like octets again.
3483 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3485 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3488 sv_force_normal_flags(sv, 0);
3490 if (SvREADONLY(sv)) {
3491 Perl_croak_no_modify(aTHX);
3493 (void) sv_utf8_upgrade(sv);
3498 =for apidoc sv_utf8_decode
3500 If the PV of the SV is an octet sequence in UTF-8
3501 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3502 so that it looks like a character. If the PV contains only single-byte
3503 characters, the C<SvUTF8> flag stays being off.
3504 Scans PV for validity and returns false if the PV is invalid UTF-8.
3510 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3512 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3518 /* The octets may have got themselves encoded - get them back as
3521 if (!sv_utf8_downgrade(sv, TRUE))
3524 /* it is actually just a matter of turning the utf8 flag on, but
3525 * we want to make sure everything inside is valid utf8 first.
3527 c = (const U8 *) SvPVX_const(sv);
3528 if (!is_utf8_string(c, SvCUR(sv)+1))
3530 e = (const U8 *) SvEND(sv);
3533 if (!UTF8_IS_INVARIANT(ch)) {
3543 =for apidoc sv_setsv
3545 Copies the contents of the source SV C<ssv> into the destination SV
3546 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3547 function if the source SV needs to be reused. Does not handle 'set' magic.
3548 Loosely speaking, it performs a copy-by-value, obliterating any previous
3549 content of the destination.
3551 You probably want to use one of the assortment of wrappers, such as
3552 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3553 C<SvSetMagicSV_nosteal>.
3555 =for apidoc sv_setsv_flags
3557 Copies the contents of the source SV C<ssv> into the destination SV
3558 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3559 function if the source SV needs to be reused. Does not handle 'set' magic.
3560 Loosely speaking, it performs a copy-by-value, obliterating any previous
3561 content of the destination.
3562 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3563 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3564 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3565 and C<sv_setsv_nomg> are implemented in terms of this function.
3567 You probably want to use one of the assortment of wrappers, such as
3568 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3569 C<SvSetMagicSV_nosteal>.
3571 This is the primary function for copying scalars, and most other
3572 copy-ish functions and macros use this underneath.
3578 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3580 I32 mro_changes = 0; /* 1 = method, 2 = isa */
3582 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3584 if (dtype != SVt_PVGV) {
3585 const char * const name = GvNAME(sstr);
3586 const STRLEN len = GvNAMELEN(sstr);
3588 if (dtype >= SVt_PV) {
3594 SvUPGRADE(dstr, SVt_PVGV);
3595 (void)SvOK_off(dstr);
3596 /* FIXME - why are we doing this, then turning it off and on again
3598 isGV_with_GP_on(dstr);
3600 GvSTASH(dstr) = GvSTASH(sstr);
3602 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3603 gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
3604 SvFAKE_on(dstr); /* can coerce to non-glob */
3607 if(GvGP(MUTABLE_GV(sstr))) {
3608 /* If source has method cache entry, clear it */
3610 SvREFCNT_dec(GvCV(sstr));
3614 /* If source has a real method, then a method is
3616 else if(GvCV((const GV *)sstr)) {
3621 /* If dest already had a real method, that's a change as well */
3622 if(!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)) {
3626 if(strEQ(GvNAME((const GV *)dstr),"ISA"))
3629 gp_free(MUTABLE_GV(dstr));
3630 isGV_with_GP_off(dstr);
3631 (void)SvOK_off(dstr);
3632 isGV_with_GP_on(dstr);
3633 GvINTRO_off(dstr); /* one-shot flag */
3634 GvGP(dstr) = gp_ref(GvGP(sstr));
3635 if (SvTAINTED(sstr))
3637 if (GvIMPORTED(dstr) != GVf_IMPORTED
3638 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3640 GvIMPORTED_on(dstr);
3643 if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
3644 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3649 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3651 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3653 const int intro = GvINTRO(dstr);
3656 const U32 stype = SvTYPE(sref);
3658 PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3661 GvINTRO_off(dstr); /* one-shot flag */
3662 GvLINE(dstr) = CopLINE(PL_curcop);
3663 GvEGV(dstr) = MUTABLE_GV(dstr);
3668 location = (SV **) &GvCV(dstr);
3669 import_flag = GVf_IMPORTED_CV;
3672 location = (SV **) &GvHV(dstr);
3673 import_flag = GVf_IMPORTED_HV;
3676 location = (SV **) &GvAV(dstr);
3677 import_flag = GVf_IMPORTED_AV;
3680 location = (SV **) &GvIOp(dstr);
3683 location = (SV **) &GvFORM(dstr);
3686 location = &GvSV(dstr);
3687 import_flag = GVf_IMPORTED_SV;
3690 if (stype == SVt_PVCV) {
3691 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3692 if (GvCVGEN(dstr)) {
3693 SvREFCNT_dec(GvCV(dstr));
3695 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3698 SAVEGENERICSV(*location);
3702 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3703 CV* const cv = MUTABLE_CV(*location);
3705 if (!GvCVGEN((const GV *)dstr) &&
3706 (CvROOT(cv) || CvXSUB(cv)))
3708 /* Redefining a sub - warning is mandatory if
3709 it was a const and its value changed. */
3710 if (CvCONST(cv) && CvCONST((const CV *)sref)
3712 == cv_const_sv((const CV *)sref)) {
3714 /* They are 2 constant subroutines generated from
3715 the same constant. This probably means that
3716 they are really the "same" proxy subroutine
3717 instantiated in 2 places. Most likely this is
3718 when a constant is exported twice. Don't warn.
3721 else if (ckWARN(WARN_REDEFINE)
3723 && (!CvCONST((const CV *)sref)
3724 || sv_cmp(cv_const_sv(cv),
3725 cv_const_sv((const CV *)
3727 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3730 ? "Constant subroutine %s::%s redefined"
3731 : "Subroutine %s::%s redefined"),
3732 HvNAME_get(GvSTASH((const GV *)dstr)),
3733 GvENAME(MUTABLE_GV(dstr)));
3737 cv_ckproto_len(cv, (const GV *)dstr,
3738 SvPOK(sref) ? SvPVX_const(sref) : NULL,
3739 SvPOK(sref) ? SvCUR(sref) : 0);
3741 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3742 GvASSUMECV_on(dstr);
3743 if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3746 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3747 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3748 GvFLAGS(dstr) |= import_flag;
3750 if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
3751 sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3752 mro_isa_changed_in(GvSTASH(dstr));
3757 if (SvTAINTED(sstr))
3763 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3766 register U32 sflags;
3768 register svtype stype;
3770 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3775 if (SvIS_FREED(dstr)) {
3776 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3777 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3779 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3781 sstr = &PL_sv_undef;
3782 if (SvIS_FREED(sstr)) {
3783 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3784 (void*)sstr, (void*)dstr);
3786 stype = SvTYPE(sstr);
3787 dtype = SvTYPE(dstr);
3789 (void)SvAMAGIC_off(dstr);
3792 /* need to nuke the magic */
3796 /* There's a lot of redundancy below but we're going for speed here */
3801 if (dtype != SVt_PVGV) {
3802 (void)SvOK_off(dstr);
3810 sv_upgrade(dstr, SVt_IV);
3814 sv_upgrade(dstr, SVt_PVIV);
3817 goto end_of_first_switch;
3819 (void)SvIOK_only(dstr);
3820 SvIV_set(dstr, SvIVX(sstr));
3823 /* SvTAINTED can only be true if the SV has taint magic, which in
3824 turn means that the SV type is PVMG (or greater). This is the
3825 case statement for SVt_IV, so this cannot be true (whatever gcov
3827 assert(!SvTAINTED(sstr));
3832 if (dtype < SVt_PV && dtype != SVt_IV)
3833 sv_upgrade(dstr, SVt_IV);
3841 sv_upgrade(dstr, SVt_NV);
3845 sv_upgrade(dstr, SVt_PVNV);
3848 goto end_of_first_switch;
3850 SvNV_set(dstr, SvNVX(sstr));
3851 (void)SvNOK_only(dstr);
3852 /* SvTAINTED can only be true if the SV has taint magic, which in
3853 turn means that the SV type is PVMG (or greater). This is the
3854 case statement for SVt_NV, so this cannot be true (whatever gcov
3856 assert(!SvTAINTED(sstr));
3862 #ifdef PERL_OLD_COPY_ON_WRITE
3863 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3864 if (dtype < SVt_PVIV)
3865 sv_upgrade(dstr, SVt_PVIV);
3872 sv_upgrade(dstr, SVt_PV);
3875 if (dtype < SVt_PVIV)
3876 sv_upgrade(dstr, SVt_PVIV);
3879 if (dtype < SVt_PVNV)
3880 sv_upgrade(dstr, SVt_PVNV);
3884 const char * const type = sv_reftype(sstr,0);
3886 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
3888 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3893 if (dtype < SVt_REGEXP)
3894 sv_upgrade(dstr, SVt_REGEXP);
3897 /* case SVt_BIND: */
3900 if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
3901 glob_assign_glob(dstr, sstr, dtype);
3904 /* SvVALID means that this PVGV is playing at being an FBM. */
3908 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3910 if (SvTYPE(sstr) != stype) {
3911 stype = SvTYPE(sstr);
3912 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
3913 glob_assign_glob(dstr, sstr, dtype);
3918 if (stype == SVt_PVLV)
3919 SvUPGRADE(dstr, SVt_PVNV);
3921 SvUPGRADE(dstr, (svtype)stype);
3923 end_of_first_switch:
3925 /* dstr may have been upgraded. */
3926 dtype = SvTYPE(dstr);
3927 sflags = SvFLAGS(sstr);
3929 if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
3930 /* Assigning to a subroutine sets the prototype. */
3933 const char *const ptr = SvPV_const(sstr, len);
3935 SvGROW(dstr, len + 1);
3936 Copy(ptr, SvPVX(dstr), len + 1, char);
3937 SvCUR_set(dstr, len);
3939 SvFLAGS(dstr) |= sflags & SVf_UTF8;
3943 } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3944 const char * const type = sv_reftype(dstr,0);
3946 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
3948 Perl_croak(aTHX_ "Cannot copy to %s", type);
3949 } else if (sflags & SVf_ROK) {
3950 if (isGV_with_GP(dstr) && dtype == SVt_PVGV
3951 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
3954 if (GvIMPORTED(dstr) != GVf_IMPORTED
3955 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3957 GvIMPORTED_on(dstr);
3962 glob_assign_glob(dstr, sstr, dtype);
3966 if (dtype >= SVt_PV) {
3967 if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3968 glob_assign_ref(dstr, sstr);
3971 if (SvPVX_const(dstr)) {
3977 (void)SvOK_off(dstr);
3978 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3979 SvFLAGS(dstr) |= sflags & SVf_ROK;
3980 assert(!(sflags & SVp_NOK));
3981 assert(!(sflags & SVp_IOK));
3982 assert(!(sflags & SVf_NOK));
3983 assert(!(sflags & SVf_IOK));
3985 else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3986 if (!(sflags & SVf_OK)) {
3987 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3988 "Undefined value assigned to typeglob");
3991 GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
3992 if (dstr != (const SV *)gv) {
3994 gp_free(MUTABLE_GV(dstr));
3995 GvGP(dstr) = gp_ref(GvGP(gv));
3999 else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
4000 reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4002 else if (sflags & SVp_POK) {
4006 * Check to see if we can just swipe the string. If so, it's a
4007 * possible small lose on short strings, but a big win on long ones.
4008 * It might even be a win on short strings if SvPVX_const(dstr)
4009 * has to be allocated and SvPVX_const(sstr) has to be freed.
4010 * Likewise if we can set up COW rather than doing an actual copy, we
4011 * drop to the else clause, as the swipe code and the COW setup code
4012 * have much in common.
4015 /* Whichever path we take through the next code, we want this true,
4016 and doing it now facilitates the COW check. */
4017 (void)SvPOK_only(dstr);
4020 /* If we're already COW then this clause is not true, and if COW
4021 is allowed then we drop down to the else and make dest COW
4022 with us. If caller hasn't said that we're allowed to COW
4023 shared hash keys then we don't do the COW setup, even if the
4024 source scalar is a shared hash key scalar. */
4025 (((flags & SV_COW_SHARED_HASH_KEYS)
4026 ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4027 : 1 /* If making a COW copy is forbidden then the behaviour we
4028 desire is as if the source SV isn't actually already
4029 COW, even if it is. So we act as if the source flags
4030 are not COW, rather than actually testing them. */
4032 #ifndef PERL_OLD_COPY_ON_WRITE
4033 /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4034 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4035 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4036 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4037 but in turn, it's somewhat dead code, never expected to go
4038 live, but more kept as a placeholder on how to do it better
4039 in a newer implementation. */
4040 /* If we are COW and dstr is a suitable target then we drop down
4041 into the else and make dest a COW of us. */
4042 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4047 (sflags & SVs_TEMP) && /* slated for free anyway? */
4048 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4049 (!(flags & SV_NOSTEAL)) &&
4050 /* and we're allowed to steal temps */
4051 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4052 SvLEN(sstr)) /* and really is a string */
4053 #ifdef PERL_OLD_COPY_ON_WRITE
4054 && ((flags & SV_COW_SHARED_HASH_KEYS)
4055 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4056 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4057 && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4061 /* Failed the swipe test, and it's not a shared hash key either.
4062 Have to copy the string. */
4063 STRLEN len = SvCUR(sstr);
4064 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4065 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4066 SvCUR_set(dstr, len);
4067 *SvEND(dstr) = '\0';
4069 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4071 /* Either it's a shared hash key, or it's suitable for
4072 copy-on-write or we can swipe the string. */
4074 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4078 #ifdef PERL_OLD_COPY_ON_WRITE
4080 if ((sflags & (SVf_FAKE | SVf_READONLY))
4081 != (SVf_FAKE | SVf_READONLY)) {
4082 SvREADONLY_on(sstr);
4084 /* Make the source SV into a loop of 1.
4085 (about to become 2) */
4086 SV_COW_NEXT_SV_SET(sstr, sstr);
4090 /* Initial code is common. */
4091 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4096 /* making another shared SV. */
4097 STRLEN cur = SvCUR(sstr);
4098 STRLEN len = SvLEN(sstr);
4099 #ifdef PERL_OLD_COPY_ON_WRITE
4101 assert (SvTYPE(dstr) >= SVt_PVIV);
4102 /* SvIsCOW_normal */
4103 /* splice us in between source and next-after-source. */
4104 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4105 SV_COW_NEXT_SV_SET(sstr, dstr);
4106 SvPV_set(dstr, SvPVX_mutable(sstr));
4110 /* SvIsCOW_shared_hash */
4111 DEBUG_C(PerlIO_printf(Perl_debug_log,
4112 "Copy on write: Sharing hash\n"));
4114 assert (SvTYPE(dstr) >= SVt_PV);
4116 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4118 SvLEN_set(dstr, len);
4119 SvCUR_set(dstr, cur);
4120 SvREADONLY_on(dstr);
4124 { /* Passes the swipe test. */
4125 SvPV_set(dstr, SvPVX_mutable(sstr));
4126 SvLEN_set(dstr, SvLEN(sstr));
4127 SvCUR_set(dstr, SvCUR(sstr));
4130 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4131 SvPV_set(sstr, NULL);
4137 if (sflags & SVp_NOK) {
4138 SvNV_set(dstr, SvNVX(sstr));
4140 if (sflags & SVp_IOK) {
4141 SvIV_set(dstr, SvIVX(sstr));
4142 /* Must do this otherwise some other overloaded use of 0x80000000
4143 gets confused. I guess SVpbm_VALID */
4144 if (sflags & SVf_IVisUV)
4147 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4149 const MAGIC * const smg = SvVSTRING_mg(sstr);
4151 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4152 smg->mg_ptr, smg->mg_len);
4153 SvRMAGICAL_on(dstr);
4157 else if (sflags & (SVp_IOK|SVp_NOK)) {
4158 (void)SvOK_off(dstr);
4159 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4160 if (sflags & SVp_IOK) {
4161 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4162 SvIV_set(dstr, SvIVX(sstr));
4164 if (sflags & SVp_NOK) {
4165 SvNV_set(dstr, SvNVX(sstr));
4169 if (isGV_with_GP(sstr)) {
4170 /* This stringification rule for globs is spread in 3 places.
4171 This feels bad. FIXME. */
4172 const U32 wasfake = sflags & SVf_FAKE;
4174 /* FAKE globs can get coerced, so need to turn this off
4175 temporarily if it is on. */
4177 gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4178 SvFLAGS(sstr) |= wasfake;
4181 (void)SvOK_off(dstr);
4183 if (SvTAINTED(sstr))
4188 =for apidoc sv_setsv_mg
4190 Like C<sv_setsv>, but also handles 'set' magic.
4196 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4198 PERL_ARGS_ASSERT_SV_SETSV_MG;
4200 sv_setsv(dstr,sstr);
4204 #ifdef PERL_OLD_COPY_ON_WRITE
4206 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4208 STRLEN cur = SvCUR(sstr);
4209 STRLEN len = SvLEN(sstr);
4210 register char *new_pv;
4212 PERL_ARGS_ASSERT_SV_SETSV_COW;
4215 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4216 (void*)sstr, (void*)dstr);
4223 if (SvTHINKFIRST(dstr))
4224 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4225 else if (SvPVX_const(dstr))
4226 Safefree(SvPVX_const(dstr));
4230 SvUPGRADE(dstr, SVt_PVIV);
4232 assert (SvPOK(sstr));
4233 assert (SvPOKp(sstr));
4234 assert (!SvIOK(sstr));
4235 assert (!SvIOKp(sstr));
4236 assert (!SvNOK(sstr));
4237 assert (!SvNOKp(sstr));
4239 if (SvIsCOW(sstr)) {
4241 if (SvLEN(sstr) == 0) {
4242 /* source is a COW shared hash key. */
4243 DEBUG_C(PerlIO_printf(Perl_debug_log,
4244 "Fast copy on write: Sharing hash\n"));
4245 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4248 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4250 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4251 SvUPGRADE(sstr, SVt_PVIV);
4252 SvREADONLY_on(sstr);
4254 DEBUG_C(PerlIO_printf(Perl_debug_log,
4255 "Fast copy on write: Converting sstr to COW\n"));
4256 SV_COW_NEXT_SV_SET(dstr, sstr);
4258 SV_COW_NEXT_SV_SET(sstr, dstr);
4259 new_pv = SvPVX_mutable(sstr);
4262 SvPV_set(dstr, new_pv);
4263 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4266 SvLEN_set(dstr, len);
4267 SvCUR_set(dstr, cur);
4276 =for apidoc sv_setpvn
4278 Copies a string into an SV. The C<len> parameter indicates the number of
4279 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4280 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4286 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4289 register char *dptr;
4291 PERL_ARGS_ASSERT_SV_SETPVN;
4293 SV_CHECK_THINKFIRST_COW_DROP(sv);
4299 /* len is STRLEN which is unsigned, need to copy to signed */
4302 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4304 SvUPGRADE(sv, SVt_PV);
4306 dptr = SvGROW(sv, len + 1);
4307 Move(ptr,dptr,len,char);
4310 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4315 =for apidoc sv_setpvn_mg
4317 Like C<sv_setpvn>, but also handles 'set' magic.
4323 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4325 PERL_ARGS_ASSERT_SV_SETPVN_MG;
4327 sv_setpvn(sv,ptr,len);
4332 =for apidoc sv_setpv
4334 Copies a string into an SV. The string must be null-terminated. Does not
4335 handle 'set' magic. See C<sv_setpv_mg>.
4341 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4344 register STRLEN len;
4346 PERL_ARGS_ASSERT_SV_SETPV;
4348 SV_CHECK_THINKFIRST_COW_DROP(sv);
4354 SvUPGRADE(sv, SVt_PV);
4356 SvGROW(sv, len + 1);
4357 Move(ptr,SvPVX(sv),len+1,char);
4359 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4364 =for apidoc sv_setpv_mg
4366 Like C<sv_setpv>, but also handles 'set' magic.
4372 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4374 PERL_ARGS_ASSERT_SV_SETPV_MG;
4381 =for apidoc sv_usepvn_flags
4383 Tells an SV to use C<ptr> to find its string value. Normally the
4384 string is stored inside the SV but sv_usepvn allows the SV to use an
4385 outside string. The C<ptr> should point to memory that was allocated
4386 by C<malloc>. The string length, C<len>, must be supplied. By default
4387 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4388 so that pointer should not be freed or used by the programmer after
4389 giving it to sv_usepvn, and neither should any pointers from "behind"
4390 that pointer (e.g. ptr + 1) be used.
4392 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4393 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4394 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4395 C<len>, and already meets the requirements for storing in C<SvPVX>)
4401 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4406 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4408 SV_CHECK_THINKFIRST_COW_DROP(sv);
4409 SvUPGRADE(sv, SVt_PV);
4412 if (flags & SV_SMAGIC)
4416 if (SvPVX_const(sv))
4420 if (flags & SV_HAS_TRAILING_NUL)
4421 assert(ptr[len] == '\0');
4424 allocate = (flags & SV_HAS_TRAILING_NUL)
4426 #ifdef Perl_safesysmalloc_size
4429 PERL_STRLEN_ROUNDUP(len + 1);
4431 if (flags & SV_HAS_TRAILING_NUL) {
4432 /* It's long enough - do nothing.
4433 Specfically Perl_newCONSTSUB is relying on this. */
4436 /* Force a move to shake out bugs in callers. */
4437 char *new_ptr = (char*)safemalloc(allocate);
4438 Copy(ptr, new_ptr, len, char);
4439 PoisonFree(ptr,len,char);
4443 ptr = (char*) saferealloc (ptr, allocate);
4446 #ifdef Perl_safesysmalloc_size
4447 SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4449 SvLEN_set(sv, allocate);
4453 if (!(flags & SV_HAS_TRAILING_NUL)) {
4456 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4458 if (flags & SV_SMAGIC)
4462 #ifdef PERL_OLD_COPY_ON_WRITE
4463 /* Need to do this *after* making the SV normal, as we need the buffer
4464 pointer to remain valid until after we've copied it. If we let go too early,
4465 another thread could invalidate it by unsharing last of the same hash key
4466 (which it can do by means other than releasing copy-on-write Svs)
4467 or by changing the other copy-on-write SVs in the loop. */
4469 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4471 PERL_ARGS_ASSERT_SV_RELEASE_COW;
4473 { /* this SV was SvIsCOW_normal(sv) */
4474 /* we need to find the SV pointing to us. */
4475 SV *current = SV_COW_NEXT_SV(after);
4477 if (current == sv) {
4478 /* The SV we point to points back to us (there were only two of us
4480 Hence other SV is no longer copy on write either. */
4482 SvREADONLY_off(after);
4484 /* We need to follow the pointers around the loop. */
4486 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4489 /* don't loop forever if the structure is bust, and we have
4490 a pointer into a closed loop. */
4491 assert (current != after);
4492 assert (SvPVX_const(current) == pvx);
4494 /* Make the SV before us point to the SV after us. */
4495 SV_COW_NEXT_SV_SET(current, after);
4501 =for apidoc sv_force_normal_flags
4503 Undo various types of fakery on an SV: if the PV is a shared string, make
4504 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4505 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4506 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4507 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4508 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4509 set to some other value.) In addition, the C<flags> parameter gets passed to
4510 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4511 with flags set to 0.
4517 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4521 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4523 #ifdef PERL_OLD_COPY_ON_WRITE
4524 if (SvREADONLY(sv)) {
4526 const char * const pvx = SvPVX_const(sv);
4527 const STRLEN len = SvLEN(sv);
4528 const STRLEN cur = SvCUR(sv);
4529 /* next COW sv in the loop. If len is 0 then this is a shared-hash
4530 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4531 we'll fail an assertion. */
4532 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4535 PerlIO_printf(Perl_debug_log,
4536 "Copy on write: Force normal %ld\n",
4542 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4545 if (flags & SV_COW_DROP_PV) {
4546 /* OK, so we don't need to copy our buffer. */
4549 SvGROW(sv, cur + 1);
4550 Move(pvx,SvPVX(sv),cur,char);
4555 sv_release_COW(sv, pvx, next);
4557 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4563 else if (IN_PERL_RUNTIME)
4564 Perl_croak_no_modify(aTHX);
4567 if (SvREADONLY(sv)) {
4569 const char * const pvx = SvPVX_const(sv);
4570 const STRLEN len = SvCUR(sv);
4575 SvGROW(sv, len + 1);
4576 Move(pvx,SvPVX(sv),len,char);
4578 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4580 else if (IN_PERL_RUNTIME)
4581 Perl_croak_no_modify(aTHX);
4585 sv_unref_flags(sv, flags);
4586 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4588 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
4589 /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous
4590 to sv_unglob. We only need it here, so inline it. */
4591 const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
4592 SV *const temp = newSV_type(new_type);
4593 void *const temp_p = SvANY(sv);
4595 if (new_type == SVt_PVMG) {
4596 SvMAGIC_set(temp, SvMAGIC(sv));
4597 SvMAGIC_set(sv, NULL);
4598 SvSTASH_set(temp, SvSTASH(sv));
4599 SvSTASH_set(sv, NULL);
4601 SvCUR_set(temp, SvCUR(sv));
4602 /* Remember that SvPVX is in the head, not the body. */
4604 SvLEN_set(temp, SvLEN(sv));
4605 /* This signals "buffer is owned by someone else" in sv_clear,
4606 which is the least effort way to stop it freeing the buffer.
4608 SvLEN_set(sv, SvLEN(sv)+1);
4610 /* Their buffer is already owned by someone else. */
4611 SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
4612 SvLEN_set(temp, SvCUR(sv)+1);
4615 /* Now swap the rest of the bodies. */
4617 SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
4618 SvFLAGS(sv) |= new_type;
4619 SvANY(sv) = SvANY(temp);
4621 SvFLAGS(temp) &= ~(SVTYPEMASK);
4622 SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
4623 SvANY(temp) = temp_p;
4632 Efficient removal of characters from the beginning of the string buffer.
4633 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4634 the string buffer. The C<ptr> becomes the first character of the adjusted
4635 string. Uses the "OOK hack".
4636 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4637 refer to the same chunk of data.
4643 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4649 const U8 *real_start;
4653 PERL_ARGS_ASSERT_SV_CHOP;
4655 if (!ptr || !SvPOKp(sv))
4657 delta = ptr - SvPVX_const(sv);
4659 /* Nothing to do. */
4662 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4663 nothing uses the value of ptr any more. */
4664 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4665 if (ptr <= SvPVX_const(sv))
4666 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4667 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4668 SV_CHECK_THINKFIRST(sv);
4669 if (delta > max_delta)
4670 Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4671 SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4672 SvPVX_const(sv) + max_delta);
4675 if (!SvLEN(sv)) { /* make copy of shared string */
4676 const char *pvx = SvPVX_const(sv);
4677 const STRLEN len = SvCUR(sv);
4678 SvGROW(sv, len + 1);
4679 Move(pvx,SvPVX(sv),len,char);
4682 SvFLAGS(sv) |= SVf_OOK;
4685 SvOOK_offset(sv, old_delta);
4687 SvLEN_set(sv, SvLEN(sv) - delta);
4688 SvCUR_set(sv, SvCUR(sv) - delta);
4689 SvPV_set(sv, SvPVX(sv) + delta);
4691 p = (U8 *)SvPVX_const(sv);
4696 real_start = p - delta;
4700 if (delta < 0x100) {
4704 p -= sizeof(STRLEN);
4705 Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4709 /* Fill the preceding buffer with sentinals to verify that no-one is
4711 while (p > real_start) {
4719 =for apidoc sv_catpvn
4721 Concatenates the string onto the end of the string which is in the SV. The
4722 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4723 status set, then the bytes appended should be valid UTF-8.
4724 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4726 =for apidoc sv_catpvn_flags
4728 Concatenates the string onto the end of the string which is in the SV. The
4729 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4730 status set, then the bytes appended should be valid UTF-8.
4731 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4732 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4733 in terms of this function.
4739 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4743 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4745 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4747 SvGROW(dsv, dlen + slen + 1);
4749 sstr = SvPVX_const(dsv);
4750 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4751 SvCUR_set(dsv, SvCUR(dsv) + slen);
4753 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4755 if (flags & SV_SMAGIC)
4760 =for apidoc sv_catsv
4762 Concatenates the string from SV C<ssv> onto the end of the string in
4763 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4764 not 'set' magic. See C<sv_catsv_mg>.
4766 =for apidoc sv_catsv_flags
4768 Concatenates the string from SV C<ssv> onto the end of the string in
4769 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4770 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4771 and C<sv_catsv_nomg> are implemented in terms of this function.
4776 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4780 PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4784 const char *spv = SvPV_const(ssv, slen);
4786 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4787 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4788 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4789 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4790 dsv->sv_flags doesn't have that bit set.
4791 Andy Dougherty 12 Oct 2001
4793 const I32 sutf8 = DO_UTF8(ssv);
4796 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4798 dutf8 = DO_UTF8(dsv);
4800 if (dutf8 != sutf8) {
4802 /* Not modifying source SV, so taking a temporary copy. */
4803 SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4805 sv_utf8_upgrade(csv);
4806 spv = SvPV_const(csv, slen);
4809 /* Leave enough space for the cat that's about to happen */
4810 sv_utf8_upgrade_flags_grow(dsv, 0, slen);
4812 sv_catpvn_nomg(dsv, spv, slen);
4815 if (flags & SV_SMAGIC)
4820 =for apidoc sv_catpv
4822 Concatenates the string onto the end of the string which is in the SV.
4823 If the SV has the UTF-8 status set, then the bytes appended should be
4824 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4829 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4832 register STRLEN len;
4836 PERL_ARGS_ASSERT_SV_CATPV;
4840 junk = SvPV_force(sv, tlen);
4842 SvGROW(sv, tlen + len + 1);
4844 ptr = SvPVX_const(sv);
4845 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4846 SvCUR_set(sv, SvCUR(sv) + len);
4847 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4852 =for apidoc sv_catpv_mg
4854 Like C<sv_catpv>, but also handles 'set' magic.
4860 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4862 PERL_ARGS_ASSERT_SV_CATPV_MG;
4871 Creates a new SV. A non-zero C<len> parameter indicates the number of
4872 bytes of preallocated string space the SV should have. An extra byte for a
4873 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
4874 space is allocated.) The reference count for the new SV is set to 1.
4876 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4877 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4878 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4879 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
4880 modules supporting older perls.
4886 Perl_newSV(pTHX_ const STRLEN len)
4893 sv_upgrade(sv, SVt_PV);
4894 SvGROW(sv, len + 1);
4899 =for apidoc sv_magicext
4901 Adds magic to an SV, upgrading it if necessary. Applies the
4902 supplied vtable and returns a pointer to the magic added.
4904 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4905 In particular, you can add magic to SvREADONLY SVs, and add more than
4906 one instance of the same 'how'.
4908 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4909 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4910 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4911 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4913 (This is now used as a subroutine by C<sv_magic>.)
4918 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
4919 const MGVTBL *const vtable, const char *const name, const I32 namlen)
4924 PERL_ARGS_ASSERT_SV_MAGICEXT;
4926 SvUPGRADE(sv, SVt_PVMG);
4927 Newxz(mg, 1, MAGIC);
4928 mg->mg_moremagic = SvMAGIC(sv);
4929 SvMAGIC_set(sv, mg);
4931 /* Sometimes a magic contains a reference loop, where the sv and
4932 object refer to each other. To prevent a reference loop that
4933 would prevent such objects being freed, we look for such loops
4934 and if we find one we avoid incrementing the object refcount.
4936 Note we cannot do this to avoid self-tie loops as intervening RV must
4937 have its REFCNT incremented to keep it in existence.
4940 if (!obj || obj == sv ||
4941 how == PERL_MAGIC_arylen ||
4942 how == PERL_MAGIC_symtab ||
4943 (SvTYPE(obj) == SVt_PVGV &&
4944 (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
4945 || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
4946 || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
4951 mg->mg_obj = SvREFCNT_inc_simple(obj);
4952 mg->mg_flags |= MGf_REFCOUNTED;
4955 /* Normal self-ties simply pass a null object, and instead of
4956 using mg_obj directly, use the SvTIED_obj macro to produce a
4957 new RV as needed. For glob "self-ties", we are tieing the PVIO
4958 with an RV obj pointing to the glob containing the PVIO. In
4959 this case, to avoid a reference loop, we need to weaken the
4963 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4964 obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
4970 mg->mg_len = namlen;
4973 mg->mg_ptr = savepvn(name, namlen);
4974 else if (namlen == HEf_SVKEY) {
4975 /* Yes, this is casting away const. This is only for the case of
4976 HEf_SVKEY. I think we need to document this abberation of the
4977 constness of the API, rather than making name non-const, as
4978 that change propagating outwards a long way. */
4979 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
4981 mg->mg_ptr = (char *) name;
4983 mg->mg_virtual = (MGVTBL *) vtable;
4987 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4992 =for apidoc sv_magic
4994 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4995 then adds a new magic item of type C<how> to the head of the magic list.
4997 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4998 handling of the C<name> and C<namlen> arguments.
5000 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5001 to add more than one instance of the same 'how'.
5007 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
5008 const char *const name, const I32 namlen)
5011 const MGVTBL *vtable;
5014 PERL_ARGS_ASSERT_SV_MAGIC;
5016 #ifdef PERL_OLD_COPY_ON_WRITE
5018 sv_force_normal_flags(sv, 0);
5020 if (SvREADONLY(sv)) {
5022 /* its okay to attach magic to shared strings; the subsequent
5023 * upgrade to PVMG will unshare the string */
5024 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
5027 && how != PERL_MAGIC_regex_global
5028 && how != PERL_MAGIC_bm
5029 && how != PERL_MAGIC_fm
5030 && how != PERL_MAGIC_sv
5031 && how != PERL_MAGIC_backref
5034 Perl_croak_no_modify(aTHX);
5037 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5038 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5039 /* sv_magic() refuses to add a magic of the same 'how' as an
5042 if (how == PERL_MAGIC_taint) {
5044 /* Any scalar which already had taint magic on which someone
5045 (erroneously?) did SvIOK_on() or similar will now be
5046 incorrectly sporting public "OK" flags. */
5047 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5055 vtable = &PL_vtbl_sv;
5057 case PERL_MAGIC_overload:
5058 vtable = &PL_vtbl_amagic;
5060 case PERL_MAGIC_overload_elem:
5061 vtable = &PL_vtbl_amagicelem;
5063 case PERL_MAGIC_overload_table:
5064 vtable = &PL_vtbl_ovrld;
5067 vtable = &PL_vtbl_bm;
5069 case PERL_MAGIC_regdata:
5070 vtable = &PL_vtbl_regdata;
5072 case PERL_MAGIC_regdatum:
5073 vtable = &PL_vtbl_regdatum;
5075 case PERL_MAGIC_env:
5076 vtable = &PL_vtbl_env;
5079 vtable = &PL_vtbl_fm;
5081 case PERL_MAGIC_envelem:
5082 vtable = &PL_vtbl_envelem;
5084 case PERL_MAGIC_regex_global:
5085 vtable = &PL_vtbl_mglob;
5087 case PERL_MAGIC_isa:
5088 vtable = &PL_vtbl_isa;
5090 case PERL_MAGIC_isaelem:
5091 vtable = &PL_vtbl_isaelem;
5093 case PERL_MAGIC_nkeys:
5094 vtable = &PL_vtbl_nkeys;
5096 case PERL_MAGIC_dbfile:
5099 case PERL_MAGIC_dbline:
5100 vtable = &PL_vtbl_dbline;
5102 #ifdef USE_LOCALE_COLLATE
5103 case PERL_MAGIC_collxfrm:
5104 vtable = &PL_vtbl_collxfrm;
5106 #endif /* USE_LOCALE_COLLATE */
5107 case PERL_MAGIC_tied:
5108 vtable = &PL_vtbl_pack;
5110 case PERL_MAGIC_tiedelem:
5111 case PERL_MAGIC_tiedscalar:
5112 vtable = &PL_vtbl_packelem;
5115 vtable = &PL_vtbl_regexp;
5117 case PERL_MAGIC_sig:
5118 vtable = &PL_vtbl_sig;
5120 case PERL_MAGIC_sigelem:
5121 vtable = &PL_vtbl_sigelem;
5123 case PERL_MAGIC_taint:
5124 vtable = &PL_vtbl_taint;
5126 case PERL_MAGIC_uvar:
5127 vtable = &PL_vtbl_uvar;
5129 case PERL_MAGIC_vec:
5130 vtable = &PL_vtbl_vec;
5132 case PERL_MAGIC_arylen_p:
5133 case PERL_MAGIC_rhash:
5134 case PERL_MAGIC_symtab:
5135 case PERL_MAGIC_vstring:
5138 case PERL_MAGIC_utf8:
5139 vtable = &PL_vtbl_utf8;
5141 case PERL_MAGIC_substr:
5142 vtable = &PL_vtbl_substr;
5144 case PERL_MAGIC_defelem:
5145 vtable = &PL_vtbl_defelem;
5147 case PERL_MAGIC_arylen:
5148 vtable = &PL_vtbl_arylen;
5150 case PERL_MAGIC_pos:
5151 vtable = &PL_vtbl_pos;
5153 case PERL_MAGIC_backref:
5154 vtable = &PL_vtbl_backref;
5156 case PERL_MAGIC_hintselem:
5157 vtable = &PL_vtbl_hintselem;
5159 case PERL_MAGIC_hints:
5160 vtable = &PL_vtbl_hints;
5162 case PERL_MAGIC_ext:
5163 /* Reserved for use by extensions not perl internals. */
5164 /* Useful for attaching extension internal data to perl vars. */
5165 /* Note that multiple extensions may clash if magical scalars */
5166 /* etc holding private data from one are passed to another. */
5170 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5173 /* Rest of work is done else where */
5174 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5177 case PERL_MAGIC_taint:
5180 case PERL_MAGIC_ext:
5181 case PERL_MAGIC_dbfile:
5188 =for apidoc sv_unmagic
5190 Removes all magic of type C<type> from an SV.
5196 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5201 PERL_ARGS_ASSERT_SV_UNMAGIC;
5203 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5205 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5206 for (mg = *mgp; mg; mg = *mgp) {
5207 if (mg->mg_type == type) {
5208 const MGVTBL* const vtbl = mg->mg_virtual;
5209 *mgp = mg->mg_moremagic;
5210 if (vtbl && vtbl->svt_free)
5211 vtbl->svt_free(aTHX_ sv, mg);
5212 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5214 Safefree(mg->mg_ptr);
5215 else if (mg->mg_len == HEf_SVKEY)
5216 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5217 else if (mg->mg_type == PERL_MAGIC_utf8)
5218 Safefree(mg->mg_ptr);
5220 if (mg->mg_flags & MGf_REFCOUNTED)
5221 SvREFCNT_dec(mg->mg_obj);
5225 mgp = &mg->mg_moremagic;
5228 if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
5229 mg_magical(sv); /* else fix the flags now */
5233 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5239 =for apidoc sv_rvweaken
5241 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5242 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5243 push a back-reference to this RV onto the array of backreferences
5244 associated with that magic. If the RV is magical, set magic will be
5245 called after the RV is cleared.
5251 Perl_sv_rvweaken(pTHX_ SV *const sv)
5255 PERL_ARGS_ASSERT_SV_RVWEAKEN;
5257 if (!SvOK(sv)) /* let undefs pass */
5260 Perl_croak(aTHX_ "Can't weaken a nonreference");
5261 else if (SvWEAKREF(sv)) {
5262 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5266 Perl_sv_add_backref(aTHX_ tsv, sv);
5272 /* Give tsv backref magic if it hasn't already got it, then push a
5273 * back-reference to sv onto the array associated with the backref magic.
5275 * As an optimisation, if there's only one backref and it's not an AV,
5276 * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5277 * allocate an AV. (Whether the slot holds an AV tells us whether this is
5280 * If an HV's backref is stored in magic, it is moved back to HvAUX.
5283 /* A discussion about the backreferences array and its refcount:
5285 * The AV holding the backreferences is pointed to either as the mg_obj of
5286 * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
5287 * structure, from the xhv_backreferences field. (A HV without hv_aux will
5288 * have the standard magic instead.) The array is created with a refcount
5289 * of 2. This means that if during global destruction the array gets
5290 * picked on before its parent to have its refcount decremented by the
5291 * random zapper, it won't actually be freed, meaning it's still there for
5292 * when its parent gets freed.
5294 * When the parent SV is freed, the extra ref is killed by
5295 * Perl_sv_kill_backrefs. The other ref is killed, in the case of magic,
5296 * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5298 * When a single backref SV is stored directly, it is not reference
5303 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5310 PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5312 /* find slot to store array or singleton backref */
5314 if (SvTYPE(tsv) == SVt_PVHV) {
5315 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5318 if ((mg = mg_find(tsv, PERL_MAGIC_backref))) {
5319 /* Aha. They've got it stowed in magic instead.
5320 * Move it back to xhv_backreferences */
5322 /* Stop mg_free decreasing the reference count. */
5324 /* Stop mg_free even calling the destructor, given that
5325 there's no AV to free up. */
5327 sv_unmagic(tsv, PERL_MAGIC_backref);
5333 (SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
5335 sv_magic(tsv, NULL, PERL_MAGIC_backref, NULL, 0);
5336 mg = mg_find(tsv, PERL_MAGIC_backref);
5338 svp = &(mg->mg_obj);
5341 /* create or retrieve the array */
5343 if ( (!*svp && SvTYPE(sv) == SVt_PVAV)
5344 || (*svp && SvTYPE(*svp) != SVt_PVAV)
5349 SvREFCNT_inc_simple_void(av);
5350 /* av now has a refcnt of 2; see discussion above */
5352 /* move single existing backref to the array */
5354 AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5358 mg->mg_flags |= MGf_REFCOUNTED;
5361 av = MUTABLE_AV(*svp);
5364 /* optimisation: store single backref directly in HvAUX or mg_obj */
5368 /* push new backref */
5369 assert(SvTYPE(av) == SVt_PVAV);
5370 if (AvFILLp(av) >= AvMAX(av)) {
5371 av_extend(av, AvFILLp(av)+1);
5373 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5376 /* delete a back-reference to ourselves from the backref magic associated
5377 * with the SV we point to.
5381 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5387 PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5389 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5390 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5392 if (!svp || !*svp) {
5394 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5395 svp = mg ? &(mg->mg_obj) : NULL;
5399 Perl_croak(aTHX_ "panic: del_backref");
5401 if (SvTYPE(*svp) == SVt_PVAV) {
5403 AV * const av = (AV*)*svp;
5404 assert(!SvIS_FREED(av));
5406 for (i = AvFILLp(av); i >= 0; i--) {
5408 const SSize_t fill = AvFILLp(av);
5410 /* We weren't the last entry.
5411 An unordered list has this property that you can take the
5412 last element off the end to fill the hole, and it's still
5413 an unordered list :-)
5418 AvFILLp(av) = fill - 1;
5421 break; /* should only be one */
5428 /* optimisation: only a single backref, stored directly */
5430 Perl_croak(aTHX_ "panic: del_backref");
5437 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5443 PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5448 is_array = (SvTYPE(av) == SVt_PVAV);
5450 assert(!SvIS_FREED(av));
5453 last = svp + AvFILLp(av);
5456 /* optimisation: only a single backref, stored directly */
5462 while (svp <= last) {
5464 SV *const referrer = *svp;
5465 if (SvWEAKREF(referrer)) {
5466 /* XXX Should we check that it hasn't changed? */
5467 assert(SvROK(referrer));
5468 SvRV_set(referrer, 0);
5470 SvWEAKREF_off(referrer);
5471 SvSETMAGIC(referrer);
5472 } else if (SvTYPE(referrer) == SVt_PVGV ||
5473 SvTYPE(referrer) == SVt_PVLV) {
5474 assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
5475 /* You lookin' at me? */
5476 assert(GvSTASH(referrer));
5477 assert(GvSTASH(referrer) == (const HV *)sv);
5478 GvSTASH(referrer) = 0;
5479 } else if (SvTYPE(referrer) == SVt_PVCV ||
5480 SvTYPE(referrer) == SVt_PVFM) {
5481 if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
5482 /* You lookin' at me? */
5483 assert(CvSTASH(referrer));
5484 assert(CvSTASH(referrer) == (const HV *)sv);
5485 CvSTASH(referrer) = 0;
5488 assert(SvTYPE(sv) == SVt_PVGV);
5489 /* You lookin' at me? */
5490 assert(CvGV(referrer));
5491 assert(CvGV(referrer) == (const GV *)sv);
5492 anonymise_cv_maybe(MUTABLE_GV(sv),
5493 MUTABLE_CV(referrer));
5498 "panic: magic_killbackrefs (flags=%"UVxf")",
5499 (UV)SvFLAGS(referrer));
5510 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5516 =for apidoc sv_insert
5518 Inserts a string at the specified offset/length within the SV. Similar to
5519 the Perl substr() function. Handles get magic.
5521 =for apidoc sv_insert_flags
5523 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5529 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5534 register char *midend;
5535 register char *bigend;
5539 PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5542 Perl_croak(aTHX_ "Can't modify non-existent substring");
5543 SvPV_force_flags(bigstr, curlen, flags);
5544 (void)SvPOK_only_UTF8(bigstr);
5545 if (offset + len > curlen) {
5546 SvGROW(bigstr, offset+len+1);
5547 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5548 SvCUR_set(bigstr, offset+len);
5552 i = littlelen - len;
5553 if (i > 0) { /* string might grow */
5554 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5555 mid = big + offset + len;
5556 midend = bigend = big + SvCUR(bigstr);
5559 while (midend > mid) /* shove everything down */
5560 *--bigend = *--midend;
5561 Move(little,big+offset,littlelen,char);
5562 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5567 Move(little,SvPVX(bigstr)+offset,len,char);
5572 big = SvPVX(bigstr);
5575 bigend = big + SvCUR(bigstr);
5577 if (midend > bigend)
5578 Perl_croak(aTHX_ "panic: sv_insert");
5580 if (mid - big > bigend - midend) { /* faster to shorten from end */
5582 Move(little, mid, littlelen,char);
5585 i = bigend - midend;
5587 Move(midend, mid, i,char);
5591 SvCUR_set(bigstr, mid - big);
5593 else if ((i = mid - big)) { /* faster from front */
5594 midend -= littlelen;
5596 Move(big, midend - i, i, char);
5597 sv_chop(bigstr,midend-i);
5599 Move(little, mid, littlelen,char);
5601 else if (littlelen) {
5602 midend -= littlelen;
5603 sv_chop(bigstr,midend);
5604 Move(little,midend,littlelen,char);
5607 sv_chop(bigstr,midend);
5613 =for apidoc sv_replace
5615 Make the first argument a copy of the second, then delete the original.
5616 The target SV physically takes over ownership of the body of the source SV
5617 and inherits its flags; however, the target keeps any magic it owns,
5618 and any magic in the source is discarded.
5619 Note that this is a rather specialist SV copying operation; most of the
5620 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5626 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5629 const U32 refcnt = SvREFCNT(sv);
5631 PERL_ARGS_ASSERT_SV_REPLACE;
5633 SV_CHECK_THINKFIRST_COW_DROP(sv);
5634 if (SvREFCNT(nsv) != 1) {
5635 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
5636 " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
5638 if (SvMAGICAL(sv)) {
5642 sv_upgrade(nsv, SVt_PVMG);
5643 SvMAGIC_set(nsv, SvMAGIC(sv));
5644 SvFLAGS(nsv) |= SvMAGICAL(sv);
5646 SvMAGIC_set(sv, NULL);
5650 assert(!SvREFCNT(sv));
5651 #ifdef DEBUG_LEAKING_SCALARS
5652 sv->sv_flags = nsv->sv_flags;
5653 sv->sv_any = nsv->sv_any;
5654 sv->sv_refcnt = nsv->sv_refcnt;
5655 sv->sv_u = nsv->sv_u;
5657 StructCopy(nsv,sv,SV);
5659 if(SvTYPE(sv) == SVt_IV) {
5661 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5665 #ifdef PERL_OLD_COPY_ON_WRITE
5666 if (SvIsCOW_normal(nsv)) {
5667 /* We need to follow the pointers around the loop to make the
5668 previous SV point to sv, rather than nsv. */
5671 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5674 assert(SvPVX_const(current) == SvPVX_const(nsv));
5676 /* Make the SV before us point to the SV after us. */
5678 PerlIO_printf(Perl_debug_log, "previous is\n");
5680 PerlIO_printf(Perl_debug_log,
5681 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5682 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5684 SV_COW_NEXT_SV_SET(current, sv);
5687 SvREFCNT(sv) = refcnt;
5688 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5693 /* We're about to free a GV which has a CV that refers back to us.
5694 * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
5698 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
5704 PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
5707 assert(SvREFCNT(gv) == 0);
5708 assert(isGV(gv) && isGV_with_GP(gv));
5710 assert(!CvANON(cv));
5711 assert(CvGV(cv) == gv);
5713 /* will the CV shortly be freed by gp_free() ? */
5714 if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
5715 SvANY(cv)->xcv_gv = NULL;
5719 /* if not, anonymise: */
5720 stash = GvSTASH(gv) ? HvNAME(GvSTASH(gv)) : NULL;
5721 gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
5722 stash ? stash : "__ANON__");
5723 anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
5724 SvREFCNT_dec(gvname);
5728 SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
5733 =for apidoc sv_clear
5735 Clear an SV: call any destructors, free up any memory used by the body,
5736 and free the body itself. The SV's head is I<not> freed, although
5737 its type is set to all 1's so that it won't inadvertently be assumed
5738 to be live during global destruction etc.
5739 This function should only be called when REFCNT is zero. Most of the time
5740 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5747 Perl_sv_clear(pTHX_ register SV *const sv)
5750 const U32 type = SvTYPE(sv);
5751 const struct body_details *const sv_type_details
5752 = bodies_by_type + type;
5755 PERL_ARGS_ASSERT_SV_CLEAR;
5756 assert(SvREFCNT(sv) == 0);
5757 assert(SvTYPE(sv) != SVTYPEMASK);
5759 if (type <= SVt_IV) {
5760 /* See the comment in sv.h about the collusion between this early
5761 return and the overloading of the NULL slots in the size table. */
5764 SvFLAGS(sv) &= SVf_BREAK;
5765 SvFLAGS(sv) |= SVTYPEMASK;
5770 if (PL_defstash && /* Still have a symbol table? */
5777 stash = SvSTASH(sv);
5778 destructor = StashHANDLER(stash,DESTROY);
5780 /* A constant subroutine can have no side effects, so
5781 don't bother calling it. */
5782 && !CvCONST(destructor)
5783 /* Don't bother calling an empty destructor */
5784 && (CvISXSUB(destructor)
5785 || (CvSTART(destructor)
5786 && (CvSTART(destructor)->op_next->op_type != OP_LEAVESUB))))
5788 SV* const tmpref = newRV(sv);
5789 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5791 PUSHSTACKi(PERLSI_DESTROY);
5796 call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5802 if(SvREFCNT(tmpref) < 2) {
5803 /* tmpref is not kept alive! */
5805 SvRV_set(tmpref, NULL);
5808 SvREFCNT_dec(tmpref);
5810 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5814 if (PL_in_clean_objs)
5815 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5817 /* DESTROY gave object new lease on life */
5823 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5824 SvOBJECT_off(sv); /* Curse the object. */
5825 if (type != SVt_PVIO)
5826 --PL_sv_objcount; /* XXX Might want something more general */
5829 if (type >= SVt_PVMG) {
5830 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
5831 SvREFCNT_dec(SvOURSTASH(sv));
5832 } else if (SvMAGIC(sv))
5834 if (type == SVt_PVMG && SvPAD_TYPED(sv))
5835 SvREFCNT_dec(SvSTASH(sv));
5838 /* case SVt_BIND: */
5841 IoIFP(sv) != PerlIO_stdin() &&
5842 IoIFP(sv) != PerlIO_stdout() &&
5843 IoIFP(sv) != PerlIO_stderr() &&
5844 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5846 io_close(MUTABLE_IO(sv), FALSE);
5848 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5849 PerlDir_close(IoDIRP(sv));
5850 IoDIRP(sv) = (DIR*)NULL;
5851 Safefree(IoTOP_NAME(sv));
5852 Safefree(IoFMT_NAME(sv));
5853 Safefree(IoBOTTOM_NAME(sv));
5856 /* FIXME for plugins */
5857 pregfree2((REGEXP*) sv);
5861 cv_undef(MUTABLE_CV(sv));
5862 /* If we're in a stash, we don't own a reference to it. However it does
5863 have a back reference to us, which needs to be cleared. */
5864 if ((stash = CvSTASH(sv)))
5865 sv_del_backref(MUTABLE_SV(stash), sv);
5868 if (PL_last_swash_hv == (const HV *)sv) {
5869 PL_last_swash_hv = NULL;
5871 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
5872 hv_undef(MUTABLE_HV(sv));
5875 if (PL_comppad == MUTABLE_AV(sv)) {
5879 av_undef(MUTABLE_AV(sv));
5882 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5883 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5884 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5885 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5887 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5888 SvREFCNT_dec(LvTARG(sv));
5890 if (isGV_with_GP(sv)) {
5891 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
5892 && HvNAME_get(stash))
5893 mro_method_changed_in(stash);
5894 gp_free(MUTABLE_GV(sv));
5896 unshare_hek(GvNAME_HEK(sv));
5897 /* If we're in a stash, we don't own a reference to it. However it does
5898 have a back reference to us, which needs to be cleared. */
5899 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
5900 sv_del_backref(MUTABLE_SV(stash), sv);
5902 /* FIXME. There are probably more unreferenced pointers to SVs in the
5903 interpreter struct that we should check and tidy in a similar
5905 if ((const GV *)sv == PL_last_in_gv)
5906 PL_last_in_gv = NULL;
5912 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5915 SvOOK_offset(sv, offset);
5916 SvPV_set(sv, SvPVX_mutable(sv) - offset);
5917 /* Don't even bother with turning off the OOK flag. */
5922 SV * const target = SvRV(sv);
5924 sv_del_backref(target, sv);
5926 SvREFCNT_dec(target);
5929 #ifdef PERL_OLD_COPY_ON_WRITE
5930 else if (SvPVX_const(sv)
5931 && !(SvTYPE(sv) == SVt_PVIO && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) {
5934 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5938 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
5940 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5944 } else if (SvLEN(sv)) {
5945 Safefree(SvPVX_const(sv));
5949 else if (SvPVX_const(sv) && SvLEN(sv)
5950 && !(SvTYPE(sv) == SVt_PVIO && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
5951 Safefree(SvPVX_mutable(sv));
5952 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5953 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5962 SvFLAGS(sv) &= SVf_BREAK;
5963 SvFLAGS(sv) |= SVTYPEMASK;
5965 if (sv_type_details->arena) {
5966 del_body(((char *)SvANY(sv) + sv_type_details->offset),
5967 &PL_body_roots[type]);
5969 else if (sv_type_details->body_size) {
5970 safefree(SvANY(sv));
5975 =for apidoc sv_newref
5977 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5984 Perl_sv_newref(pTHX_ SV *const sv)
5986 PERL_UNUSED_CONTEXT;
5995 Decrement an SV's reference count, and if it drops to zero, call
5996 C<sv_clear> to invoke destructors and free up any memory used by
5997 the body; finally, deallocate the SV's head itself.
5998 Normally called via a wrapper macro C<SvREFCNT_dec>.
6004 Perl_sv_free(pTHX_ SV *const sv)
6009 if (SvREFCNT(sv) == 0) {
6010 if (SvFLAGS(sv) & SVf_BREAK)
6011 /* this SV's refcnt has been artificially decremented to
6012 * trigger cleanup */
6014 if (PL_in_clean_all) /* All is fair */
6016 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6017 /* make sure SvREFCNT(sv)==0 happens very seldom */
6018 SvREFCNT(sv) = (~(U32)0)/2;
6021 if (ckWARN_d(WARN_INTERNAL)) {
6022 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
6023 Perl_dump_sv_child(aTHX_ sv);
6025 #ifdef DEBUG_LEAKING_SCALARS
6028 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6029 if (PL_warnhook == PERL_WARNHOOK_FATAL
6030 || ckDEAD(packWARN(WARN_INTERNAL))) {
6031 /* Don't let Perl_warner cause us to escape our fate: */
6035 /* This may not return: */
6036 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6037 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6038 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6041 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6046 if (--(SvREFCNT(sv)) > 0)
6048 Perl_sv_free2(aTHX_ sv);
6052 Perl_sv_free2(pTHX_ SV *const sv)
6056 PERL_ARGS_ASSERT_SV_FREE2;
6060 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6061 "Attempt to free temp prematurely: SV 0x%"UVxf
6062 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6066 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6067 /* make sure SvREFCNT(sv)==0 happens very seldom */
6068 SvREFCNT(sv) = (~(U32)0)/2;
6079 Returns the length of the string in the SV. Handles magic and type
6080 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6086 Perl_sv_len(pTHX_ register SV *const sv)
6094 len = mg_length(sv);
6096 (void)SvPV_const(sv, len);
6101 =for apidoc sv_len_utf8
6103 Returns the number of characters in the string in an SV, counting wide
6104 UTF-8 bytes as a single character. Handles magic and type coercion.
6110 * The length is cached in PERL_MAGIC_utf8, in the mg_len field. Also the
6111 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6112 * (Note that the mg_len is not the length of the mg_ptr field.
6113 * This allows the cache to store the character length of the string without
6114 * needing to malloc() extra storage to attach to the mg_ptr.)
6119 Perl_sv_len_utf8(pTHX_ register SV *const sv)
6125 return mg_length(sv);
6129 const U8 *s = (U8*)SvPV_const(sv, len);
6133 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6135 if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
6136 if (mg->mg_len != -1)
6139 /* We can use the offset cache for a headstart.
6140 The longer value is stored in the first pair. */
6141 STRLEN *cache = (STRLEN *) mg->mg_ptr;
6143 ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
6147 if (PL_utf8cache < 0) {
6148 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6149 assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
6153 ulen = Perl_utf8_length(aTHX_ s, s + len);
6154 utf8_mg_len_cache_update(sv, &mg, ulen);
6158 return Perl_utf8_length(aTHX_ s, s + len);
6162 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6165 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6166 STRLEN *const uoffset_p, bool *const at_end)
6168 const U8 *s = start;
6169 STRLEN uoffset = *uoffset_p;
6171 PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6173 while (s < send && uoffset) {
6180 else if (s > send) {
6182 /* This is the existing behaviour. Possibly it should be a croak, as
6183 it's actually a bounds error */
6186 *uoffset_p -= uoffset;
6190 /* Given the length of the string in both bytes and UTF-8 characters, decide
6191 whether to walk forwards or backwards to find the byte corresponding to
6192 the passed in UTF-8 offset. */
6194 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6195 STRLEN uoffset, const STRLEN uend)
6197 STRLEN backw = uend - uoffset;
6199 PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6201 if (uoffset < 2 * backw) {
6202 /* The assumption is that going forwards is twice the speed of going
6203 forward (that's where the 2 * backw comes from).
6204 (The real figure of course depends on the UTF-8 data.) */
6205 const U8 *s = start;
6207 while (s < send && uoffset--)
6217 while (UTF8_IS_CONTINUATION(*send))
6220 return send - start;
6223 /* For the string representation of the given scalar, find the byte
6224 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
6225 give another position in the string, *before* the sought offset, which
6226 (which is always true, as 0, 0 is a valid pair of positions), which should
6227 help reduce the amount of linear searching.
6228 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6229 will be used to reduce the amount of linear searching. The cache will be
6230 created if necessary, and the found value offered to it for update. */
6232 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6233 const U8 *const send, STRLEN uoffset,
6234 STRLEN uoffset0, STRLEN boffset0)
6236 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
6238 bool at_end = FALSE;
6240 PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6242 assert (uoffset >= uoffset0);
6249 && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
6250 (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
6251 if ((*mgp)->mg_ptr) {
6252 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6253 if (cache[0] == uoffset) {
6254 /* An exact match. */
6257 if (cache[2] == uoffset) {
6258 /* An exact match. */
6262 if (cache[0] < uoffset) {
6263 /* The cache already knows part of the way. */
6264 if (cache[0] > uoffset0) {
6265 /* The cache knows more than the passed in pair */
6266 uoffset0 = cache[0];
6267 boffset0 = cache[1];
6269 if ((*mgp)->mg_len != -1) {
6270 /* And we know the end too. */
6272 + sv_pos_u2b_midway(start + boffset0, send,
6274 (*mgp)->mg_len - uoffset0);
6276 uoffset -= uoffset0;
6278 + sv_pos_u2b_forwards(start + boffset0,
6279 send, &uoffset, &at_end);
6280 uoffset += uoffset0;
6283 else if (cache[2] < uoffset) {
6284 /* We're between the two cache entries. */
6285 if (cache[2] > uoffset0) {
6286 /* and the cache knows more than the passed in pair */
6287 uoffset0 = cache[2];
6288 boffset0 = cache[3];
6292 + sv_pos_u2b_midway(start + boffset0,
6295 cache[0] - uoffset0);
6298 + sv_pos_u2b_midway(start + boffset0,
6301 cache[2] - uoffset0);
6305 else if ((*mgp)->mg_len != -1) {
6306 /* If we can take advantage of a passed in offset, do so. */
6307 /* In fact, offset0 is either 0, or less than offset, so don't
6308 need to worry about the other possibility. */
6310 + sv_pos_u2b_midway(start + boffset0, send,
6312 (*mgp)->mg_len - uoffset0);
6317 if (!found || PL_utf8cache < 0) {
6318 STRLEN real_boffset;
6319 uoffset -= uoffset0;
6320 real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6321 send, &uoffset, &at_end);
6322 uoffset += uoffset0;
6324 if (found && PL_utf8cache < 0)
6325 assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
6327 boffset = real_boffset;
6332 utf8_mg_len_cache_update(sv, mgp, uoffset);
6334 utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6341 =for apidoc sv_pos_u2b_flags
6343 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6344 the start of the string, to a count of the equivalent number of bytes; if
6345 lenp is non-zero, it does the same to lenp, but this time starting from
6346 the offset, rather than from the start of the string. Handles type coercion.
6347 I<flags> is passed to C<SvPV_flags>, and usually should be
6348 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
6354 * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
6355 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6356 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6361 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
6368 PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
6370 start = (U8*)SvPV_flags(sv, len, flags);
6372 const U8 * const send = start + len;
6374 boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
6377 && *lenp /* don't bother doing work for 0, as its bytes equivalent
6378 is 0, and *lenp is already set to that. */) {
6379 /* Convert the relative offset to absolute. */
6380 const STRLEN uoffset2 = uoffset + *lenp;
6381 const STRLEN boffset2
6382 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6383 uoffset, boffset) - boffset;
6397 =for apidoc sv_pos_u2b
6399 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6400 the start of the string, to a count of the equivalent number of bytes; if
6401 lenp is non-zero, it does the same to lenp, but this time starting from
6402 the offset, rather than from the start of the string. Handles magic and
6405 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
6412 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6413 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6414 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6418 /* This function is subject to size and sign problems */
6421 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6423 PERL_ARGS_ASSERT_SV_POS_U2B;
6426 STRLEN ulen = (STRLEN)*lenp;
6427 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
6428 SV_GMAGIC|SV_CONST_RETURN);
6431 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
6432 SV_GMAGIC|SV_CONST_RETURN);
6437 S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
6440 PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
6444 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6445 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6446 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
6450 (*mgp)->mg_len = ulen;
6451 /* For now, treat "overflowed" as "still unknown". See RT #72924. */
6452 if (ulen != (STRLEN) (*mgp)->mg_len)
6453 (*mgp)->mg_len = -1;
6456 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6457 byte length pairing. The (byte) length of the total SV is passed in too,
6458 as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6459 may not have updated SvCUR, so we can't rely on reading it directly.
6461 The proffered utf8/byte length pairing isn't used if the cache already has
6462 two pairs, and swapping either for the proffered pair would increase the
6463 RMS of the intervals between known byte offsets.
6465 The cache itself consists of 4 STRLEN values
6466 0: larger UTF-8 offset
6467 1: corresponding byte offset
6468 2: smaller UTF-8 offset
6469 3: corresponding byte offset
6471 Unused cache pairs have the value 0, 0.
6472 Keeping the cache "backwards" means that the invariant of
6473 cache[0] >= cache[2] is maintained even with empty slots, which means that
6474 the code that uses it doesn't need to worry if only 1 entry has actually
6475 been set to non-zero. It also makes the "position beyond the end of the
6476 cache" logic much simpler, as the first slot is always the one to start
6480 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6481 const STRLEN utf8, const STRLEN blen)
6485 PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6490 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6491 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6492 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6494 (*mgp)->mg_len = -1;
6498 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6499 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6500 (*mgp)->mg_ptr = (char *) cache;
6504 if (PL_utf8cache < 0 && SvPOKp(sv)) {
6505 /* SvPOKp() because it's possible that sv has string overloading, and
6506 therefore is a reference, hence SvPVX() is actually a pointer.
6507 This cures the (very real) symptoms of RT 69422, but I'm not actually
6508 sure whether we should even be caching the results of UTF-8
6509 operations on overloading, given that nothing stops overloading
6510 returning a different value every time it's called. */
6511 const U8 *start = (const U8 *) SvPVX_const(sv);
6512 const STRLEN realutf8 = utf8_length(start, start + byte);
6514 assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
6518 /* Cache is held with the later position first, to simplify the code
6519 that deals with unbounded ends. */
6521 ASSERT_UTF8_CACHE(cache);
6522 if (cache[1] == 0) {
6523 /* Cache is totally empty */
6526 } else if (cache[3] == 0) {
6527 if (byte > cache[1]) {
6528 /* New one is larger, so goes first. */
6529 cache[2] = cache[0];
6530 cache[3] = cache[1];
6538 #define THREEWAY_SQUARE(a,b,c,d) \
6539 ((float)((d) - (c))) * ((float)((d) - (c))) \
6540 + ((float)((c) - (b))) * ((float)((c) - (b))) \
6541 + ((float)((b) - (a))) * ((float)((b) - (a)))
6543 /* Cache has 2 slots in use, and we know three potential pairs.
6544 Keep the two that give the lowest RMS distance. Do the
6545 calcualation in bytes simply because we always know the byte
6546 length. squareroot has the same ordering as the positive value,
6547 so don't bother with the actual square root. */
6548 const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6549 if (byte > cache[1]) {
6550 /* New position is after the existing pair of pairs. */
6551 const float keep_earlier
6552 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6553 const float keep_later
6554 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6556 if (keep_later < keep_earlier) {
6557 if (keep_later < existing) {
6558 cache[2] = cache[0];
6559 cache[3] = cache[1];
6565 if (keep_earlier < existing) {
6571 else if (byte > cache[3]) {
6572 /* New position is between the existing pair of pairs. */
6573 const float keep_earlier
6574 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6575 const float keep_later
6576 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6578 if (keep_later < keep_earlier) {
6579 if (keep_later < existing) {
6585 if (keep_earlier < existing) {
6592 /* New position is before the existing pair of pairs. */
6593 const float keep_earlier
6594 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6595 const float keep_later
6596 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6598 if (keep_later < keep_earlier) {
6599 if (keep_later < existing) {
6605 if (keep_earlier < existing) {
6606 cache[0] = cache[2];
6607 cache[1] = cache[3];
6614 ASSERT_UTF8_CACHE(cache);
6617 /* We already know all of the way, now we may be able to walk back. The same
6618 assumption is made as in S_sv_pos_u2b_midway(), namely that walking
6619 backward is half the speed of walking forward. */
6621 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
6622 const U8 *end, STRLEN endu)
6624 const STRLEN forw = target - s;
6625 STRLEN backw = end - target;
6627 PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
6629 if (forw < 2 * backw) {
6630 return utf8_length(s, target);
6633 while (end > target) {
6635 while (UTF8_IS_CONTINUATION(*end)) {
6644 =for apidoc sv_pos_b2u
6646 Converts the value pointed to by offsetp from a count of bytes from the
6647 start of the string, to a count of the equivalent number of UTF-8 chars.
6648 Handles magic and type coercion.
6654 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6655 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6660 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
6663 const STRLEN byte = *offsetp;
6664 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
6670 PERL_ARGS_ASSERT_SV_POS_B2U;
6675 s = (const U8*)SvPV_const(sv, blen);
6678 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6684 && SvTYPE(sv) >= SVt_PVMG
6685 && (mg = mg_find(sv, PERL_MAGIC_utf8)))
6688 STRLEN * const cache = (STRLEN *) mg->mg_ptr;
6689 if (cache[1] == byte) {
6690 /* An exact match. */
6691 *offsetp = cache[0];
6694 if (cache[3] == byte) {
6695 /* An exact match. */
6696 *offsetp = cache[2];
6700 if (cache[1] < byte) {
6701 /* We already know part of the way. */
6702 if (mg->mg_len != -1) {
6703 /* Actually, we know the end too. */
6705 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
6706 s + blen, mg->mg_len - cache[0]);
6708 len = cache[0] + utf8_length(s + cache[1], send);
6711 else if (cache[3] < byte) {
6712 /* We're between the two cached pairs, so we do the calculation
6713 offset by the byte/utf-8 positions for the earlier pair,
6714 then add the utf-8 characters from the string start to
6716 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
6717 s + cache[1], cache[0] - cache[2])
6721 else { /* cache[3] > byte */
6722 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
6726 ASSERT_UTF8_CACHE(cache);
6728 } else if (mg->mg_len != -1) {
6729 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
6733 if (!found || PL_utf8cache < 0) {
6734 const STRLEN real_len = utf8_length(s, send);
6736 if (found && PL_utf8cache < 0)
6737 assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
6744 utf8_mg_len_cache_update(sv, &mg, len);
6746 utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
6751 S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
6752 STRLEN real, SV *const sv)
6754 PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
6756 /* As this is debugging only code, save space by keeping this test here,
6757 rather than inlining it in all the callers. */
6758 if (from_cache == real)
6761 /* Need to turn the assertions off otherwise we may recurse infinitely
6762 while printing error messages. */
6763 SAVEI8(PL_utf8cache);
6765 Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
6766 func, (UV) from_cache, (UV) real, SVfARG(sv));
6772 Returns a boolean indicating whether the strings in the two SVs are
6773 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6774 coerce its args to strings if necessary.
6780 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6789 SV* svrecode = NULL;
6796 /* if pv1 and pv2 are the same, second SvPV_const call may
6797 * invalidate pv1, so we may need to make a copy */
6798 if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
6799 pv1 = SvPV_const(sv1, cur1);
6800 sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
6802 pv1 = SvPV_const(sv1, cur1);
6810 pv2 = SvPV_const(sv2, cur2);
6812 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6813 /* Differing utf8ness.
6814 * Do not UTF8size the comparands as a side-effect. */
6817 svrecode = newSVpvn(pv2, cur2);
6818 sv_recode_to_utf8(svrecode, PL_encoding);
6819 pv2 = SvPV_const(svrecode, cur2);
6822 svrecode = newSVpvn(pv1, cur1);
6823 sv_recode_to_utf8(svrecode, PL_encoding);
6824 pv1 = SvPV_const(svrecode, cur1);
6826 /* Now both are in UTF-8. */
6828 SvREFCNT_dec(svrecode);
6833 bool is_utf8 = TRUE;
6836 /* sv1 is the UTF-8 one,
6837 * if is equal it must be downgrade-able */
6838 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6844 /* sv2 is the UTF-8 one,
6845 * if is equal it must be downgrade-able */
6846 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6852 /* Downgrade not possible - cannot be eq */
6860 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6862 SvREFCNT_dec(svrecode);
6872 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6873 string in C<sv1> is less than, equal to, or greater than the string in
6874 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6875 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6881 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
6885 const char *pv1, *pv2;
6888 SV *svrecode = NULL;
6895 pv1 = SvPV_const(sv1, cur1);
6902 pv2 = SvPV_const(sv2, cur2);
6904 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6905 /* Differing utf8ness.
6906 * Do not UTF8size the comparands as a side-effect. */
6909 svrecode = newSVpvn(pv2, cur2);
6910 sv_recode_to_utf8(svrecode, PL_encoding);
6911 pv2 = SvPV_const(svrecode, cur2);
6914 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6919 svrecode = newSVpvn(pv1, cur1);
6920 sv_recode_to_utf8(svrecode, PL_encoding);
6921 pv1 = SvPV_const(svrecode, cur1);
6924 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6930 cmp = cur2 ? -1 : 0;
6934 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6937 cmp = retval < 0 ? -1 : 1;
6938 } else if (cur1 == cur2) {
6941 cmp = cur1 < cur2 ? -1 : 1;
6945 SvREFCNT_dec(svrecode);
6953 =for apidoc sv_cmp_locale
6955 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6956 'use bytes' aware, handles get magic, and will coerce its args to strings
6957 if necessary. See also C<sv_cmp>.
6963 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
6966 #ifdef USE_LOCALE_COLLATE
6972 if (PL_collation_standard)
6976 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6978 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6980 if (!pv1 || !len1) {
6991 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6994 return retval < 0 ? -1 : 1;
6997 * When the result of collation is equality, that doesn't mean
6998 * that there are no differences -- some locales exclude some
6999 * characters from consideration. So to avoid false equalities,
7000 * we use the raw string as a tiebreaker.
7006 #endif /* USE_LOCALE_COLLATE */
7008 return sv_cmp(sv1, sv2);
7012 #ifdef USE_LOCALE_COLLATE
7015 =for apidoc sv_collxfrm
7017 Add Collate Transform magic to an SV if it doesn't already have it.
7019 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
7020 scalar data of the variable, but transformed to such a format that a normal
7021 memory comparison can be used to compare the data according to the locale
7028 Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
7033 PERL_ARGS_ASSERT_SV_COLLXFRM;
7035 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
7036 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
7042 Safefree(mg->mg_ptr);
7043 s = SvPV_const(sv, len);
7044 if ((xf = mem_collxfrm(s, len, &xlen))) {
7046 #ifdef PERL_OLD_COPY_ON_WRITE
7048 sv_force_normal_flags(sv, 0);
7050 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
7064 if (mg && mg->mg_ptr) {
7066 return mg->mg_ptr + sizeof(PL_collation_ix);
7074 #endif /* USE_LOCALE_COLLATE */
7079 Get a line from the filehandle and store it into the SV, optionally
7080 appending to the currently-stored string.
7086 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
7091 register STDCHAR rslast;
7092 register STDCHAR *bp;
7097 PERL_ARGS_ASSERT_SV_GETS;
7099 if (SvTHINKFIRST(sv))
7100 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
7101 /* XXX. If you make this PVIV, then copy on write can copy scalars read
7103 However, perlbench says it's slower, because the existing swipe code
7104 is faster than copy on write.
7105 Swings and roundabouts. */
7106 SvUPGRADE(sv, SVt_PV);
7111 if (PerlIO_isutf8(fp)) {
7113 sv_utf8_upgrade_nomg(sv);
7114 sv_pos_u2b(sv,&append,0);
7116 } else if (SvUTF8(sv)) {
7117 SV * const tsv = newSV(0);
7118 sv_gets(tsv, fp, 0);
7119 sv_utf8_upgrade_nomg(tsv);
7120 SvCUR_set(sv,append);
7123 goto return_string_or_null;
7131 if (PerlIO_isutf8(fp))
7134 if (IN_PERL_COMPILETIME) {
7135 /* we always read code in line mode */
7139 else if (RsSNARF(PL_rs)) {
7140 /* If it is a regular disk file use size from stat() as estimate
7141 of amount we are going to read -- may result in mallocing
7142 more memory than we really need if the layers below reduce
7143 the size we read (e.g. CRLF or a gzip layer).
7146 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
7147 const Off_t offset = PerlIO_tell(fp);
7148 if (offset != (Off_t) -1 && st.st_size + append > offset) {
7149 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7155 else if (RsRECORD(PL_rs)) {
7163 /* Grab the size of the record we're getting */
7164 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7165 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7168 /* VMS wants read instead of fread, because fread doesn't respect */
7169 /* RMS record boundaries. This is not necessarily a good thing to be */
7170 /* doing, but we've got no other real choice - except avoid stdio
7171 as implementation - perhaps write a :vms layer ?
7173 fd = PerlIO_fileno(fp);
7174 if (fd == -1) { /* in-memory file from PerlIO::Scalar */
7175 bytesread = PerlIO_read(fp, buffer, recsize);
7178 bytesread = PerlLIO_read(fd, buffer, recsize);
7181 bytesread = PerlIO_read(fp, buffer, recsize);
7185 SvCUR_set(sv, bytesread + append);
7186 buffer[bytesread] = '\0';
7187 goto return_string_or_null;
7189 else if (RsPARA(PL_rs)) {
7195 /* Get $/ i.e. PL_rs into same encoding as stream wants */
7196 if (PerlIO_isutf8(fp)) {
7197 rsptr = SvPVutf8(PL_rs, rslen);
7200 if (SvUTF8(PL_rs)) {
7201 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7202 Perl_croak(aTHX_ "Wide character in $/");
7205 rsptr = SvPV_const(PL_rs, rslen);
7209 rslast = rslen ? rsptr[rslen - 1] : '\0';
7211 if (rspara) { /* have to do this both before and after */
7212 do { /* to make sure file boundaries work right */
7215 i = PerlIO_getc(fp);
7219 PerlIO_ungetc(fp,i);
7225 /* See if we know enough about I/O mechanism to cheat it ! */
7227 /* This used to be #ifdef test - it is made run-time test for ease
7228 of abstracting out stdio interface. One call should be cheap
7229 enough here - and may even be a macro allowing compile
7233 if (PerlIO_fast_gets(fp)) {
7236 * We're going to steal some values from the stdio struct
7237 * and put EVERYTHING in the innermost loop into registers.
7239 register STDCHAR *ptr;
7243 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7244 /* An ungetc()d char is handled separately from the regular
7245 * buffer, so we getc() it back out and stuff it in the buffer.
7247 i = PerlIO_getc(fp);
7248 if (i == EOF) return 0;
7249 *(--((*fp)->_ptr)) = (unsigned char) i;
7253 /* Here is some breathtakingly efficient cheating */
7255 cnt = PerlIO_get_cnt(fp); /* get count into register */
7256 /* make sure we have the room */
7257 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7258 /* Not room for all of it
7259 if we are looking for a separator and room for some
7261 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7262 /* just process what we have room for */
7263 shortbuffered = cnt - SvLEN(sv) + append + 1;
7264 cnt -= shortbuffered;
7268 /* remember that cnt can be negative */
7269 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7274 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
7275 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7276 DEBUG_P(PerlIO_printf(Perl_debug_log,
7277 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7278 DEBUG_P(PerlIO_printf(Perl_debug_log,
7279 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7280 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7281 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7286 while (cnt > 0) { /* this | eat */
7288 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7289 goto thats_all_folks; /* screams | sed :-) */
7293 Copy(ptr, bp, cnt, char); /* this | eat */
7294 bp += cnt; /* screams | dust */
7295 ptr += cnt; /* louder | sed :-) */
7300 if (shortbuffered) { /* oh well, must extend */
7301 cnt = shortbuffered;
7303 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7305 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7306 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7310 DEBUG_P(PerlIO_printf(Perl_debug_log,
7311 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7312 PTR2UV(ptr),(long)cnt));
7313 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7315 DEBUG_P(PerlIO_printf(Perl_debug_log,
7316 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7317 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7318 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7320 /* This used to call 'filbuf' in stdio form, but as that behaves like
7321 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7322 another abstraction. */
7323 i = PerlIO_getc(fp); /* get more characters */
7325 DEBUG_P(PerlIO_printf(Perl_debug_log,
7326 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7327 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7328 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7330 cnt = PerlIO_get_cnt(fp);
7331 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7332 DEBUG_P(PerlIO_printf(Perl_debug_log,
7333 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7335 if (i == EOF) /* all done for ever? */
7336 goto thats_really_all_folks;
7338 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7340 SvGROW(sv, bpx + cnt + 2);
7341 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7343 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7345 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7346 goto thats_all_folks;
7350 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7351 memNE((char*)bp - rslen, rsptr, rslen))
7352 goto screamer; /* go back to the fray */
7353 thats_really_all_folks:
7355 cnt += shortbuffered;
7356 DEBUG_P(PerlIO_printf(Perl_debug_log,
7357 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7358 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7359 DEBUG_P(PerlIO_printf(Perl_debug_log,
7360 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7361 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7362 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7364 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
7365 DEBUG_P(PerlIO_printf(Perl_debug_log,
7366 "Screamer: done, len=%ld, string=|%.*s|\n",
7367 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7371 /*The big, slow, and stupid way. */
7372 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
7373 STDCHAR *buf = NULL;
7374 Newx(buf, 8192, STDCHAR);
7382 register const STDCHAR * const bpe = buf + sizeof(buf);
7384 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7385 ; /* keep reading */
7389 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7390 /* Accomodate broken VAXC compiler, which applies U8 cast to
7391 * both args of ?: operator, causing EOF to change into 255
7394 i = (U8)buf[cnt - 1];
7400 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7402 sv_catpvn(sv, (char *) buf, cnt);
7404 sv_setpvn(sv, (char *) buf, cnt);
7406 if (i != EOF && /* joy */
7408 SvCUR(sv) < rslen ||
7409 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7413 * If we're reading from a TTY and we get a short read,
7414 * indicating that the user hit his EOF character, we need
7415 * to notice it now, because if we try to read from the TTY
7416 * again, the EOF condition will disappear.
7418 * The comparison of cnt to sizeof(buf) is an optimization
7419 * that prevents unnecessary calls to feof().
7423 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7427 #ifdef USE_HEAP_INSTEAD_OF_STACK
7432 if (rspara) { /* have to do this both before and after */
7433 while (i != EOF) { /* to make sure file boundaries work right */
7434 i = PerlIO_getc(fp);
7436 PerlIO_ungetc(fp,i);
7442 return_string_or_null:
7443 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7449 Auto-increment of the value in the SV, doing string to numeric conversion
7450 if necessary. Handles 'get' magic and operator overloading.
7456 Perl_sv_inc(pTHX_ register SV *const sv)
7465 =for apidoc sv_inc_nomg
7467 Auto-increment of the value in the SV, doing string to numeric conversion
7468 if necessary. Handles operator overloading. Skips handling 'get' magic.
7474 Perl_sv_inc_nomg(pTHX_ register SV *const sv)
7482 if (SvTHINKFIRST(sv)) {
7484 sv_force_normal_flags(sv, 0);
7485 if (SvREADONLY(sv)) {
7486 if (IN_PERL_RUNTIME)
7487 Perl_croak_no_modify(aTHX);
7491 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7493 i = PTR2IV(SvRV(sv));
7498 flags = SvFLAGS(sv);
7499 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7500 /* It's (privately or publicly) a float, but not tested as an
7501 integer, so test it to see. */
7503 flags = SvFLAGS(sv);
7505 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7506 /* It's publicly an integer, or privately an integer-not-float */
7507 #ifdef PERL_PRESERVE_IVUV
7511 if (SvUVX(sv) == UV_MAX)
7512 sv_setnv(sv, UV_MAX_P1);
7514 (void)SvIOK_only_UV(sv);
7515 SvUV_set(sv, SvUVX(sv) + 1);
7517 if (SvIVX(sv) == IV_MAX)
7518 sv_setuv(sv, (UV)IV_MAX + 1);
7520 (void)SvIOK_only(sv);
7521 SvIV_set(sv, SvIVX(sv) + 1);
7526 if (flags & SVp_NOK) {
7527 const NV was = SvNVX(sv);
7528 if (NV_OVERFLOWS_INTEGERS_AT &&
7529 was >= NV_OVERFLOWS_INTEGERS_AT) {
7530 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7531 "Lost precision when incrementing %" NVff " by 1",
7534 (void)SvNOK_only(sv);
7535 SvNV_set(sv, was + 1.0);
7539 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7540 if ((flags & SVTYPEMASK) < SVt_PVIV)
7541 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
7542 (void)SvIOK_only(sv);
7547 while (isALPHA(*d)) d++;
7548 while (isDIGIT(*d)) d++;
7549 if (d < SvEND(sv)) {
7550 #ifdef PERL_PRESERVE_IVUV
7551 /* Got to punt this as an integer if needs be, but we don't issue
7552 warnings. Probably ought to make the sv_iv_please() that does
7553 the conversion if possible, and silently. */
7554 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7555 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7556 /* Need to try really hard to see if it's an integer.
7557 9.22337203685478e+18 is an integer.
7558 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7559 so $a="9.22337203685478e+18"; $a+0; $a++
7560 needs to be the same as $a="9.22337203685478e+18"; $a++
7567 /* sv_2iv *should* have made this an NV */
7568 if (flags & SVp_NOK) {
7569 (void)SvNOK_only(sv);
7570 SvNV_set(sv, SvNVX(sv) + 1.0);
7573 /* I don't think we can get here. Maybe I should assert this
7574 And if we do get here I suspect that sv_setnv will croak. NWC
7576 #if defined(USE_LONG_DOUBLE)
7577 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",
7578 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7580 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7581 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7584 #endif /* PERL_PRESERVE_IVUV */
7585 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7589 while (d >= SvPVX_const(sv)) {
7597 /* MKS: The original code here died if letters weren't consecutive.
7598 * at least it didn't have to worry about non-C locales. The
7599 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7600 * arranged in order (although not consecutively) and that only
7601 * [A-Za-z] are accepted by isALPHA in the C locale.
7603 if (*d != 'z' && *d != 'Z') {
7604 do { ++*d; } while (!isALPHA(*d));
7607 *(d--) -= 'z' - 'a';
7612 *(d--) -= 'z' - 'a' + 1;
7616 /* oh,oh, the number grew */
7617 SvGROW(sv, SvCUR(sv) + 2);
7618 SvCUR_set(sv, SvCUR(sv) + 1);
7619 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7630 Auto-decrement of the value in the SV, doing string to numeric conversion
7631 if necessary. Handles 'get' magic and operator overloading.
7637 Perl_sv_dec(pTHX_ register SV *const sv)
7647 =for apidoc sv_dec_nomg
7649 Auto-decrement of the value in the SV, doing string to numeric conversion
7650 if necessary. Handles operator overloading. Skips handling 'get' magic.
7656 Perl_sv_dec_nomg(pTHX_ register SV *const sv)
7663 if (SvTHINKFIRST(sv)) {
7665 sv_force_normal_flags(sv, 0);
7666 if (SvREADONLY(sv)) {
7667 if (IN_PERL_RUNTIME)
7668 Perl_croak_no_modify(aTHX);
7672 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7674 i = PTR2IV(SvRV(sv));
7679 /* Unlike sv_inc we don't have to worry about string-never-numbers
7680 and keeping them magic. But we mustn't warn on punting */
7681 flags = SvFLAGS(sv);
7682 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7683 /* It's publicly an integer, or privately an integer-not-float */
7684 #ifdef PERL_PRESERVE_IVUV
7688 if (SvUVX(sv) == 0) {
7689 (void)SvIOK_only(sv);
7693 (void)SvIOK_only_UV(sv);
7694 SvUV_set(sv, SvUVX(sv) - 1);
7697 if (SvIVX(sv) == IV_MIN) {
7698 sv_setnv(sv, (NV)IV_MIN);
7702 (void)SvIOK_only(sv);
7703 SvIV_set(sv, SvIVX(sv) - 1);
7708 if (flags & SVp_NOK) {
7711 const NV was = SvNVX(sv);
7712 if (NV_OVERFLOWS_INTEGERS_AT &&
7713 was <= -NV_OVERFLOWS_INTEGERS_AT) {
7714 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7715 "Lost precision when decrementing %" NVff " by 1",
7718 (void)SvNOK_only(sv);
7719 SvNV_set(sv, was - 1.0);
7723 if (!(flags & SVp_POK)) {
7724 if ((flags & SVTYPEMASK) < SVt_PVIV)
7725 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
7727 (void)SvIOK_only(sv);
7730 #ifdef PERL_PRESERVE_IVUV
7732 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7733 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7734 /* Need to try really hard to see if it's an integer.
7735 9.22337203685478e+18 is an integer.
7736 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7737 so $a="9.22337203685478e+18"; $a+0; $a--
7738 needs to be the same as $a="9.22337203685478e+18"; $a--
7745 /* sv_2iv *should* have made this an NV */
7746 if (flags & SVp_NOK) {
7747 (void)SvNOK_only(sv);
7748 SvNV_set(sv, SvNVX(sv) - 1.0);
7751 /* I don't think we can get here. Maybe I should assert this
7752 And if we do get here I suspect that sv_setnv will croak. NWC
7754 #if defined(USE_LONG_DOUBLE)
7755 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",
7756 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7758 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7759 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7763 #endif /* PERL_PRESERVE_IVUV */
7764 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
7767 /* this define is used to eliminate a chunk of duplicated but shared logic
7768 * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
7769 * used anywhere but here - yves
7771 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
7774 PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
7778 =for apidoc sv_mortalcopy
7780 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7781 The new SV is marked as mortal. It will be destroyed "soon", either by an
7782 explicit call to FREETMPS, or by an implicit call at places such as
7783 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7788 /* Make a string that will exist for the duration of the expression
7789 * evaluation. Actually, it may have to last longer than that, but
7790 * hopefully we won't free it until it has been assigned to a
7791 * permanent location. */
7794 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
7800 sv_setsv(sv,oldstr);
7801 PUSH_EXTEND_MORTAL__SV_C(sv);
7807 =for apidoc sv_newmortal
7809 Creates a new null SV which is mortal. The reference count of the SV is
7810 set to 1. It will be destroyed "soon", either by an explicit call to
7811 FREETMPS, or by an implicit call at places such as statement boundaries.
7812 See also C<sv_mortalcopy> and C<sv_2mortal>.
7818 Perl_sv_newmortal(pTHX)
7824 SvFLAGS(sv) = SVs_TEMP;
7825 PUSH_EXTEND_MORTAL__SV_C(sv);
7831 =for apidoc newSVpvn_flags
7833 Creates a new SV and copies a string into it. The reference count for the
7834 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7835 string. You are responsible for ensuring that the source string is at least
7836 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7837 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
7838 If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before
7839 returning. If C<SVf_UTF8> is set, C<s> is considered to be in UTF-8 and the
7840 C<SVf_UTF8> flag will be set on the new SV.
7841 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
7843 #define newSVpvn_utf8(s, len, u) \
7844 newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
7850 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
7855 /* All the flags we don't support must be zero.
7856 And we're new code so I'm going to assert this from the start. */
7857 assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
7859 sv_setpvn(sv,s,len);
7861 /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal()
7862 * and do what it does outselves here.
7863 * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags
7864 * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which
7865 * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we
7866 * eleminate quite a few steps than it looks - Yves (explaining patch by gfx)
7869 SvFLAGS(sv) |= flags;
7871 if(flags & SVs_TEMP){
7872 PUSH_EXTEND_MORTAL__SV_C(sv);
7879 =for apidoc sv_2mortal
7881 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7882 by an explicit call to FREETMPS, or by an implicit call at places such as
7883 statement boundaries. SvTEMP() is turned on which means that the SV's
7884 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7885 and C<sv_mortalcopy>.
7891 Perl_sv_2mortal(pTHX_ register SV *const sv)
7896 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7898 PUSH_EXTEND_MORTAL__SV_C(sv);
7906 Creates a new SV and copies a string into it. The reference count for the
7907 SV is set to 1. If C<len> is zero, Perl will compute the length using
7908 strlen(). For efficiency, consider using C<newSVpvn> instead.
7914 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
7920 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
7925 =for apidoc newSVpvn
7927 Creates a new SV and copies a string into it. The reference count for the
7928 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7929 string. You are responsible for ensuring that the source string is at least
7930 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7936 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
7942 sv_setpvn(sv,s,len);
7947 =for apidoc newSVhek
7949 Creates a new SV from the hash key structure. It will generate scalars that
7950 point to the shared string table where possible. Returns a new (undefined)
7951 SV if the hek is NULL.
7957 Perl_newSVhek(pTHX_ const HEK *const hek)
7967 if (HEK_LEN(hek) == HEf_SVKEY) {
7968 return newSVsv(*(SV**)HEK_KEY(hek));
7970 const int flags = HEK_FLAGS(hek);
7971 if (flags & HVhek_WASUTF8) {
7973 Andreas would like keys he put in as utf8 to come back as utf8
7975 STRLEN utf8_len = HEK_LEN(hek);
7976 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7977 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7980 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7982 } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
7983 /* We don't have a pointer to the hv, so we have to replicate the
7984 flag into every HEK. This hv is using custom a hasing
7985 algorithm. Hence we can't return a shared string scalar, as
7986 that would contain the (wrong) hash value, and might get passed
7987 into an hv routine with a regular hash.
7988 Similarly, a hash that isn't using shared hash keys has to have
7989 the flag in every key so that we know not to try to call
7990 share_hek_kek on it. */
7992 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7997 /* This will be overwhelminly the most common case. */
7999 /* Inline most of newSVpvn_share(), because share_hek_hek() is far
8000 more efficient than sharepvn(). */
8004 sv_upgrade(sv, SVt_PV);
8005 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
8006 SvCUR_set(sv, HEK_LEN(hek));
8019 =for apidoc newSVpvn_share
8021 Creates a new SV with its SvPVX_const pointing to a shared string in the string
8022 table. If the string does not already exist in the table, it is created
8023 first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
8024 value is used; otherwise the hash is computed. The string's hash can be later
8025 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
8026 that as the string table is used for shared hash keys these strings will have
8027 SvPVX_const == HeKEY and hash lookup will avoid string compare.
8033 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
8037 bool is_utf8 = FALSE;
8038 const char *const orig_src = src;
8041 STRLEN tmplen = -len;
8043 /* See the note in hv.c:hv_fetch() --jhi */
8044 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
8048 PERL_HASH(hash, src, len);
8050 /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
8051 changes here, update it there too. */
8052 sv_upgrade(sv, SVt_PV);
8053 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
8061 if (src != orig_src)
8067 #if defined(PERL_IMPLICIT_CONTEXT)
8069 /* pTHX_ magic can't cope with varargs, so this is a no-context
8070 * version of the main function, (which may itself be aliased to us).
8071 * Don't access this version directly.
8075 Perl_newSVpvf_nocontext(const char *const pat, ...)
8081 PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
8083 va_start(args, pat);
8084 sv = vnewSVpvf(pat, &args);
8091 =for apidoc newSVpvf
8093 Creates a new SV and initializes it with the string formatted like
8100 Perl_newSVpvf(pTHX_ const char *const pat, ...)
8105 PERL_ARGS_ASSERT_NEWSVPVF;
8107 va_start(args, pat);
8108 sv = vnewSVpvf(pat, &args);
8113 /* backend for newSVpvf() and newSVpvf_nocontext() */
8116 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
8121 PERL_ARGS_ASSERT_VNEWSVPVF;
8124 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8131 Creates a new SV and copies a floating point value into it.
8132 The reference count for the SV is set to 1.
8138 Perl_newSVnv(pTHX_ const NV n)
8151 Creates a new SV and copies an integer into it. The reference count for the
8158 Perl_newSViv(pTHX_ const IV i)
8171 Creates a new SV and copies an unsigned integer into it.
8172 The reference count for the SV is set to 1.
8178 Perl_newSVuv(pTHX_ const UV u)
8189 =for apidoc newSV_type
8191 Creates a new SV, of the type specified. The reference count for the new SV
8198 Perl_newSV_type(pTHX_ const svtype type)
8203 sv_upgrade(sv, type);
8208 =for apidoc newRV_noinc
8210 Creates an RV wrapper for an SV. The reference count for the original
8211 SV is B<not> incremented.
8217 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
8220 register SV *sv = newSV_type(SVt_IV);
8222 PERL_ARGS_ASSERT_NEWRV_NOINC;
8225 SvRV_set(sv, tmpRef);
8230 /* newRV_inc is the official function name to use now.
8231 * newRV_inc is in fact #defined to newRV in sv.h
8235 Perl_newRV(pTHX_ SV *const sv)
8239 PERL_ARGS_ASSERT_NEWRV;
8241 return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
8247 Creates a new SV which is an exact duplicate of the original SV.
8254 Perl_newSVsv(pTHX_ register SV *const old)
8261 if (SvTYPE(old) == SVTYPEMASK) {
8262 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
8266 /* SV_GMAGIC is the default for sv_setv()
8267 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
8268 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
8269 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
8274 =for apidoc sv_reset
8276 Underlying implementation for the C<reset> Perl function.
8277 Note that the perl-level function is vaguely deprecated.
8283 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
8286 char todo[PERL_UCHAR_MAX+1];
8288 PERL_ARGS_ASSERT_SV_RESET;
8293 if (!*s) { /* reset ?? searches */
8294 MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
8296 const U32 count = mg->mg_len / sizeof(PMOP**);
8297 PMOP **pmp = (PMOP**) mg->mg_ptr;
8298 PMOP *const *const end = pmp + count;
8302 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
8304 (*pmp)->op_pmflags &= ~PMf_USED;
8312 /* reset variables */
8314 if (!HvARRAY(stash))
8317 Zero(todo, 256, char);
8320 I32 i = (unsigned char)*s;
8324 max = (unsigned char)*s++;
8325 for ( ; i <= max; i++) {
8328 for (i = 0; i <= (I32) HvMAX(stash); i++) {
8330 for (entry = HvARRAY(stash)[i];
8332 entry = HeNEXT(entry))
8337 if (!todo[(U8)*HeKEY(entry)])
8339 gv = MUTABLE_GV(HeVAL(entry));
8342 if (SvTHINKFIRST(sv)) {
8343 if (!SvREADONLY(sv) && SvROK(sv))
8345 /* XXX Is this continue a bug? Why should THINKFIRST
8346 exempt us from resetting arrays and hashes? */
8350 if (SvTYPE(sv) >= SVt_PV) {
8352 if (SvPVX_const(sv) != NULL)
8360 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8362 Perl_die(aTHX_ "Can't reset %%ENV on this system");
8365 # if defined(USE_ENVIRON_ARRAY)
8368 # endif /* USE_ENVIRON_ARRAY */
8379 Using various gambits, try to get an IO from an SV: the IO slot if its a
8380 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8381 named after the PV if we're a string.
8387 Perl_sv_2io(pTHX_ SV *const sv)
8392 PERL_ARGS_ASSERT_SV_2IO;
8394 switch (SvTYPE(sv)) {
8396 io = MUTABLE_IO(sv);
8399 if (isGV_with_GP(sv)) {
8400 gv = MUTABLE_GV(sv);
8403 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8409 Perl_croak(aTHX_ PL_no_usym, "filehandle");
8411 return sv_2io(SvRV(sv));
8412 gv = gv_fetchsv(sv, 0, SVt_PVIO);
8418 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
8427 Using various gambits, try to get a CV from an SV; in addition, try if
8428 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8429 The flags in C<lref> are passed to gv_fetchsv.
8435 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8441 PERL_ARGS_ASSERT_SV_2CV;
8448 switch (SvTYPE(sv)) {
8452 return MUTABLE_CV(sv);
8459 if (isGV_with_GP(sv)) {
8460 gv = MUTABLE_GV(sv);
8469 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
8471 tryAMAGICunDEREF(to_cv);
8474 if (SvTYPE(sv) == SVt_PVCV) {
8475 cv = MUTABLE_CV(sv);
8480 else if(isGV_with_GP(sv))
8481 gv = MUTABLE_GV(sv);
8483 Perl_croak(aTHX_ "Not a subroutine reference");
8485 else if (isGV_with_GP(sv)) {
8487 gv = MUTABLE_GV(sv);
8490 gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
8496 /* Some flags to gv_fetchsv mean don't really create the GV */
8497 if (!isGV_with_GP(gv)) {
8503 if (lref && !GvCVu(gv)) {
8507 gv_efullname3(tmpsv, gv, NULL);
8508 /* XXX this is probably not what they think they're getting.
8509 * It has the same effect as "sub name;", i.e. just a forward
8511 newSUB(start_subparse(FALSE, 0),
8512 newSVOP(OP_CONST, 0, tmpsv),
8516 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8517 SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8526 Returns true if the SV has a true value by Perl's rules.
8527 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8528 instead use an in-line version.
8534 Perl_sv_true(pTHX_ register SV *const sv)
8539 register const XPV* const tXpv = (XPV*)SvANY(sv);
8541 (tXpv->xpv_cur > 1 ||
8542 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
8549 return SvIVX(sv) != 0;
8552 return SvNVX(sv) != 0.0;
8554 return sv_2bool(sv);
8560 =for apidoc sv_pvn_force
8562 Get a sensible string out of the SV somehow.
8563 A private implementation of the C<SvPV_force> macro for compilers which
8564 can't cope with complex macro expressions. Always use the macro instead.
8566 =for apidoc sv_pvn_force_flags
8568 Get a sensible string out of the SV somehow.
8569 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8570 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8571 implemented in terms of this function.
8572 You normally want to use the various wrapper macros instead: see
8573 C<SvPV_force> and C<SvPV_force_nomg>
8579 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
8583 PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
8585 if (SvTHINKFIRST(sv) && !SvROK(sv))
8586 sv_force_normal_flags(sv, 0);
8596 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8597 const char * const ref = sv_reftype(sv,0);
8599 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8600 ref, OP_DESC(PL_op));
8602 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
8604 if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
8605 || isGV_with_GP(sv))
8606 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8608 s = sv_2pv_flags(sv, &len, flags);
8612 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
8615 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8616 SvGROW(sv, len + 1);
8617 Move(s,SvPVX(sv),len,char);
8619 SvPVX(sv)[len] = '\0';
8622 SvPOK_on(sv); /* validate pointer */
8624 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8625 PTR2UV(sv),SvPVX_const(sv)));
8628 return SvPVX_mutable(sv);
8632 =for apidoc sv_pvbyten_force
8634 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
8640 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
8642 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
8644 sv_pvn_force(sv,lp);
8645 sv_utf8_downgrade(sv,0);
8651 =for apidoc sv_pvutf8n_force
8653 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
8659 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
8661 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
8663 sv_pvn_force(sv,lp);
8664 sv_utf8_upgrade(sv);
8670 =for apidoc sv_reftype
8672 Returns a string describing what the SV is a reference to.
8678 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
8680 PERL_ARGS_ASSERT_SV_REFTYPE;
8682 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8683 inside return suggests a const propagation bug in g++. */
8684 if (ob && SvOBJECT(sv)) {
8685 char * const name = HvNAME_get(SvSTASH(sv));
8686 return name ? name : (char *) "__ANON__";
8689 switch (SvTYPE(sv)) {
8704 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
8705 /* tied lvalues should appear to be
8706 * scalars for backwards compatitbility */
8707 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8708 ? "SCALAR" : "LVALUE");
8709 case SVt_PVAV: return "ARRAY";
8710 case SVt_PVHV: return "HASH";
8711 case SVt_PVCV: return "CODE";
8712 case SVt_PVGV: return (char *) (isGV_with_GP(sv)
8713 ? "GLOB" : "SCALAR");
8714 case SVt_PVFM: return "FORMAT";
8715 case SVt_PVIO: return "IO";
8716 case SVt_BIND: return "BIND";
8717 case SVt_REGEXP: return "REGEXP";
8718 default: return "UNKNOWN";
8724 =for apidoc sv_isobject
8726 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8727 object. If the SV is not an RV, or if the object is not blessed, then this
8734 Perl_sv_isobject(pTHX_ SV *sv)
8750 Returns a boolean indicating whether the SV is blessed into the specified
8751 class. This does not check for subtypes; use C<sv_derived_from> to verify
8752 an inheritance relationship.
8758 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
8762 PERL_ARGS_ASSERT_SV_ISA;
8772 hvname = HvNAME_get(SvSTASH(sv));
8776 return strEQ(hvname, name);
8782 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8783 it will be upgraded to one. If C<classname> is non-null then the new SV will
8784 be blessed in the specified package. The new SV is returned and its
8785 reference count is 1.
8791 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
8796 PERL_ARGS_ASSERT_NEWSVRV;
8800 SV_CHECK_THINKFIRST_COW_DROP(rv);
8801 (void)SvAMAGIC_off(rv);
8803 if (SvTYPE(rv) >= SVt_PVMG) {
8804 const U32 refcnt = SvREFCNT(rv);
8808 SvREFCNT(rv) = refcnt;
8810 sv_upgrade(rv, SVt_IV);
8811 } else if (SvROK(rv)) {
8812 SvREFCNT_dec(SvRV(rv));
8814 prepare_SV_for_RV(rv);
8822 HV* const stash = gv_stashpv(classname, GV_ADD);
8823 (void)sv_bless(rv, stash);
8829 =for apidoc sv_setref_pv
8831 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8832 argument will be upgraded to an RV. That RV will be modified to point to
8833 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8834 into the SV. The C<classname> argument indicates the package for the
8835 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8836 will have a reference count of 1, and the RV will be returned.
8838 Do not use with other Perl types such as HV, AV, SV, CV, because those
8839 objects will become corrupted by the pointer copy process.
8841 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8847 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
8851 PERL_ARGS_ASSERT_SV_SETREF_PV;
8854 sv_setsv(rv, &PL_sv_undef);
8858 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8863 =for apidoc sv_setref_iv
8865 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8866 argument will be upgraded to an RV. That RV will be modified to point to
8867 the new SV. The C<classname> argument indicates the package for the
8868 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8869 will have a reference count of 1, and the RV will be returned.
8875 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
8877 PERL_ARGS_ASSERT_SV_SETREF_IV;
8879 sv_setiv(newSVrv(rv,classname), iv);
8884 =for apidoc sv_setref_uv
8886 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8887 argument will be upgraded to an RV. That RV will be modified to point to
8888 the new SV. The C<classname> argument indicates the package for the
8889 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8890 will have a reference count of 1, and the RV will be returned.
8896 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
8898 PERL_ARGS_ASSERT_SV_SETREF_UV;
8900 sv_setuv(newSVrv(rv,classname), uv);
8905 =for apidoc sv_setref_nv
8907 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8908 argument will be upgraded to an RV. That RV will be modified to point to
8909 the new SV. The C<classname> argument indicates the package for the
8910 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8911 will have a reference count of 1, and the RV will be returned.
8917 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
8919 PERL_ARGS_ASSERT_SV_SETREF_NV;
8921 sv_setnv(newSVrv(rv,classname), nv);
8926 =for apidoc sv_setref_pvn
8928 Copies a string into a new SV, optionally blessing the SV. The length of the
8929 string must be specified with C<n>. The C<rv> argument will be upgraded to
8930 an RV. That RV will be modified to point to the new SV. The C<classname>
8931 argument indicates the package for the blessing. Set C<classname> to
8932 C<NULL> to avoid the blessing. The new SV will have a reference count
8933 of 1, and the RV will be returned.
8935 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8941 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
8942 const char *const pv, const STRLEN n)
8944 PERL_ARGS_ASSERT_SV_SETREF_PVN;
8946 sv_setpvn(newSVrv(rv,classname), pv, n);
8951 =for apidoc sv_bless
8953 Blesses an SV into a specified package. The SV must be an RV. The package
8954 must be designated by its stash (see C<gv_stashpv()>). The reference count
8955 of the SV is unaffected.
8961 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
8966 PERL_ARGS_ASSERT_SV_BLESS;
8969 Perl_croak(aTHX_ "Can't bless non-reference value");
8971 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8972 if (SvIsCOW(tmpRef))
8973 sv_force_normal_flags(tmpRef, 0);
8974 if (SvREADONLY(tmpRef))
8975 Perl_croak_no_modify(aTHX);
8976 if (SvOBJECT(tmpRef)) {
8977 if (SvTYPE(tmpRef) != SVt_PVIO)
8979 SvREFCNT_dec(SvSTASH(tmpRef));
8982 SvOBJECT_on(tmpRef);
8983 if (SvTYPE(tmpRef) != SVt_PVIO)
8985 SvUPGRADE(tmpRef, SVt_PVMG);
8986 SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
8991 (void)SvAMAGIC_off(sv);
8993 if(SvSMAGICAL(tmpRef))
8994 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
9002 /* Downgrades a PVGV to a PVMG.
9006 S_sv_unglob(pTHX_ SV *const sv)
9011 SV * const temp = sv_newmortal();
9013 PERL_ARGS_ASSERT_SV_UNGLOB;
9015 assert(SvTYPE(sv) == SVt_PVGV);
9017 gv_efullname3(temp, MUTABLE_GV(sv), "*");
9020 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
9021 && HvNAME_get(stash))
9022 mro_method_changed_in(stash);
9023 gp_free(MUTABLE_GV(sv));
9026 sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
9030 if (GvNAME_HEK(sv)) {
9031 unshare_hek(GvNAME_HEK(sv));
9033 isGV_with_GP_off(sv);
9035 /* need to keep SvANY(sv) in the right arena */
9036 xpvmg = new_XPVMG();
9037 StructCopy(SvANY(sv), xpvmg, XPVMG);
9038 del_XPVGV(SvANY(sv));
9041 SvFLAGS(sv) &= ~SVTYPEMASK;
9042 SvFLAGS(sv) |= SVt_PVMG;
9044 /* Intentionally not calling any local SET magic, as this isn't so much a
9045 set operation as merely an internal storage change. */
9046 sv_setsv_flags(sv, temp, 0);
9050 =for apidoc sv_unref_flags
9052 Unsets the RV status of the SV, and decrements the reference count of
9053 whatever was being referenced by the RV. This can almost be thought of
9054 as a reversal of C<newSVrv>. The C<cflags> argument can contain
9055 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
9056 (otherwise the decrementing is conditional on the reference count being
9057 different from one or the reference being a readonly SV).
9064 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
9066 SV* const target = SvRV(ref);
9068 PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
9070 if (SvWEAKREF(ref)) {
9071 sv_del_backref(target, ref);
9073 SvRV_set(ref, NULL);
9076 SvRV_set(ref, NULL);
9078 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
9079 assigned to as BEGIN {$a = \"Foo"} will fail. */
9080 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
9081 SvREFCNT_dec(target);
9082 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
9083 sv_2mortal(target); /* Schedule for freeing later */
9087 =for apidoc sv_untaint
9089 Untaint an SV. Use C<SvTAINTED_off> instead.
9094 Perl_sv_untaint(pTHX_ SV *const sv)
9096 PERL_ARGS_ASSERT_SV_UNTAINT;
9098 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9099 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9106 =for apidoc sv_tainted
9108 Test an SV for taintedness. Use C<SvTAINTED> instead.
9113 Perl_sv_tainted(pTHX_ SV *const sv)
9115 PERL_ARGS_ASSERT_SV_TAINTED;
9117 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9118 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9119 if (mg && (mg->mg_len & 1) )
9126 =for apidoc sv_setpviv
9128 Copies an integer into the given SV, also updating its string value.
9129 Does not handle 'set' magic. See C<sv_setpviv_mg>.
9135 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
9137 char buf[TYPE_CHARS(UV)];
9139 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
9141 PERL_ARGS_ASSERT_SV_SETPVIV;
9143 sv_setpvn(sv, ptr, ebuf - ptr);
9147 =for apidoc sv_setpviv_mg
9149 Like C<sv_setpviv>, but also handles 'set' magic.
9155 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
9157 PERL_ARGS_ASSERT_SV_SETPVIV_MG;
9163 #if defined(PERL_IMPLICIT_CONTEXT)
9165 /* pTHX_ magic can't cope with varargs, so this is a no-context
9166 * version of the main function, (which may itself be aliased to us).
9167 * Don't access this version directly.
9171 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
9176 PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
9178 va_start(args, pat);
9179 sv_vsetpvf(sv, pat, &args);
9183 /* pTHX_ magic can't cope with varargs, so this is a no-context
9184 * version of the main function, (which may itself be aliased to us).
9185 * Don't access this version directly.
9189 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9194 PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
9196 va_start(args, pat);
9197 sv_vsetpvf_mg(sv, pat, &args);
9203 =for apidoc sv_setpvf
9205 Works like C<sv_catpvf> but copies the text into the SV instead of
9206 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
9212 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
9216 PERL_ARGS_ASSERT_SV_SETPVF;
9218 va_start(args, pat);
9219 sv_vsetpvf(sv, pat, &args);
9224 =for apidoc sv_vsetpvf
9226 Works like C<sv_vcatpvf> but copies the text into the SV instead of
9227 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
9229 Usually used via its frontend C<sv_setpvf>.
9235 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9237 PERL_ARGS_ASSERT_SV_VSETPVF;
9239 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9243 =for apidoc sv_setpvf_mg
9245 Like C<sv_setpvf>, but also handles 'set' magic.
9251 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9255 PERL_ARGS_ASSERT_SV_SETPVF_MG;
9257 va_start(args, pat);
9258 sv_vsetpvf_mg(sv, pat, &args);
9263 =for apidoc sv_vsetpvf_mg
9265 Like C<sv_vsetpvf>, but also handles 'set' magic.
9267 Usually used via its frontend C<sv_setpvf_mg>.
9273 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9275 PERL_ARGS_ASSERT_SV_VSETPVF_MG;
9277 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9281 #if defined(PERL_IMPLICIT_CONTEXT)
9283 /* pTHX_ magic can't cope with varargs, so this is a no-context
9284 * version of the main function, (which may itself be aliased to us).
9285 * Don't access this version directly.
9289 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
9294 PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
9296 va_start(args, pat);
9297 sv_vcatpvf(sv, pat, &args);
9301 /* pTHX_ magic can't cope with varargs, so this is a no-context
9302 * version of the main function, (which may itself be aliased to us).
9303 * Don't access this version directly.
9307 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9312 PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9314 va_start(args, pat);
9315 sv_vcatpvf_mg(sv, pat, &args);
9321 =for apidoc sv_catpvf
9323 Processes its arguments like C<sprintf> and appends the formatted
9324 output to an SV. If the appended data contains "wide" characters
9325 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9326 and characters >255 formatted with %c), the original SV might get
9327 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
9328 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9329 valid UTF-8; if the original SV was bytes, the pattern should be too.
9334 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9338 PERL_ARGS_ASSERT_SV_CATPVF;
9340 va_start(args, pat);
9341 sv_vcatpvf(sv, pat, &args);
9346 =for apidoc sv_vcatpvf
9348 Processes its arguments like C<vsprintf> and appends the formatted output
9349 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
9351 Usually used via its frontend C<sv_catpvf>.
9357 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9359 PERL_ARGS_ASSERT_SV_VCATPVF;
9361 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9365 =for apidoc sv_catpvf_mg
9367 Like C<sv_catpvf>, but also handles 'set' magic.
9373 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9377 PERL_ARGS_ASSERT_SV_CATPVF_MG;
9379 va_start(args, pat);
9380 sv_vcatpvf_mg(sv, pat, &args);
9385 =for apidoc sv_vcatpvf_mg
9387 Like C<sv_vcatpvf>, but also handles 'set' magic.
9389 Usually used via its frontend C<sv_catpvf_mg>.
9395 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9397 PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9399 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9404 =for apidoc sv_vsetpvfn
9406 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9409 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9415 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9416 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9418 PERL_ARGS_ASSERT_SV_VSETPVFN;
9421 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9426 * Warn of missing argument to sprintf, and then return a defined value
9427 * to avoid inappropriate "use of uninit" warnings [perl #71000].
9429 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
9431 S_vcatpvfn_missing_argument(pTHX) {
9432 if (ckWARN(WARN_MISSING)) {
9433 Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
9434 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
9441 S_expect_number(pTHX_ char **const pattern)
9446 PERL_ARGS_ASSERT_EXPECT_NUMBER;
9448 switch (**pattern) {
9449 case '1': case '2': case '3':
9450 case '4': case '5': case '6':
9451 case '7': case '8': case '9':
9452 var = *(*pattern)++ - '0';
9453 while (isDIGIT(**pattern)) {
9454 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
9456 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
9464 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
9466 const int neg = nv < 0;
9469 PERL_ARGS_ASSERT_F0CONVERT;
9477 if (uv & 1 && uv == nv)
9478 uv--; /* Round to even */
9480 const unsigned dig = uv % 10;
9493 =for apidoc sv_vcatpvfn
9495 Processes its arguments like C<vsprintf> and appends the formatted output
9496 to an SV. Uses an array of SVs if the C style variable argument list is
9497 missing (NULL). When running with taint checks enabled, indicates via
9498 C<maybe_tainted> if results are untrustworthy (often due to the use of
9501 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9507 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
9508 vecstr = (U8*)SvPV_const(vecsv,veclen);\
9509 vec_utf8 = DO_UTF8(vecsv);
9511 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9514 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9515 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9523 static const char nullstr[] = "(null)";
9525 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
9526 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9528 /* Times 4: a decimal digit takes more than 3 binary digits.
9529 * NV_DIG: mantissa takes than many decimal digits.
9530 * Plus 32: Playing safe. */
9531 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9532 /* large enough for "%#.#f" --chip */
9533 /* what about long double NVs? --jhi */
9535 PERL_ARGS_ASSERT_SV_VCATPVFN;
9536 PERL_UNUSED_ARG(maybe_tainted);
9538 /* no matter what, this is a string now */
9539 (void)SvPV_force(sv, origlen);
9541 /* special-case "", "%s", and "%-p" (SVf - see below) */
9544 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9546 const char * const s = va_arg(*args, char*);
9547 sv_catpv(sv, s ? s : nullstr);
9549 else if (svix < svmax) {
9550 sv_catsv(sv, *svargs);
9553 S_vcatpvfn_missing_argument(aTHX);
9556 if (args && patlen == 3 && pat[0] == '%' &&
9557 pat[1] == '-' && pat[2] == 'p') {
9558 argsv = MUTABLE_SV(va_arg(*args, void*));
9559 sv_catsv(sv, argsv);
9563 #ifndef USE_LONG_DOUBLE
9564 /* special-case "%.<number>[gf]" */
9565 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9566 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9567 unsigned digits = 0;
9571 while (*pp >= '0' && *pp <= '9')
9572 digits = 10 * digits + (*pp++ - '0');
9573 if (pp - pat == (int)patlen - 1 && svix < svmax) {
9574 const NV nv = SvNV(*svargs);
9576 /* Add check for digits != 0 because it seems that some
9577 gconverts are buggy in this case, and we don't yet have
9578 a Configure test for this. */
9579 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9580 /* 0, point, slack */
9581 Gconvert(nv, (int)digits, 0, ebuf);
9583 if (*ebuf) /* May return an empty string for digits==0 */
9586 } else if (!digits) {
9589 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9590 sv_catpvn(sv, p, l);
9596 #endif /* !USE_LONG_DOUBLE */
9598 if (!args && svix < svmax && DO_UTF8(*svargs))
9601 patend = (char*)pat + patlen;
9602 for (p = (char*)pat; p < patend; p = q) {
9605 bool vectorize = FALSE;
9606 bool vectorarg = FALSE;
9607 bool vec_utf8 = FALSE;
9613 bool has_precis = FALSE;
9615 const I32 osvix = svix;
9616 bool is_utf8 = FALSE; /* is this item utf8? */
9617 #ifdef HAS_LDBL_SPRINTF_BUG
9618 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9619 with sfio - Allen <allens@cpan.org> */
9620 bool fix_ldbl_sprintf_bug = FALSE;
9624 U8 utf8buf[UTF8_MAXBYTES+1];
9625 STRLEN esignlen = 0;
9627 const char *eptr = NULL;
9628 const char *fmtstart;
9631 const U8 *vecstr = NULL;
9638 /* we need a long double target in case HAS_LONG_DOUBLE but
9641 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9649 const char *dotstr = ".";
9650 STRLEN dotstrlen = 1;
9651 I32 efix = 0; /* explicit format parameter index */
9652 I32 ewix = 0; /* explicit width index */
9653 I32 epix = 0; /* explicit precision index */
9654 I32 evix = 0; /* explicit vector index */
9655 bool asterisk = FALSE;
9657 /* echo everything up to the next format specification */
9658 for (q = p; q < patend && *q != '%'; ++q) ;
9660 if (has_utf8 && !pat_utf8)
9661 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9663 sv_catpvn(sv, p, q - p);
9672 We allow format specification elements in this order:
9673 \d+\$ explicit format parameter index
9675 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9676 0 flag (as above): repeated to allow "v02"
9677 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9678 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9680 [%bcdefginopsuxDFOUX] format (mandatory)
9685 As of perl5.9.3, printf format checking is on by default.
9686 Internally, perl uses %p formats to provide an escape to
9687 some extended formatting. This block deals with those
9688 extensions: if it does not match, (char*)q is reset and
9689 the normal format processing code is used.
9691 Currently defined extensions are:
9692 %p include pointer address (standard)
9693 %-p (SVf) include an SV (previously %_)
9694 %-<num>p include an SV with precision <num>
9695 %<num>p reserved for future extensions
9697 Robin Barker 2005-07-14
9699 %1p (VDf) removed. RMB 2007-10-19
9706 n = expect_number(&q);
9713 argsv = MUTABLE_SV(va_arg(*args, void*));
9714 eptr = SvPV_const(argsv, elen);
9720 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
9721 "internal %%<num>p might conflict with future printf extensions");
9727 if ( (width = expect_number(&q)) ) {
9742 if (plus == '+' && *q == ' ') /* '+' over ' ' */
9771 if ( (ewix = expect_number(&q)) )
9780 if ((vectorarg = asterisk)) {
9793 width = expect_number(&q);
9799 vecsv = va_arg(*args, SV*);
9801 vecsv = (evix > 0 && evix <= svmax)
9802 ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
9804 vecsv = svix < svmax
9805 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
9807 dotstr = SvPV_const(vecsv, dotstrlen);
9808 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
9809 bad with tied or overloaded values that return UTF8. */
9812 else if (has_utf8) {
9813 vecsv = sv_mortalcopy(vecsv);
9814 sv_utf8_upgrade(vecsv);
9815 dotstr = SvPV_const(vecsv, dotstrlen);
9822 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
9823 vecsv = svargs[efix ? efix-1 : svix++];
9824 vecstr = (U8*)SvPV_const(vecsv,veclen);
9825 vec_utf8 = DO_UTF8(vecsv);
9827 /* if this is a version object, we need to convert
9828 * back into v-string notation and then let the
9829 * vectorize happen normally
9831 if (sv_derived_from(vecsv, "version")) {
9832 char *version = savesvpv(vecsv);
9833 if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
9834 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9835 "vector argument not supported with alpha versions");
9838 vecsv = sv_newmortal();
9839 scan_vstring(version, version + veclen, vecsv);
9840 vecstr = (U8*)SvPV_const(vecsv, veclen);
9841 vec_utf8 = DO_UTF8(vecsv);
9853 i = va_arg(*args, int);
9855 i = (ewix ? ewix <= svmax : svix < svmax) ?
9856 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9858 width = (i < 0) ? -i : i;
9868 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
9870 /* XXX: todo, support specified precision parameter */
9874 i = va_arg(*args, int);
9876 i = (ewix ? ewix <= svmax : svix < svmax)
9877 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9879 has_precis = !(i < 0);
9884 precis = precis * 10 + (*q++ - '0');
9893 case 'I': /* Ix, I32x, and I64x */
9895 if (q[1] == '6' && q[2] == '4') {
9901 if (q[1] == '3' && q[2] == '2') {
9911 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9922 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9923 if (*(q + 1) == 'l') { /* lld, llf */
9949 if (!vectorize && !args) {
9951 const I32 i = efix-1;
9952 argsv = (i >= 0 && i < svmax)
9953 ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
9955 argsv = (svix >= 0 && svix < svmax)
9956 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
9967 uv = (args) ? va_arg(*args, int) : SvIV(argsv);
9969 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9971 eptr = (char*)utf8buf;
9972 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9986 eptr = va_arg(*args, char*);
9988 elen = strlen(eptr);
9990 eptr = (char *)nullstr;
9991 elen = sizeof nullstr - 1;
9995 eptr = SvPV_const(argsv, elen);
9996 if (DO_UTF8(argsv)) {
9997 STRLEN old_precis = precis;
9998 if (has_precis && precis < elen) {
9999 STRLEN ulen = sv_len_utf8(argsv);
10000 I32 p = precis > ulen ? ulen : precis;
10001 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
10004 if (width) { /* fudge width (can't fudge elen) */
10005 if (has_precis && precis < elen)
10006 width += precis - old_precis;
10008 width += elen - sv_len_utf8(argsv);
10015 if (has_precis && precis < elen)
10022 if (alt || vectorize)
10024 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
10045 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10054 esignbuf[esignlen++] = plus;
10058 case 'h': iv = (short)va_arg(*args, int); break;
10059 case 'l': iv = va_arg(*args, long); break;
10060 case 'V': iv = va_arg(*args, IV); break;
10061 default: iv = va_arg(*args, int); break;
10064 iv = va_arg(*args, Quad_t); break;
10071 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
10073 case 'h': iv = (short)tiv; break;
10074 case 'l': iv = (long)tiv; break;
10076 default: iv = tiv; break;
10079 iv = (Quad_t)tiv; break;
10085 if ( !vectorize ) /* we already set uv above */
10090 esignbuf[esignlen++] = plus;
10094 esignbuf[esignlen++] = '-';
10138 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10149 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
10150 case 'l': uv = va_arg(*args, unsigned long); break;
10151 case 'V': uv = va_arg(*args, UV); break;
10152 default: uv = va_arg(*args, unsigned); break;
10155 uv = va_arg(*args, Uquad_t); break;
10162 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
10164 case 'h': uv = (unsigned short)tuv; break;
10165 case 'l': uv = (unsigned long)tuv; break;
10167 default: uv = tuv; break;
10170 uv = (Uquad_t)tuv; break;
10179 char *ptr = ebuf + sizeof ebuf;
10180 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
10186 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
10190 } while (uv >>= 4);
10192 esignbuf[esignlen++] = '0';
10193 esignbuf[esignlen++] = c; /* 'x' or 'X' */
10199 *--ptr = '0' + dig;
10200 } while (uv >>= 3);
10201 if (alt && *ptr != '0')
10207 *--ptr = '0' + dig;
10208 } while (uv >>= 1);
10210 esignbuf[esignlen++] = '0';
10211 esignbuf[esignlen++] = c;
10214 default: /* it had better be ten or less */
10217 *--ptr = '0' + dig;
10218 } while (uv /= base);
10221 elen = (ebuf + sizeof ebuf) - ptr;
10225 zeros = precis - elen;
10226 else if (precis == 0 && elen == 1 && *eptr == '0'
10227 && !(base == 8 && alt)) /* "%#.0o" prints "0" */
10230 /* a precision nullifies the 0 flag. */
10237 /* FLOATING POINT */
10240 c = 'f'; /* maybe %F isn't supported here */
10242 case 'e': case 'E':
10244 case 'g': case 'G':
10248 /* This is evil, but floating point is even more evil */
10250 /* for SV-style calling, we can only get NV
10251 for C-style calling, we assume %f is double;
10252 for simplicity we allow any of %Lf, %llf, %qf for long double
10256 #if defined(USE_LONG_DOUBLE)
10260 /* [perl #20339] - we should accept and ignore %lf rather than die */
10264 #if defined(USE_LONG_DOUBLE)
10265 intsize = args ? 0 : 'q';
10269 #if defined(HAS_LONG_DOUBLE)
10278 /* now we need (long double) if intsize == 'q', else (double) */
10280 #if LONG_DOUBLESIZE > DOUBLESIZE
10282 va_arg(*args, long double) :
10283 va_arg(*args, double)
10285 va_arg(*args, double)
10290 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
10291 else. frexp() has some unspecified behaviour for those three */
10292 if (c != 'e' && c != 'E' && (nv * 0) == 0) {
10294 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
10295 will cast our (long double) to (double) */
10296 (void)Perl_frexp(nv, &i);
10297 if (i == PERL_INT_MIN)
10298 Perl_die(aTHX_ "panic: frexp");
10300 need = BIT_DIGITS(i);
10302 need += has_precis ? precis : 6; /* known default */
10307 #ifdef HAS_LDBL_SPRINTF_BUG
10308 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10309 with sfio - Allen <allens@cpan.org> */
10312 # define MY_DBL_MAX DBL_MAX
10313 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
10314 # if DOUBLESIZE >= 8
10315 # define MY_DBL_MAX 1.7976931348623157E+308L
10317 # define MY_DBL_MAX 3.40282347E+38L
10321 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10322 # define MY_DBL_MAX_BUG 1L
10324 # define MY_DBL_MAX_BUG MY_DBL_MAX
10328 # define MY_DBL_MIN DBL_MIN
10329 # else /* XXX guessing! -Allen */
10330 # if DOUBLESIZE >= 8
10331 # define MY_DBL_MIN 2.2250738585072014E-308L
10333 # define MY_DBL_MIN 1.17549435E-38L
10337 if ((intsize == 'q') && (c == 'f') &&
10338 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10339 (need < DBL_DIG)) {
10340 /* it's going to be short enough that
10341 * long double precision is not needed */
10343 if ((nv <= 0L) && (nv >= -0L))
10344 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10346 /* would use Perl_fp_class as a double-check but not
10347 * functional on IRIX - see perl.h comments */
10349 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10350 /* It's within the range that a double can represent */
10351 #if defined(DBL_MAX) && !defined(DBL_MIN)
10352 if ((nv >= ((long double)1/DBL_MAX)) ||
10353 (nv <= (-(long double)1/DBL_MAX)))
10355 fix_ldbl_sprintf_bug = TRUE;
10358 if (fix_ldbl_sprintf_bug == TRUE) {
10368 # undef MY_DBL_MAX_BUG
10371 #endif /* HAS_LDBL_SPRINTF_BUG */
10373 need += 20; /* fudge factor */
10374 if (PL_efloatsize < need) {
10375 Safefree(PL_efloatbuf);
10376 PL_efloatsize = need + 20; /* more fudge */
10377 Newx(PL_efloatbuf, PL_efloatsize, char);
10378 PL_efloatbuf[0] = '\0';
10381 if ( !(width || left || plus || alt) && fill != '0'
10382 && has_precis && intsize != 'q' ) { /* Shortcuts */
10383 /* See earlier comment about buggy Gconvert when digits,
10385 if ( c == 'g' && precis) {
10386 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10387 /* May return an empty string for digits==0 */
10388 if (*PL_efloatbuf) {
10389 elen = strlen(PL_efloatbuf);
10390 goto float_converted;
10392 } else if ( c == 'f' && !precis) {
10393 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10398 char *ptr = ebuf + sizeof ebuf;
10401 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10402 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10403 if (intsize == 'q') {
10404 /* Copy the one or more characters in a long double
10405 * format before the 'base' ([efgEFG]) character to
10406 * the format string. */
10407 static char const prifldbl[] = PERL_PRIfldbl;
10408 char const *p = prifldbl + sizeof(prifldbl) - 3;
10409 while (p >= prifldbl) { *--ptr = *p--; }
10414 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10419 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10431 /* No taint. Otherwise we are in the strange situation
10432 * where printf() taints but print($float) doesn't.
10434 #if defined(HAS_LONG_DOUBLE)
10435 elen = ((intsize == 'q')
10436 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
10437 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
10439 elen = my_sprintf(PL_efloatbuf, ptr, nv);
10443 eptr = PL_efloatbuf;
10451 i = SvCUR(sv) - origlen;
10454 case 'h': *(va_arg(*args, short*)) = i; break;
10455 default: *(va_arg(*args, int*)) = i; break;
10456 case 'l': *(va_arg(*args, long*)) = i; break;
10457 case 'V': *(va_arg(*args, IV*)) = i; break;
10460 *(va_arg(*args, Quad_t*)) = i; break;
10467 sv_setuv_mg(argsv, (UV)i);
10468 continue; /* not "break" */
10475 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
10476 && ckWARN(WARN_PRINTF))
10478 SV * const msg = sv_newmortal();
10479 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10480 (PL_op->op_type == OP_PRTF) ? "" : "s");
10481 if (fmtstart < patend) {
10482 const char * const fmtend = q < patend ? q : patend;
10484 sv_catpvs(msg, "\"%");
10485 for (f = fmtstart; f < fmtend; f++) {
10487 sv_catpvn(msg, f, 1);
10489 Perl_sv_catpvf(aTHX_ msg,
10490 "\\%03"UVof, (UV)*f & 0xFF);
10493 sv_catpvs(msg, "\"");
10495 sv_catpvs(msg, "end of string");
10497 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
10500 /* output mangled stuff ... */
10506 /* ... right here, because formatting flags should not apply */
10507 SvGROW(sv, SvCUR(sv) + elen + 1);
10509 Copy(eptr, p, elen, char);
10512 SvCUR_set(sv, p - SvPVX_const(sv));
10514 continue; /* not "break" */
10517 if (is_utf8 != has_utf8) {
10520 sv_utf8_upgrade(sv);
10523 const STRLEN old_elen = elen;
10524 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
10525 sv_utf8_upgrade(nsv);
10526 eptr = SvPVX_const(nsv);
10529 if (width) { /* fudge width (can't fudge elen) */
10530 width += elen - old_elen;
10536 have = esignlen + zeros + elen;
10538 Perl_croak_nocontext("%s", PL_memory_wrap);
10540 need = (have > width ? have : width);
10543 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
10544 Perl_croak_nocontext("%s", PL_memory_wrap);
10545 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10547 if (esignlen && fill == '0') {
10549 for (i = 0; i < (int)esignlen; i++)
10550 *p++ = esignbuf[i];
10552 if (gap && !left) {
10553 memset(p, fill, gap);
10556 if (esignlen && fill != '0') {
10558 for (i = 0; i < (int)esignlen; i++)
10559 *p++ = esignbuf[i];
10563 for (i = zeros; i; i--)
10567 Copy(eptr, p, elen, char);
10571 memset(p, ' ', gap);
10576 Copy(dotstr, p, dotstrlen, char);
10580 vectorize = FALSE; /* done iterating over vecstr */
10587 SvCUR_set(sv, p - SvPVX_const(sv));
10596 /* =========================================================================
10598 =head1 Cloning an interpreter
10600 All the macros and functions in this section are for the private use of
10601 the main function, perl_clone().
10603 The foo_dup() functions make an exact copy of an existing foo thingy.
10604 During the course of a cloning, a hash table is used to map old addresses
10605 to new addresses. The table is created and manipulated with the
10606 ptr_table_* functions.
10610 * =========================================================================*/
10613 #if defined(USE_ITHREADS)
10615 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
10616 #ifndef GpREFCNT_inc
10617 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10621 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
10622 that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
10623 If this changes, please unmerge ss_dup.
10624 Likewise, sv_dup_inc_multiple() relies on this fact. */
10625 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup_inc(s,t))
10626 #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
10627 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
10628 #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
10629 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
10630 #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
10631 #define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t))
10632 #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
10633 #define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t))
10634 #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
10635 #define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t))
10636 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
10637 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
10639 /* clone a parser */
10642 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
10646 PERL_ARGS_ASSERT_PARSER_DUP;
10651 /* look for it in the table first */
10652 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
10656 /* create anew and remember what it is */
10657 Newxz(parser, 1, yy_parser);
10658 ptr_table_store(PL_ptr_table, proto, parser);
10660 /* XXX these not yet duped */
10661 parser->old_parser = NULL;
10662 parser->stack = NULL;
10664 parser->stack_size = 0;
10665 /* XXX parser->stack->state = 0; */
10667 /* XXX eventually, just Copy() most of the parser struct ? */
10669 parser->lex_brackets = proto->lex_brackets;
10670 parser->lex_casemods = proto->lex_casemods;
10671 parser->lex_brackstack = savepvn(proto->lex_brackstack,
10672 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
10673 parser->lex_casestack = savepvn(proto->lex_casestack,
10674 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
10675 parser->lex_defer = proto->lex_defer;
10676 parser->lex_dojoin = proto->lex_dojoin;
10677 parser->lex_expect = proto->lex_expect;
10678 parser->lex_formbrack = proto->lex_formbrack;
10679 parser->lex_inpat = proto->lex_inpat;
10680 parser->lex_inwhat = proto->lex_inwhat;
10681 parser->lex_op = proto->lex_op;
10682 parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
10683 parser->lex_starts = proto->lex_starts;
10684 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
10685 parser->multi_close = proto->multi_close;
10686 parser->multi_open = proto->multi_open;
10687 parser->multi_start = proto->multi_start;
10688 parser->multi_end = proto->multi_end;
10689 parser->pending_ident = proto->pending_ident;
10690 parser->preambled = proto->preambled;
10691 parser->sublex_info = proto->sublex_info; /* XXX not quite right */
10692 parser->linestr = sv_dup_inc(proto->linestr, param);
10693 parser->expect = proto->expect;
10694 parser->copline = proto->copline;
10695 parser->last_lop_op = proto->last_lop_op;
10696 parser->lex_state = proto->lex_state;
10697 parser->rsfp = fp_dup(proto->rsfp, '<', param);
10698 /* rsfp_filters entries have fake IoDIRP() */
10699 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
10700 parser->in_my = proto->in_my;
10701 parser->in_my_stash = hv_dup(proto->in_my_stash, param);
10702 parser->error_count = proto->error_count;
10705 parser->linestr = sv_dup_inc(proto->linestr, param);
10708 char * const ols = SvPVX(proto->linestr);
10709 char * const ls = SvPVX(parser->linestr);
10711 parser->bufptr = ls + (proto->bufptr >= ols ?
10712 proto->bufptr - ols : 0);
10713 parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
10714 proto->oldbufptr - ols : 0);
10715 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
10716 proto->oldoldbufptr - ols : 0);
10717 parser->linestart = ls + (proto->linestart >= ols ?
10718 proto->linestart - ols : 0);
10719 parser->last_uni = ls + (proto->last_uni >= ols ?
10720 proto->last_uni - ols : 0);
10721 parser->last_lop = ls + (proto->last_lop >= ols ?
10722 proto->last_lop - ols : 0);
10724 parser->bufend = ls + SvCUR(parser->linestr);
10727 Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
10731 parser->endwhite = proto->endwhite;
10732 parser->faketokens = proto->faketokens;
10733 parser->lasttoke = proto->lasttoke;
10734 parser->nextwhite = proto->nextwhite;
10735 parser->realtokenstart = proto->realtokenstart;
10736 parser->skipwhite = proto->skipwhite;
10737 parser->thisclose = proto->thisclose;
10738 parser->thismad = proto->thismad;
10739 parser->thisopen = proto->thisopen;
10740 parser->thisstuff = proto->thisstuff;
10741 parser->thistoken = proto->thistoken;
10742 parser->thiswhite = proto->thiswhite;
10744 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
10745 parser->curforce = proto->curforce;
10747 Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
10748 Copy(proto->nexttype, parser->nexttype, 5, I32);
10749 parser->nexttoke = proto->nexttoke;
10752 /* XXX should clone saved_curcop here, but we aren't passed
10753 * proto_perl; so do it in perl_clone_using instead */
10759 /* duplicate a file handle */
10762 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
10766 PERL_ARGS_ASSERT_FP_DUP;
10767 PERL_UNUSED_ARG(type);
10770 return (PerlIO*)NULL;
10772 /* look for it in the table first */
10773 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10777 /* create anew and remember what it is */
10778 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10779 ptr_table_store(PL_ptr_table, fp, ret);
10783 /* duplicate a directory handle */
10786 Perl_dirp_dup(pTHX_ DIR *const dp)
10788 PERL_UNUSED_CONTEXT;
10795 /* duplicate a typeglob */
10798 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
10802 PERL_ARGS_ASSERT_GP_DUP;
10806 /* look for it in the table first */
10807 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10811 /* create anew and remember what it is */
10813 ptr_table_store(PL_ptr_table, gp, ret);
10816 /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
10817 on Newxz() to do this for us. */
10818 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10819 ret->gp_io = io_dup_inc(gp->gp_io, param);
10820 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10821 ret->gp_av = av_dup_inc(gp->gp_av, param);
10822 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10823 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10824 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10825 ret->gp_cvgen = gp->gp_cvgen;
10826 ret->gp_line = gp->gp_line;
10827 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
10831 /* duplicate a chain of magic */
10834 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
10836 MAGIC *mgret = NULL;
10837 MAGIC **mgprev_p = &mgret;
10839 PERL_ARGS_ASSERT_MG_DUP;
10841 for (; mg; mg = mg->mg_moremagic) {
10844 if ((param->flags & CLONEf_JOIN_IN)
10845 && mg->mg_type == PERL_MAGIC_backref)
10846 /* when joining, we let the individual SVs add themselves to
10847 * backref as needed. */
10850 Newx(nmg, 1, MAGIC);
10852 mgprev_p = &(nmg->mg_moremagic);
10854 /* There was a comment "XXX copy dynamic vtable?" but as we don't have
10855 dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
10856 from the original commit adding Perl_mg_dup() - revision 4538.
10857 Similarly there is the annotation "XXX random ptr?" next to the
10858 assignment to nmg->mg_ptr. */
10861 /* FIXME for plugins
10862 if (nmg->mg_type == PERL_MAGIC_qr) {
10863 nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
10867 nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
10868 ? nmg->mg_type == PERL_MAGIC_backref
10869 /* The backref AV has its reference
10870 * count deliberately bumped by 1 */
10871 ? SvREFCNT_inc(av_dup_inc((const AV *)
10872 nmg->mg_obj, param))
10873 : sv_dup_inc(nmg->mg_obj, param)
10874 : sv_dup(nmg->mg_obj, param);
10876 if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
10877 if (nmg->mg_len > 0) {
10878 nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
10879 if (nmg->mg_type == PERL_MAGIC_overload_table &&
10880 AMT_AMAGIC((AMT*)nmg->mg_ptr))
10882 AMT * const namtp = (AMT*)nmg->mg_ptr;
10883 sv_dup_inc_multiple((SV**)(namtp->table),
10884 (SV**)(namtp->table), NofAMmeth, param);
10887 else if (nmg->mg_len == HEf_SVKEY)
10888 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
10890 if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
10891 nmg->mg_virtual->svt_dup(aTHX_ nmg, param);
10897 #endif /* USE_ITHREADS */
10899 struct ptr_tbl_arena {
10900 struct ptr_tbl_arena *next;
10901 struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */
10904 /* create a new pointer-mapping table */
10907 Perl_ptr_table_new(pTHX)
10910 PERL_UNUSED_CONTEXT;
10912 Newx(tbl, 1, PTR_TBL_t);
10913 tbl->tbl_max = 511;
10914 tbl->tbl_items = 0;
10915 tbl->tbl_arena = NULL;
10916 tbl->tbl_arena_next = NULL;
10917 tbl->tbl_arena_end = NULL;
10918 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10922 #define PTR_TABLE_HASH(ptr) \
10923 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
10925 /* map an existing pointer using a table */
10927 STATIC PTR_TBL_ENT_t *
10928 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
10930 PTR_TBL_ENT_t *tblent;
10931 const UV hash = PTR_TABLE_HASH(sv);
10933 PERL_ARGS_ASSERT_PTR_TABLE_FIND;
10935 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10936 for (; tblent; tblent = tblent->next) {
10937 if (tblent->oldval == sv)
10944 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
10946 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
10948 PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
10949 PERL_UNUSED_CONTEXT;
10951 return tblent ? tblent->newval : NULL;
10954 /* add a new entry to a pointer-mapping table */
10957 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
10959 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
10961 PERL_ARGS_ASSERT_PTR_TABLE_STORE;
10962 PERL_UNUSED_CONTEXT;
10965 tblent->newval = newsv;
10967 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
10969 if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
10970 struct ptr_tbl_arena *new_arena;
10972 Newx(new_arena, 1, struct ptr_tbl_arena);
10973 new_arena->next = tbl->tbl_arena;
10974 tbl->tbl_arena = new_arena;
10975 tbl->tbl_arena_next = new_arena->array;
10976 tbl->tbl_arena_end = new_arena->array
10977 + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
10980 tblent = tbl->tbl_arena_next++;
10982 tblent->oldval = oldsv;
10983 tblent->newval = newsv;
10984 tblent->next = tbl->tbl_ary[entry];
10985 tbl->tbl_ary[entry] = tblent;
10987 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
10988 ptr_table_split(tbl);
10992 /* double the hash bucket size of an existing ptr table */
10995 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
10997 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10998 const UV oldsize = tbl->tbl_max + 1;
10999 UV newsize = oldsize * 2;
11002 PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
11003 PERL_UNUSED_CONTEXT;
11005 Renew(ary, newsize, PTR_TBL_ENT_t*);
11006 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
11007 tbl->tbl_max = --newsize;
11008 tbl->tbl_ary = ary;
11009 for (i=0; i < oldsize; i++, ary++) {
11010 PTR_TBL_ENT_t **entp = ary;
11011 PTR_TBL_ENT_t *ent = *ary;
11012 PTR_TBL_ENT_t **curentp;
11015 curentp = ary + oldsize;
11017 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
11019 ent->next = *curentp;
11029 /* remove all the entries from a ptr table */
11030 /* Deprecated - will be removed post 5.14 */
11033 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
11035 if (tbl && tbl->tbl_items) {
11036 struct ptr_tbl_arena *arena = tbl->tbl_arena;
11038 Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
11041 struct ptr_tbl_arena *next = arena->next;
11047 tbl->tbl_items = 0;
11048 tbl->tbl_arena = NULL;
11049 tbl->tbl_arena_next = NULL;
11050 tbl->tbl_arena_end = NULL;
11054 /* clear and free a ptr table */
11057 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
11059 struct ptr_tbl_arena *arena;
11065 arena = tbl->tbl_arena;
11068 struct ptr_tbl_arena *next = arena->next;
11074 Safefree(tbl->tbl_ary);
11078 #if defined(USE_ITHREADS)
11081 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
11083 PERL_ARGS_ASSERT_RVPV_DUP;
11086 if (SvWEAKREF(sstr)) {
11087 SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
11088 if (param->flags & CLONEf_JOIN_IN) {
11089 /* if joining, we add any back references individually rather
11090 * than copying the whole backref array */
11091 Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
11095 SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
11097 else if (SvPVX_const(sstr)) {
11098 /* Has something there */
11100 /* Normal PV - clone whole allocated space */
11101 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
11102 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
11103 /* Not that normal - actually sstr is copy on write.
11104 But we are a true, independant SV, so: */
11105 SvREADONLY_off(dstr);
11110 /* Special case - not normally malloced for some reason */
11111 if (isGV_with_GP(sstr)) {
11112 /* Don't need to do anything here. */
11114 else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
11115 /* A "shared" PV - clone it as "shared" PV */
11117 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
11121 /* Some other special case - random pointer */
11122 SvPV_set(dstr, (char *) SvPVX_const(sstr));
11127 /* Copy the NULL */
11128 SvPV_set(dstr, NULL);
11132 /* duplicate a list of SVs. source and dest may point to the same memory. */
11134 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
11135 SSize_t items, CLONE_PARAMS *const param)
11137 PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
11139 while (items-- > 0) {
11140 *dest++ = sv_dup_inc(*source++, param);
11146 /* duplicate an SV of any type (including AV, HV etc) */
11149 S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11154 PERL_ARGS_ASSERT_SV_DUP_COMMON;
11156 if (SvTYPE(sstr) == SVTYPEMASK) {
11157 #ifdef DEBUG_LEAKING_SCALARS_ABORT
11162 /* look for it in the table first */
11163 dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
11167 if(param->flags & CLONEf_JOIN_IN) {
11168 /** We are joining here so we don't want do clone
11169 something that is bad **/
11170 if (SvTYPE(sstr) == SVt_PVHV) {
11171 const HEK * const hvname = HvNAME_HEK(sstr);
11173 /** don't clone stashes if they already exist **/
11174 dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
11175 ptr_table_store(PL_ptr_table, sstr, dstr);
11181 /* create anew and remember what it is */
11184 #ifdef DEBUG_LEAKING_SCALARS
11185 dstr->sv_debug_optype = sstr->sv_debug_optype;
11186 dstr->sv_debug_line = sstr->sv_debug_line;
11187 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
11188 dstr->sv_debug_parent = (SV*)sstr;
11189 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
11192 ptr_table_store(PL_ptr_table, sstr, dstr);
11195 SvFLAGS(dstr) = SvFLAGS(sstr);
11196 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
11197 SvREFCNT(dstr) = 0; /* must be before any other dups! */
11200 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
11201 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
11202 (void*)PL_watch_pvx, SvPVX_const(sstr));
11205 /* don't clone objects whose class has asked us not to */
11206 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
11211 switch (SvTYPE(sstr)) {
11213 SvANY(dstr) = NULL;
11216 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
11218 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11220 SvIV_set(dstr, SvIVX(sstr));
11224 SvANY(dstr) = new_XNV();
11225 SvNV_set(dstr, SvNVX(sstr));
11227 /* case SVt_BIND: */
11230 /* These are all the types that need complex bodies allocating. */
11232 const svtype sv_type = SvTYPE(sstr);
11233 const struct body_details *const sv_type_details
11234 = bodies_by_type + sv_type;
11238 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11253 assert(sv_type_details->body_size);
11254 if (sv_type_details->arena) {
11255 new_body_inline(new_body, sv_type);
11257 = (void*)((char*)new_body - sv_type_details->offset);
11259 new_body = new_NOARENA(sv_type_details);
11263 SvANY(dstr) = new_body;
11266 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
11267 ((char*)SvANY(dstr)) + sv_type_details->offset,
11268 sv_type_details->copy, char);
11270 Copy(((char*)SvANY(sstr)),
11271 ((char*)SvANY(dstr)),
11272 sv_type_details->body_size + sv_type_details->offset, char);
11275 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
11276 && !isGV_with_GP(dstr)
11277 && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
11278 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11280 /* The Copy above means that all the source (unduplicated) pointers
11281 are now in the destination. We can check the flags and the
11282 pointers in either, but it's possible that there's less cache
11283 missing by always going for the destination.
11284 FIXME - instrument and check that assumption */
11285 if (sv_type >= SVt_PVMG) {
11286 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
11287 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
11288 } else if (SvMAGIC(dstr))
11289 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
11291 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
11294 /* The cast silences a GCC warning about unhandled types. */
11295 switch ((int)sv_type) {
11305 /* FIXME for plugins */
11306 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
11309 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
11310 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
11311 LvTARG(dstr) = dstr;
11312 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
11313 LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
11315 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
11317 /* non-GP case already handled above */
11318 if(isGV_with_GP(sstr)) {
11319 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
11320 /* Don't call sv_add_backref here as it's going to be
11321 created as part of the magic cloning of the symbol
11322 table--unless this is during a join and the stash
11323 is not actually being cloned. */
11324 /* Danger Will Robinson - GvGP(dstr) isn't initialised
11325 at the point of this comment. */
11326 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
11327 if (param->flags & CLONEf_JOIN_IN)
11328 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
11329 GvGP(dstr) = gp_dup(GvGP(sstr), param);
11330 (void)GpREFCNT_inc(GvGP(dstr));
11334 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
11335 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
11336 /* I have no idea why fake dirp (rsfps)
11337 should be treated differently but otherwise
11338 we end up with leaks -- sky*/
11339 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
11340 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
11341 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
11343 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
11344 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
11345 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
11346 if (IoDIRP(dstr)) {
11347 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
11350 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
11352 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param);
11354 if (IoOFP(dstr) == IoIFP(sstr))
11355 IoOFP(dstr) = IoIFP(dstr);
11357 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
11358 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
11359 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
11360 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
11363 /* avoid cloning an empty array */
11364 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
11365 SV **dst_ary, **src_ary;
11366 SSize_t items = AvFILLp((const AV *)sstr) + 1;
11368 src_ary = AvARRAY((const AV *)sstr);
11369 Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
11370 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
11371 AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
11372 AvALLOC((const AV *)dstr) = dst_ary;
11373 if (AvREAL((const AV *)sstr)) {
11374 dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
11378 while (items-- > 0)
11379 *dst_ary++ = sv_dup(*src_ary++, param);
11381 items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
11382 while (items-- > 0) {
11383 *dst_ary++ = &PL_sv_undef;
11387 AvARRAY(MUTABLE_AV(dstr)) = NULL;
11388 AvALLOC((const AV *)dstr) = (SV**)NULL;
11389 AvMAX( (const AV *)dstr) = -1;
11390 AvFILLp((const AV *)dstr) = -1;
11394 if (HvARRAY((const HV *)sstr)) {
11396 const bool sharekeys = !!HvSHAREKEYS(sstr);
11397 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
11398 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
11400 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
11401 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
11403 HvARRAY(dstr) = (HE**)darray;
11404 while (i <= sxhv->xhv_max) {
11405 const HE * const source = HvARRAY(sstr)[i];
11406 HvARRAY(dstr)[i] = source
11407 ? he_dup(source, sharekeys, param) : 0;
11412 const struct xpvhv_aux * const saux = HvAUX(sstr);
11413 struct xpvhv_aux * const daux = HvAUX(dstr);
11414 /* This flag isn't copied. */
11415 /* SvOOK_on(hv) attacks the IV flags. */
11416 SvFLAGS(dstr) |= SVf_OOK;
11418 hvname = saux->xhv_name;
11419 daux->xhv_name = hek_dup(hvname, param);
11421 daux->xhv_riter = saux->xhv_riter;
11422 daux->xhv_eiter = saux->xhv_eiter
11423 ? he_dup(saux->xhv_eiter,
11424 cBOOL(HvSHAREKEYS(sstr)), param) : 0;
11425 /* backref array needs refcnt=2; see sv_add_backref */
11426 daux->xhv_backreferences =
11427 (param->flags & CLONEf_JOIN_IN)
11428 /* when joining, we let the individual GVs and
11429 * CVs add themselves to backref as
11430 * needed. This avoids pulling in stuff
11431 * that isn't required, and simplifies the
11432 * case where stashes aren't cloned back
11433 * if they already exist in the parent
11436 : saux->xhv_backreferences
11437 ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
11438 ? MUTABLE_AV(SvREFCNT_inc(
11439 sv_dup_inc((const SV *)
11440 saux->xhv_backreferences, param)))
11441 : MUTABLE_AV(sv_dup((const SV *)
11442 saux->xhv_backreferences, param))
11445 daux->xhv_mro_meta = saux->xhv_mro_meta
11446 ? mro_meta_dup(saux->xhv_mro_meta, param)
11449 /* Record stashes for possible cloning in Perl_clone(). */
11451 av_push(param->stashes, dstr);
11455 HvARRAY(MUTABLE_HV(dstr)) = NULL;
11458 if (!(param->flags & CLONEf_COPY_STACKS)) {
11463 /* NOTE: not refcounted */
11464 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
11465 if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
11466 Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
11468 if (!CvISXSUB(dstr))
11469 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
11471 if (CvCONST(dstr) && CvISXSUB(dstr)) {
11472 CvXSUBANY(dstr).any_ptr =
11473 sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
11475 /* don't dup if copying back - CvGV isn't refcounted, so the
11476 * duped GV may never be freed. A bit of a hack! DAPM */
11477 SvANY(MUTABLE_CV(dstr))->xcv_gv =
11479 ? gv_dup_inc(CvGV(sstr), param)
11480 : (param->flags & CLONEf_JOIN_IN)
11482 : gv_dup(CvGV(sstr), param);
11484 CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
11486 CvWEAKOUTSIDE(sstr)
11487 ? cv_dup( CvOUTSIDE(dstr), param)
11488 : cv_dup_inc(CvOUTSIDE(dstr), param);
11489 if (!CvISXSUB(dstr))
11490 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
11496 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11503 Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11505 PERL_ARGS_ASSERT_SV_DUP_INC;
11506 return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
11510 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11512 SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
11513 PERL_ARGS_ASSERT_SV_DUP;
11515 /* Track every SV that (at least initially) had a reference count of 0.
11516 We need to do this by holding an actual reference to it in this array.
11517 If we attempt to cheat, turn AvREAL_off(), and store only pointers
11518 (akin to the stashes hash, and the perl stack), we come unstuck if
11519 a weak reference (or other SV legitimately SvREFCNT() == 0 for this
11520 thread) is manipulated in a CLONE method, because CLONE runs before the
11521 unreferenced array is walked to find SVs still with SvREFCNT() == 0
11522 (and fix things up by giving each a reference via the temps stack).
11523 Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
11524 then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
11525 before the walk of unreferenced happens and a reference to that is SV
11526 added to the temps stack. At which point we have the same SV considered
11527 to be in use, and free to be re-used. Not good.
11529 if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
11530 assert(param->unreferenced);
11531 av_push(param->unreferenced, SvREFCNT_inc(dstr));
11537 /* duplicate a context */
11540 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11542 PERL_CONTEXT *ncxs;
11544 PERL_ARGS_ASSERT_CX_DUP;
11547 return (PERL_CONTEXT*)NULL;
11549 /* look for it in the table first */
11550 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11554 /* create anew and remember what it is */
11555 Newx(ncxs, max + 1, PERL_CONTEXT);
11556 ptr_table_store(PL_ptr_table, cxs, ncxs);
11557 Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
11560 PERL_CONTEXT * const ncx = &ncxs[ix];
11561 if (CxTYPE(ncx) == CXt_SUBST) {
11562 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11565 switch (CxTYPE(ncx)) {
11567 ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
11568 ? cv_dup_inc(ncx->blk_sub.cv, param)
11569 : cv_dup(ncx->blk_sub.cv,param));
11570 ncx->blk_sub.argarray = (CxHASARGS(ncx)
11571 ? av_dup_inc(ncx->blk_sub.argarray,
11574 ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
11576 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
11577 ncx->blk_sub.oldcomppad);
11580 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
11582 ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
11584 case CXt_LOOP_LAZYSV:
11585 ncx->blk_loop.state_u.lazysv.end
11586 = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
11587 /* We are taking advantage of av_dup_inc and sv_dup_inc
11588 actually being the same function, and order equivalance of
11590 We can assert the later [but only at run time :-(] */
11591 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
11592 (void *) &ncx->blk_loop.state_u.lazysv.cur);
11594 ncx->blk_loop.state_u.ary.ary
11595 = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
11596 case CXt_LOOP_LAZYIV:
11597 case CXt_LOOP_PLAIN:
11598 if (CxPADLOOP(ncx)) {
11599 ncx->blk_loop.itervar_u.oldcomppad
11600 = (PAD*)ptr_table_fetch(PL_ptr_table,
11601 ncx->blk_loop.itervar_u.oldcomppad);
11603 ncx->blk_loop.itervar_u.gv
11604 = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
11609 ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
11610 ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
11611 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
11624 /* duplicate a stack info structure */
11627 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11631 PERL_ARGS_ASSERT_SI_DUP;
11634 return (PERL_SI*)NULL;
11636 /* look for it in the table first */
11637 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11641 /* create anew and remember what it is */
11642 Newxz(nsi, 1, PERL_SI);
11643 ptr_table_store(PL_ptr_table, si, nsi);
11645 nsi->si_stack = av_dup_inc(si->si_stack, param);
11646 nsi->si_cxix = si->si_cxix;
11647 nsi->si_cxmax = si->si_cxmax;
11648 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11649 nsi->si_type = si->si_type;
11650 nsi->si_prev = si_dup(si->si_prev, param);
11651 nsi->si_next = si_dup(si->si_next, param);
11652 nsi->si_markoff = si->si_markoff;
11657 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
11658 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
11659 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
11660 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
11661 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
11662 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
11663 #define POPUV(ss,ix) ((ss)[--(ix)].any_uv)
11664 #define TOPUV(ss,ix) ((ss)[ix].any_uv)
11665 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
11666 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
11667 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
11668 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
11669 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
11670 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
11671 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11672 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11675 #define pv_dup_inc(p) SAVEPV(p)
11676 #define pv_dup(p) SAVEPV(p)
11677 #define svp_dup_inc(p,pp) any_dup(p,pp)
11679 /* map any object to the new equivent - either something in the
11680 * ptr table, or something in the interpreter structure
11684 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
11688 PERL_ARGS_ASSERT_ANY_DUP;
11691 return (void*)NULL;
11693 /* look for it in the table first */
11694 ret = ptr_table_fetch(PL_ptr_table, v);
11698 /* see if it is part of the interpreter structure */
11699 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11700 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11708 /* duplicate the save stack */
11711 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11714 ANY * const ss = proto_perl->Isavestack;
11715 const I32 max = proto_perl->Isavestack_max;
11716 I32 ix = proto_perl->Isavestack_ix;
11729 void (*dptr) (void*);
11730 void (*dxptr) (pTHX_ void*);
11732 PERL_ARGS_ASSERT_SS_DUP;
11734 Newxz(nss, max, ANY);
11737 const UV uv = POPUV(ss,ix);
11738 const U8 type = (U8)uv & SAVE_MASK;
11740 TOPUV(nss,ix) = uv;
11742 case SAVEt_CLEARSV:
11744 case SAVEt_HELEM: /* hash element */
11745 sv = (const SV *)POPPTR(ss,ix);
11746 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11748 case SAVEt_ITEM: /* normal string */
11749 case SAVEt_GVSV: /* scalar slot in GV */
11750 case SAVEt_SV: /* scalar reference */
11751 sv = (const SV *)POPPTR(ss,ix);
11752 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11755 case SAVEt_MORTALIZESV:
11756 sv = (const SV *)POPPTR(ss,ix);
11757 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11759 case SAVEt_SHARED_PVREF: /* char* in shared space */
11760 c = (char*)POPPTR(ss,ix);
11761 TOPPTR(nss,ix) = savesharedpv(c);
11762 ptr = POPPTR(ss,ix);
11763 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11765 case SAVEt_GENERIC_SVREF: /* generic sv */
11766 case SAVEt_SVREF: /* scalar reference */
11767 sv = (const SV *)POPPTR(ss,ix);
11768 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11769 ptr = POPPTR(ss,ix);
11770 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11772 case SAVEt_HV: /* hash reference */
11773 case SAVEt_AV: /* array reference */
11774 sv = (const SV *) POPPTR(ss,ix);
11775 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11777 case SAVEt_COMPPAD:
11779 sv = (const SV *) POPPTR(ss,ix);
11780 TOPPTR(nss,ix) = sv_dup(sv, param);
11782 case SAVEt_INT: /* int reference */
11783 ptr = POPPTR(ss,ix);
11784 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11785 intval = (int)POPINT(ss,ix);
11786 TOPINT(nss,ix) = intval;
11788 case SAVEt_LONG: /* long reference */
11789 ptr = POPPTR(ss,ix);
11790 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11791 longval = (long)POPLONG(ss,ix);
11792 TOPLONG(nss,ix) = longval;
11794 case SAVEt_I32: /* I32 reference */
11795 case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
11796 ptr = POPPTR(ss,ix);
11797 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11799 TOPINT(nss,ix) = i;
11801 case SAVEt_IV: /* IV reference */
11802 ptr = POPPTR(ss,ix);
11803 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11805 TOPIV(nss,ix) = iv;
11807 case SAVEt_HPTR: /* HV* reference */
11808 case SAVEt_APTR: /* AV* reference */
11809 case SAVEt_SPTR: /* SV* reference */
11810 ptr = POPPTR(ss,ix);
11811 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11812 sv = (const SV *)POPPTR(ss,ix);
11813 TOPPTR(nss,ix) = sv_dup(sv, param);
11815 case SAVEt_VPTR: /* random* reference */
11816 ptr = POPPTR(ss,ix);
11817 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11819 case SAVEt_INT_SMALL:
11820 case SAVEt_I32_SMALL:
11821 case SAVEt_I16: /* I16 reference */
11822 case SAVEt_I8: /* I8 reference */
11824 ptr = POPPTR(ss,ix);
11825 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11827 case SAVEt_GENERIC_PVREF: /* generic char* */
11828 case SAVEt_PPTR: /* char* reference */
11829 ptr = POPPTR(ss,ix);
11830 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11831 c = (char*)POPPTR(ss,ix);
11832 TOPPTR(nss,ix) = pv_dup(c);
11834 case SAVEt_GP: /* scalar reference */
11835 gv = (const GV *)POPPTR(ss,ix);
11836 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11837 gp = (GP*)POPPTR(ss,ix);
11838 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11839 (void)GpREFCNT_inc(gp);
11841 TOPINT(nss,ix) = i;
11844 ptr = POPPTR(ss,ix);
11845 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11846 /* these are assumed to be refcounted properly */
11848 switch (((OP*)ptr)->op_type) {
11850 case OP_LEAVESUBLV:
11854 case OP_LEAVEWRITE:
11855 TOPPTR(nss,ix) = ptr;
11858 (void) OpREFCNT_inc(o);
11862 TOPPTR(nss,ix) = NULL;
11867 TOPPTR(nss,ix) = NULL;
11870 hv = (const HV *)POPPTR(ss,ix);
11871 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11873 TOPINT(nss,ix) = i;
11876 c = (char*)POPPTR(ss,ix);
11877 TOPPTR(nss,ix) = pv_dup_inc(c);
11879 case SAVEt_STACK_POS: /* Position on Perl stack */
11881 TOPINT(nss,ix) = i;
11883 case SAVEt_DESTRUCTOR:
11884 ptr = POPPTR(ss,ix);
11885 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11886 dptr = POPDPTR(ss,ix);
11887 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
11888 any_dup(FPTR2DPTR(void *, dptr),
11891 case SAVEt_DESTRUCTOR_X:
11892 ptr = POPPTR(ss,ix);
11893 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11894 dxptr = POPDXPTR(ss,ix);
11895 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
11896 any_dup(FPTR2DPTR(void *, dxptr),
11899 case SAVEt_REGCONTEXT:
11901 ix -= uv >> SAVE_TIGHT_SHIFT;
11903 case SAVEt_AELEM: /* array element */
11904 sv = (const SV *)POPPTR(ss,ix);
11905 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11907 TOPINT(nss,ix) = i;
11908 av = (const AV *)POPPTR(ss,ix);
11909 TOPPTR(nss,ix) = av_dup_inc(av, param);
11912 ptr = POPPTR(ss,ix);
11913 TOPPTR(nss,ix) = ptr;
11916 ptr = POPPTR(ss,ix);
11919 ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
11920 HINTS_REFCNT_UNLOCK;
11922 TOPPTR(nss,ix) = ptr;
11924 TOPINT(nss,ix) = i;
11925 if (i & HINT_LOCALIZE_HH) {
11926 hv = (const HV *)POPPTR(ss,ix);
11927 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11930 case SAVEt_PADSV_AND_MORTALIZE:
11931 longval = (long)POPLONG(ss,ix);
11932 TOPLONG(nss,ix) = longval;
11933 ptr = POPPTR(ss,ix);
11934 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11935 sv = (const SV *)POPPTR(ss,ix);
11936 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11938 case SAVEt_SET_SVFLAGS:
11940 TOPINT(nss,ix) = i;
11942 TOPINT(nss,ix) = i;
11943 sv = (const SV *)POPPTR(ss,ix);
11944 TOPPTR(nss,ix) = sv_dup(sv, param);
11946 case SAVEt_RE_STATE:
11948 const struct re_save_state *const old_state
11949 = (struct re_save_state *)
11950 (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11951 struct re_save_state *const new_state
11952 = (struct re_save_state *)
11953 (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11955 Copy(old_state, new_state, 1, struct re_save_state);
11956 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11958 new_state->re_state_bostr
11959 = pv_dup(old_state->re_state_bostr);
11960 new_state->re_state_reginput
11961 = pv_dup(old_state->re_state_reginput);
11962 new_state->re_state_regeol
11963 = pv_dup(old_state->re_state_regeol);
11964 new_state->re_state_regoffs
11965 = (regexp_paren_pair*)
11966 any_dup(old_state->re_state_regoffs, proto_perl);
11967 new_state->re_state_reglastparen
11968 = (U32*) any_dup(old_state->re_state_reglastparen,
11970 new_state->re_state_reglastcloseparen
11971 = (U32*)any_dup(old_state->re_state_reglastcloseparen,
11973 /* XXX This just has to be broken. The old save_re_context
11974 code did SAVEGENERICPV(PL_reg_start_tmp);
11975 PL_reg_start_tmp is char **.
11976 Look above to what the dup code does for
11977 SAVEt_GENERIC_PVREF
11978 It can never have worked.
11979 So this is merely a faithful copy of the exiting bug: */
11980 new_state->re_state_reg_start_tmp
11981 = (char **) pv_dup((char *)
11982 old_state->re_state_reg_start_tmp);
11983 /* I assume that it only ever "worked" because no-one called
11984 (pseudo)fork while the regexp engine had re-entered itself.
11986 #ifdef PERL_OLD_COPY_ON_WRITE
11987 new_state->re_state_nrs
11988 = sv_dup(old_state->re_state_nrs, param);
11990 new_state->re_state_reg_magic
11991 = (MAGIC*) any_dup(old_state->re_state_reg_magic,
11993 new_state->re_state_reg_oldcurpm
11994 = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
11996 new_state->re_state_reg_curpm
11997 = (PMOP*) any_dup(old_state->re_state_reg_curpm,
11999 new_state->re_state_reg_oldsaved
12000 = pv_dup(old_state->re_state_reg_oldsaved);
12001 new_state->re_state_reg_poscache
12002 = pv_dup(old_state->re_state_reg_poscache);
12003 new_state->re_state_reg_starttry
12004 = pv_dup(old_state->re_state_reg_starttry);
12007 case SAVEt_COMPILE_WARNINGS:
12008 ptr = POPPTR(ss,ix);
12009 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
12012 ptr = POPPTR(ss,ix);
12013 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
12017 "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
12025 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
12026 * flag to the result. This is done for each stash before cloning starts,
12027 * so we know which stashes want their objects cloned */
12030 do_mark_cloneable_stash(pTHX_ SV *const sv)
12032 const HEK * const hvname = HvNAME_HEK((const HV *)sv);
12034 GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
12035 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
12036 if (cloner && GvCV(cloner)) {
12043 mXPUSHs(newSVhek(hvname));
12045 call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
12052 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
12060 =for apidoc perl_clone
12062 Create and return a new interpreter by cloning the current one.
12064 perl_clone takes these flags as parameters:
12066 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
12067 without it we only clone the data and zero the stacks,
12068 with it we copy the stacks and the new perl interpreter is
12069 ready to run at the exact same point as the previous one.
12070 The pseudo-fork code uses COPY_STACKS while the
12071 threads->create doesn't.
12073 CLONEf_KEEP_PTR_TABLE
12074 perl_clone keeps a ptr_table with the pointer of the old
12075 variable as a key and the new variable as a value,
12076 this allows it to check if something has been cloned and not
12077 clone it again but rather just use the value and increase the
12078 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
12079 the ptr_table using the function
12080 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
12081 reason to keep it around is if you want to dup some of your own
12082 variable who are outside the graph perl scans, example of this
12083 code is in threads.xs create
12086 This is a win32 thing, it is ignored on unix, it tells perls
12087 win32host code (which is c++) to clone itself, this is needed on
12088 win32 if you want to run two threads at the same time,
12089 if you just want to do some stuff in a separate perl interpreter
12090 and then throw it away and return to the original one,
12091 you don't need to do anything.
12096 /* XXX the above needs expanding by someone who actually understands it ! */
12097 EXTERN_C PerlInterpreter *
12098 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
12101 perl_clone(PerlInterpreter *proto_perl, UV flags)
12104 #ifdef PERL_IMPLICIT_SYS
12106 PERL_ARGS_ASSERT_PERL_CLONE;
12108 /* perlhost.h so we need to call into it
12109 to clone the host, CPerlHost should have a c interface, sky */
12111 if (flags & CLONEf_CLONE_HOST) {
12112 return perl_clone_host(proto_perl,flags);
12114 return perl_clone_using(proto_perl, flags,
12116 proto_perl->IMemShared,
12117 proto_perl->IMemParse,
12119 proto_perl->IStdIO,
12123 proto_perl->IProc);
12127 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
12128 struct IPerlMem* ipM, struct IPerlMem* ipMS,
12129 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
12130 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
12131 struct IPerlDir* ipD, struct IPerlSock* ipS,
12132 struct IPerlProc* ipP)
12134 /* XXX many of the string copies here can be optimized if they're
12135 * constants; they need to be allocated as common memory and just
12136 * their pointers copied. */
12139 CLONE_PARAMS clone_params;
12140 CLONE_PARAMS* const param = &clone_params;
12142 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
12144 PERL_ARGS_ASSERT_PERL_CLONE_USING;
12145 #else /* !PERL_IMPLICIT_SYS */
12147 CLONE_PARAMS clone_params;
12148 CLONE_PARAMS* param = &clone_params;
12149 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
12151 PERL_ARGS_ASSERT_PERL_CLONE;
12152 #endif /* PERL_IMPLICIT_SYS */
12154 /* for each stash, determine whether its objects should be cloned */
12155 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
12156 PERL_SET_THX(my_perl);
12159 PoisonNew(my_perl, 1, PerlInterpreter);
12164 PL_scopestack_name = 0;
12166 PL_savestack_ix = 0;
12167 PL_savestack_max = -1;
12168 PL_sig_pending = 0;
12170 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
12171 # ifdef DEBUG_LEAKING_SCALARS
12172 PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
12174 #else /* !DEBUGGING */
12175 Zero(my_perl, 1, PerlInterpreter);
12176 #endif /* DEBUGGING */
12178 #ifdef PERL_IMPLICIT_SYS
12179 /* host pointers */
12181 PL_MemShared = ipMS;
12182 PL_MemParse = ipMP;
12189 #endif /* PERL_IMPLICIT_SYS */
12191 param->flags = flags;
12192 /* Nothing in the core code uses this, but we make it available to
12193 extensions (using mg_dup). */
12194 param->proto_perl = proto_perl;
12195 /* Likely nothing will use this, but it is initialised to be consistent
12196 with Perl_clone_params_new(). */
12197 param->proto_perl = my_perl;
12198 param->unreferenced = NULL;
12200 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
12202 PL_body_arenas = NULL;
12203 Zero(&PL_body_roots, 1, PL_body_roots);
12206 PL_sv_objcount = 0;
12208 PL_sv_arenaroot = NULL;
12210 PL_debug = proto_perl->Idebug;
12212 PL_hash_seed = proto_perl->Ihash_seed;
12213 PL_rehash_seed = proto_perl->Irehash_seed;
12215 #ifdef USE_REENTRANT_API
12216 /* XXX: things like -Dm will segfault here in perlio, but doing
12217 * PERL_SET_CONTEXT(proto_perl);
12218 * breaks too many other things
12220 Perl_reentrant_init(aTHX);
12223 /* create SV map for pointer relocation */
12224 PL_ptr_table = ptr_table_new();
12226 /* initialize these special pointers as early as possible */
12227 SvANY(&PL_sv_undef) = NULL;
12228 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
12229 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
12230 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
12232 SvANY(&PL_sv_no) = new_XPVNV();
12233 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
12234 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12235 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12236 SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
12237 SvCUR_set(&PL_sv_no, 0);
12238 SvLEN_set(&PL_sv_no, 1);
12239 SvIV_set(&PL_sv_no, 0);
12240 SvNV_set(&PL_sv_no, 0);
12241 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
12243 SvANY(&PL_sv_yes) = new_XPVNV();
12244 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
12245 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12246 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12247 SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
12248 SvCUR_set(&PL_sv_yes, 1);
12249 SvLEN_set(&PL_sv_yes, 2);
12250 SvIV_set(&PL_sv_yes, 1);
12251 SvNV_set(&PL_sv_yes, 1);
12252 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
12254 /* dbargs array probably holds garbage */
12257 /* create (a non-shared!) shared string table */
12258 PL_strtab = newHV();
12259 HvSHAREKEYS_off(PL_strtab);
12260 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
12261 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
12263 PL_compiling = proto_perl->Icompiling;
12265 /* These two PVs will be free'd special way so must set them same way op.c does */
12266 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
12267 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
12269 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
12270 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
12272 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
12273 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
12274 if (PL_compiling.cop_hints_hash) {
12276 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
12277 HINTS_REFCNT_UNLOCK;
12279 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
12280 #ifdef PERL_DEBUG_READONLY_OPS
12285 /* pseudo environmental stuff */
12286 PL_origargc = proto_perl->Iorigargc;
12287 PL_origargv = proto_perl->Iorigargv;
12289 param->stashes = newAV(); /* Setup array of objects to call clone on */
12290 /* This makes no difference to the implementation, as it always pushes
12291 and shifts pointers to other SVs without changing their reference
12292 count, with the array becoming empty before it is freed. However, it
12293 makes it conceptually clear what is going on, and will avoid some
12294 work inside av.c, filling slots between AvFILL() and AvMAX() with
12295 &PL_sv_undef, and SvREFCNT_dec()ing those. */
12296 AvREAL_off(param->stashes);
12298 if (!(flags & CLONEf_COPY_STACKS)) {
12299 param->unreferenced = newAV();
12302 /* Set tainting stuff before PerlIO_debug can possibly get called */
12303 PL_tainting = proto_perl->Itainting;
12304 PL_taint_warn = proto_perl->Itaint_warn;
12306 #ifdef PERLIO_LAYERS
12307 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
12308 PerlIO_clone(aTHX_ proto_perl, param);
12311 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
12312 PL_incgv = gv_dup(proto_perl->Iincgv, param);
12313 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
12314 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
12315 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
12316 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
12319 PL_minus_c = proto_perl->Iminus_c;
12320 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
12321 PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
12322 PL_localpatches = proto_perl->Ilocalpatches;
12323 PL_splitstr = proto_perl->Isplitstr;
12324 PL_minus_n = proto_perl->Iminus_n;
12325 PL_minus_p = proto_perl->Iminus_p;
12326 PL_minus_l = proto_perl->Iminus_l;
12327 PL_minus_a = proto_perl->Iminus_a;
12328 PL_minus_E = proto_perl->Iminus_E;
12329 PL_minus_F = proto_perl->Iminus_F;
12330 PL_doswitches = proto_perl->Idoswitches;
12331 PL_dowarn = proto_perl->Idowarn;
12332 PL_doextract = proto_perl->Idoextract;
12333 PL_sawampersand = proto_perl->Isawampersand;
12334 PL_unsafe = proto_perl->Iunsafe;
12335 PL_inplace = SAVEPV(proto_perl->Iinplace);
12336 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
12337 PL_perldb = proto_perl->Iperldb;
12338 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
12339 PL_exit_flags = proto_perl->Iexit_flags;
12341 /* magical thingies */
12342 /* XXX time(&PL_basetime) when asked for? */
12343 PL_basetime = proto_perl->Ibasetime;
12344 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
12346 PL_maxsysfd = proto_perl->Imaxsysfd;
12347 PL_statusvalue = proto_perl->Istatusvalue;
12349 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
12351 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
12353 PL_encoding = sv_dup(proto_perl->Iencoding, param);
12355 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
12356 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
12357 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
12360 /* RE engine related */
12361 Zero(&PL_reg_state, 1, struct re_save_state);
12362 PL_reginterp_cnt = 0;
12363 PL_regmatch_slab = NULL;
12365 /* Clone the regex array */
12366 /* ORANGE FIXME for plugins, probably in the SV dup code.
12367 newSViv(PTR2IV(CALLREGDUPE(
12368 INT2PTR(REGEXP *, SvIVX(regex)), param))))
12370 PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
12371 PL_regex_pad = AvARRAY(PL_regex_padav);
12373 /* shortcuts to various I/O objects */
12374 PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param);
12375 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
12376 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
12377 PL_defgv = gv_dup(proto_perl->Idefgv, param);
12378 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
12379 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
12380 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
12382 /* shortcuts to regexp stuff */
12383 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
12385 /* shortcuts to misc objects */
12386 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
12388 /* shortcuts to debugging objects */
12389 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
12390 PL_DBline = gv_dup(proto_perl->IDBline, param);
12391 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
12392 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
12393 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
12394 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
12396 /* symbol tables */
12397 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
12398 PL_curstash = hv_dup(proto_perl->Icurstash, param);
12399 PL_debstash = hv_dup(proto_perl->Idebstash, param);
12400 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
12401 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
12403 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
12404 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
12405 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
12406 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
12407 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
12408 PL_endav = av_dup_inc(proto_perl->Iendav, param);
12409 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
12410 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
12412 PL_sub_generation = proto_perl->Isub_generation;
12413 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
12415 /* funky return mechanisms */
12416 PL_forkprocess = proto_perl->Iforkprocess;
12418 /* subprocess state */
12419 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
12421 /* internal state */
12422 PL_maxo = proto_perl->Imaxo;
12423 if (proto_perl->Iop_mask)
12424 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
12427 /* PL_asserting = proto_perl->Iasserting; */
12429 /* current interpreter roots */
12430 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
12432 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
12434 PL_main_start = proto_perl->Imain_start;
12435 PL_eval_root = proto_perl->Ieval_root;
12436 PL_eval_start = proto_perl->Ieval_start;
12438 /* runtime control stuff */
12439 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
12441 PL_filemode = proto_perl->Ifilemode;
12442 PL_lastfd = proto_perl->Ilastfd;
12443 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
12446 PL_gensym = proto_perl->Igensym;
12447 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
12448 PL_laststatval = proto_perl->Ilaststatval;
12449 PL_laststype = proto_perl->Ilaststype;
12452 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
12454 /* interpreter atexit processing */
12455 PL_exitlistlen = proto_perl->Iexitlistlen;
12456 if (PL_exitlistlen) {
12457 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12458 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12461 PL_exitlist = (PerlExitListEntry*)NULL;
12463 PL_my_cxt_size = proto_perl->Imy_cxt_size;
12464 if (PL_my_cxt_size) {
12465 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
12466 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
12467 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12468 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
12469 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
12473 PL_my_cxt_list = (void**)NULL;
12474 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12475 PL_my_cxt_keys = (const char**)NULL;
12478 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
12479 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
12480 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
12482 PL_profiledata = NULL;
12484 PL_compcv = cv_dup(proto_perl->Icompcv, param);
12486 PAD_CLONE_VARS(proto_perl, param);
12488 #ifdef HAVE_INTERP_INTERN
12489 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
12492 /* more statics moved here */
12493 PL_generation = proto_perl->Igeneration;
12494 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
12496 PL_in_clean_objs = proto_perl->Iin_clean_objs;
12497 PL_in_clean_all = proto_perl->Iin_clean_all;
12499 PL_uid = proto_perl->Iuid;
12500 PL_euid = proto_perl->Ieuid;
12501 PL_gid = proto_perl->Igid;
12502 PL_egid = proto_perl->Iegid;
12503 PL_nomemok = proto_perl->Inomemok;
12504 PL_an = proto_perl->Ian;
12505 PL_evalseq = proto_perl->Ievalseq;
12506 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
12507 PL_origalen = proto_perl->Iorigalen;
12508 #ifdef PERL_USES_PL_PIDSTATUS
12509 PL_pidstatus = newHV(); /* XXX flag for cloning? */
12511 PL_osname = SAVEPV(proto_perl->Iosname);
12512 PL_sighandlerp = proto_perl->Isighandlerp;
12514 PL_runops = proto_perl->Irunops;
12516 PL_parser = parser_dup(proto_perl->Iparser, param);
12518 /* XXX this only works if the saved cop has already been cloned */
12519 if (proto_perl->Iparser) {
12520 PL_parser->saved_curcop = (COP*)any_dup(
12521 proto_perl->Iparser->saved_curcop,
12525 PL_subline = proto_perl->Isubline;
12526 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
12529 PL_cryptseen = proto_perl->Icryptseen;
12532 PL_hints = proto_perl->Ihints;
12534 PL_amagic_generation = proto_perl->Iamagic_generation;
12536 #ifdef USE_LOCALE_COLLATE
12537 PL_collation_ix = proto_perl->Icollation_ix;
12538 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
12539 PL_collation_standard = proto_perl->Icollation_standard;
12540 PL_collxfrm_base = proto_perl->Icollxfrm_base;
12541 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
12542 #endif /* USE_LOCALE_COLLATE */
12544 #ifdef USE_LOCALE_NUMERIC
12545 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
12546 PL_numeric_standard = proto_perl->Inumeric_standard;
12547 PL_numeric_local = proto_perl->Inumeric_local;
12548 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12549 #endif /* !USE_LOCALE_NUMERIC */
12551 /* utf8 character classes */
12552 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12553 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12554 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12555 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
12556 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12557 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
12558 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
12559 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
12560 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
12561 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
12562 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
12563 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12564 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
12565 PL_utf8_X_begin = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
12566 PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
12567 PL_utf8_X_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
12568 PL_utf8_X_non_hangul = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
12569 PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
12570 PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
12571 PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
12572 PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
12573 PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
12574 PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
12575 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12576 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12577 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12578 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12579 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12580 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12582 /* Did the locale setup indicate UTF-8? */
12583 PL_utf8locale = proto_perl->Iutf8locale;
12584 /* Unicode features (see perlrun/-C) */
12585 PL_unicode = proto_perl->Iunicode;
12587 /* Pre-5.8 signals control */
12588 PL_signals = proto_perl->Isignals;
12590 /* times() ticks per second */
12591 PL_clocktick = proto_perl->Iclocktick;
12593 /* Recursion stopper for PerlIO_find_layer */
12594 PL_in_load_module = proto_perl->Iin_load_module;
12596 /* sort() routine */
12597 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
12599 /* Not really needed/useful since the reenrant_retint is "volatile",
12600 * but do it for consistency's sake. */
12601 PL_reentrant_retint = proto_perl->Ireentrant_retint;
12603 /* Hooks to shared SVs and locks. */
12604 PL_sharehook = proto_perl->Isharehook;
12605 PL_lockhook = proto_perl->Ilockhook;
12606 PL_unlockhook = proto_perl->Iunlockhook;
12607 PL_threadhook = proto_perl->Ithreadhook;
12608 PL_destroyhook = proto_perl->Idestroyhook;
12609 PL_signalhook = proto_perl->Isignalhook;
12611 #ifdef THREADS_HAVE_PIDS
12612 PL_ppid = proto_perl->Ippid;
12616 PL_last_swash_hv = NULL; /* reinits on demand */
12617 PL_last_swash_klen = 0;
12618 PL_last_swash_key[0]= '\0';
12619 PL_last_swash_tmps = (U8*)NULL;
12620 PL_last_swash_slen = 0;
12622 PL_glob_index = proto_perl->Iglob_index;
12623 PL_srand_called = proto_perl->Isrand_called;
12625 if (proto_perl->Ipsig_pend) {
12626 Newxz(PL_psig_pend, SIG_SIZE, int);
12629 PL_psig_pend = (int*)NULL;
12632 if (proto_perl->Ipsig_name) {
12633 Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
12634 sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
12636 PL_psig_ptr = PL_psig_name + SIG_SIZE;
12639 PL_psig_ptr = (SV**)NULL;
12640 PL_psig_name = (SV**)NULL;
12643 /* intrpvar.h stuff */
12645 if (flags & CLONEf_COPY_STACKS) {
12646 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12647 PL_tmps_ix = proto_perl->Itmps_ix;
12648 PL_tmps_max = proto_perl->Itmps_max;
12649 PL_tmps_floor = proto_perl->Itmps_floor;
12650 Newx(PL_tmps_stack, PL_tmps_max, SV*);
12651 sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
12652 PL_tmps_ix+1, param);
12654 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12655 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
12656 Newxz(PL_markstack, i, I32);
12657 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
12658 - proto_perl->Imarkstack);
12659 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
12660 - proto_perl->Imarkstack);
12661 Copy(proto_perl->Imarkstack, PL_markstack,
12662 PL_markstack_ptr - PL_markstack + 1, I32);
12664 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12665 * NOTE: unlike the others! */
12666 PL_scopestack_ix = proto_perl->Iscopestack_ix;
12667 PL_scopestack_max = proto_perl->Iscopestack_max;
12668 Newxz(PL_scopestack, PL_scopestack_max, I32);
12669 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
12672 Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
12673 Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
12675 /* NOTE: si_dup() looks at PL_markstack */
12676 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
12678 /* PL_curstack = PL_curstackinfo->si_stack; */
12679 PL_curstack = av_dup(proto_perl->Icurstack, param);
12680 PL_mainstack = av_dup(proto_perl->Imainstack, param);
12682 /* next PUSHs() etc. set *(PL_stack_sp+1) */
12683 PL_stack_base = AvARRAY(PL_curstack);
12684 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
12685 - proto_perl->Istack_base);
12686 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
12688 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12689 * NOTE: unlike the others! */
12690 PL_savestack_ix = proto_perl->Isavestack_ix;
12691 PL_savestack_max = proto_perl->Isavestack_max;
12692 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
12693 PL_savestack = ss_dup(proto_perl, param);
12697 ENTER; /* perl_destruct() wants to LEAVE; */
12700 PL_start_env = proto_perl->Istart_env; /* XXXXXX */
12701 PL_top_env = &PL_start_env;
12703 PL_op = proto_perl->Iop;
12706 PL_Xpv = (XPV*)NULL;
12707 my_perl->Ina = proto_perl->Ina;
12709 PL_statbuf = proto_perl->Istatbuf;
12710 PL_statcache = proto_perl->Istatcache;
12711 PL_statgv = gv_dup(proto_perl->Istatgv, param);
12712 PL_statname = sv_dup_inc(proto_perl->Istatname, param);
12714 PL_timesbuf = proto_perl->Itimesbuf;
12717 PL_tainted = proto_perl->Itainted;
12718 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
12719 PL_rs = sv_dup_inc(proto_perl->Irs, param);
12720 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
12721 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
12722 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
12723 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
12724 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
12725 PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
12727 PL_restartjmpenv = proto_perl->Irestartjmpenv;
12728 PL_restartop = proto_perl->Irestartop;
12729 PL_in_eval = proto_perl->Iin_eval;
12730 PL_delaymagic = proto_perl->Idelaymagic;
12731 PL_dirty = proto_perl->Idirty;
12732 PL_localizing = proto_perl->Ilocalizing;
12734 PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
12735 PL_hv_fetch_ent_mh = NULL;
12736 PL_modcount = proto_perl->Imodcount;
12737 PL_lastgotoprobe = NULL;
12738 PL_dumpindent = proto_perl->Idumpindent;
12740 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
12741 PL_sortstash = hv_dup(proto_perl->Isortstash, param);
12742 PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
12743 PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
12744 PL_efloatbuf = NULL; /* reinits on demand */
12745 PL_efloatsize = 0; /* reinits on demand */
12749 PL_screamfirst = NULL;
12750 PL_screamnext = NULL;
12751 PL_maxscream = -1; /* reinits on demand */
12752 PL_lastscream = NULL;
12755 PL_regdummy = proto_perl->Iregdummy;
12756 PL_colorset = 0; /* reinits PL_colors[] */
12757 /*PL_colors[6] = {0,0,0,0,0,0};*/
12761 /* Pluggable optimizer */
12762 PL_peepp = proto_perl->Ipeepp;
12763 PL_rpeepp = proto_perl->Irpeepp;
12764 /* op_free() hook */
12765 PL_opfreehook = proto_perl->Iopfreehook;
12767 PL_stashcache = newHV();
12769 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
12770 proto_perl->Iwatchaddr);
12771 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
12772 if (PL_debug && PL_watchaddr) {
12773 PerlIO_printf(Perl_debug_log,
12774 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
12775 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
12776 PTR2UV(PL_watchok));
12779 PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
12780 PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param);
12782 /* Call the ->CLONE method, if it exists, for each of the stashes
12783 identified by sv_dup() above.
12785 while(av_len(param->stashes) != -1) {
12786 HV* const stash = MUTABLE_HV(av_shift(param->stashes));
12787 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12788 if (cloner && GvCV(cloner)) {
12793 mXPUSHs(newSVhek(HvNAME_HEK(stash)));
12795 call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
12801 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12802 ptr_table_free(PL_ptr_table);
12803 PL_ptr_table = NULL;
12806 if (!(flags & CLONEf_COPY_STACKS)) {
12807 unreferenced_to_tmp_stack(param->unreferenced);
12810 SvREFCNT_dec(param->stashes);
12812 /* orphaned? eg threads->new inside BEGIN or use */
12813 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12814 SvREFCNT_inc_simple_void(PL_compcv);
12815 SAVEFREESV(PL_compcv);
12822 S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
12824 PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
12826 if (AvFILLp(unreferenced) > -1) {
12827 SV **svp = AvARRAY(unreferenced);
12828 SV **const last = svp + AvFILLp(unreferenced);
12832 if (SvREFCNT(*svp) == 1)
12834 } while (++svp <= last);
12836 EXTEND_MORTAL(count);
12837 svp = AvARRAY(unreferenced);
12840 if (SvREFCNT(*svp) == 1) {
12841 /* Our reference is the only one to this SV. This means that
12842 in this thread, the scalar effectively has a 0 reference.
12843 That doesn't work (cleanup never happens), so donate our
12844 reference to it onto the save stack. */
12845 PL_tmps_stack[++PL_tmps_ix] = *svp;
12847 /* As an optimisation, because we are already walking the
12848 entire array, instead of above doing either
12849 SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
12850 release our reference to the scalar, so that at the end of
12851 the array owns zero references to the scalars it happens to
12852 point to. We are effectively converting the array from
12853 AvREAL() on to AvREAL() off. This saves the av_clear()
12854 (triggered by the SvREFCNT_dec(unreferenced) below) from
12855 walking the array a second time. */
12856 SvREFCNT_dec(*svp);
12859 } while (++svp <= last);
12860 AvREAL_off(unreferenced);
12862 SvREFCNT_dec(unreferenced);
12866 Perl_clone_params_del(CLONE_PARAMS *param)
12868 /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
12870 PerlInterpreter *const to = param->new_perl;
12872 PerlInterpreter *const was = PERL_GET_THX;
12874 PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
12880 SvREFCNT_dec(param->stashes);
12881 if (param->unreferenced)
12882 unreferenced_to_tmp_stack(param->unreferenced);
12892 Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
12895 /* Need to play this game, as newAV() can call safesysmalloc(), and that
12896 does a dTHX; to get the context from thread local storage.
12897 FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
12898 a version that passes in my_perl. */
12899 PerlInterpreter *const was = PERL_GET_THX;
12900 CLONE_PARAMS *param;
12902 PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
12908 /* Given that we've set the context, we can do this unshared. */
12909 Newx(param, 1, CLONE_PARAMS);
12912 param->proto_perl = from;
12913 param->new_perl = to;
12914 param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
12915 AvREAL_off(param->stashes);
12916 param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
12924 #endif /* USE_ITHREADS */
12927 =head1 Unicode Support
12929 =for apidoc sv_recode_to_utf8
12931 The encoding is assumed to be an Encode object, on entry the PV
12932 of the sv is assumed to be octets in that encoding, and the sv
12933 will be converted into Unicode (and UTF-8).
12935 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12936 is not a reference, nothing is done to the sv. If the encoding is not
12937 an C<Encode::XS> Encoding object, bad things will happen.
12938 (See F<lib/encoding.pm> and L<Encode>).
12940 The PV of the sv is returned.
12945 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12949 PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
12951 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12965 Passing sv_yes is wrong - it needs to be or'ed set of constants
12966 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12967 remove converted chars from source.
12969 Both will default the value - let them.
12971 XPUSHs(&PL_sv_yes);
12974 call_method("decode", G_SCALAR);
12978 s = SvPV_const(uni, len);
12979 if (s != SvPVX_const(sv)) {
12980 SvGROW(sv, len + 1);
12981 Move(s, SvPVX(sv), len + 1, char);
12982 SvCUR_set(sv, len);
12989 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12993 =for apidoc sv_cat_decode
12995 The encoding is assumed to be an Encode object, the PV of the ssv is
12996 assumed to be octets in that encoding and decoding the input starts
12997 from the position which (PV + *offset) pointed to. The dsv will be
12998 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12999 when the string tstr appears in decoding output or the input ends on
13000 the PV of the ssv. The value which the offset points will be modified
13001 to the last input position on the ssv.
13003 Returns TRUE if the terminator was found, else returns FALSE.
13008 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
13009 SV *ssv, int *offset, char *tstr, int tlen)
13014 PERL_ARGS_ASSERT_SV_CAT_DECODE;
13016 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
13027 offsv = newSViv(*offset);
13029 mXPUSHp(tstr, tlen);
13031 call_method("cat_decode", G_SCALAR);
13033 ret = SvTRUE(TOPs);
13034 *offset = SvIV(offsv);
13040 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
13045 /* ---------------------------------------------------------------------
13047 * support functions for report_uninit()
13050 /* the maxiumum size of array or hash where we will scan looking
13051 * for the undefined element that triggered the warning */
13053 #define FUV_MAX_SEARCH_SIZE 1000
13055 /* Look for an entry in the hash whose value has the same SV as val;
13056 * If so, return a mortal copy of the key. */
13059 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
13062 register HE **array;
13065 PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
13067 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
13068 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
13071 array = HvARRAY(hv);
13073 for (i=HvMAX(hv); i>0; i--) {
13074 register HE *entry;
13075 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
13076 if (HeVAL(entry) != val)
13078 if ( HeVAL(entry) == &PL_sv_undef ||
13079 HeVAL(entry) == &PL_sv_placeholder)
13083 if (HeKLEN(entry) == HEf_SVKEY)
13084 return sv_mortalcopy(HeKEY_sv(entry));
13085 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
13091 /* Look for an entry in the array whose value has the same SV as val;
13092 * If so, return the index, otherwise return -1. */
13095 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
13099 PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
13101 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
13102 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
13105 if (val != &PL_sv_undef) {
13106 SV ** const svp = AvARRAY(av);
13109 for (i=AvFILLp(av); i>=0; i--)
13116 /* S_varname(): return the name of a variable, optionally with a subscript.
13117 * If gv is non-zero, use the name of that global, along with gvtype (one
13118 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
13119 * targ. Depending on the value of the subscript_type flag, return:
13122 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
13123 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
13124 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
13125 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
13128 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
13129 const SV *const keyname, I32 aindex, int subscript_type)
13132 SV * const name = sv_newmortal();
13135 buffer[0] = gvtype;
13138 /* as gv_fullname4(), but add literal '^' for $^FOO names */
13140 gv_fullname4(name, gv, buffer, 0);
13142 if ((unsigned int)SvPVX(name)[1] <= 26) {
13144 buffer[1] = SvPVX(name)[1] + 'A' - 1;
13146 /* Swap the 1 unprintable control character for the 2 byte pretty
13147 version - ie substr($name, 1, 1) = $buffer; */
13148 sv_insert(name, 1, 1, buffer, 2);
13152 CV * const cv = find_runcv(NULL);
13156 if (!cv || !CvPADLIST(cv))
13158 av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
13159 sv = *av_fetch(av, targ, FALSE);
13160 sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
13163 if (subscript_type == FUV_SUBSCRIPT_HASH) {
13164 SV * const sv = newSV(0);
13165 *SvPVX(name) = '$';
13166 Perl_sv_catpvf(aTHX_ name, "{%s}",
13167 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
13170 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
13171 *SvPVX(name) = '$';
13172 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
13174 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
13175 /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
13176 Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
13184 =for apidoc find_uninit_var
13186 Find the name of the undefined variable (if any) that caused the operator o
13187 to issue a "Use of uninitialized value" warning.
13188 If match is true, only return a name if it's value matches uninit_sv.
13189 So roughly speaking, if a unary operator (such as OP_COS) generates a
13190 warning, then following the direct child of the op may yield an
13191 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
13192 other hand, with OP_ADD there are two branches to follow, so we only print
13193 the variable name if we get an exact match.
13195 The name is returned as a mortal SV.
13197 Assumes that PL_op is the op that originally triggered the error, and that
13198 PL_comppad/PL_curpad points to the currently executing pad.
13204 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
13210 const OP *o, *o2, *kid;
13212 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
13213 uninit_sv == &PL_sv_placeholder)))
13216 switch (obase->op_type) {
13223 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
13224 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
13227 int subscript_type = FUV_SUBSCRIPT_WITHIN;
13229 if (pad) { /* @lex, %lex */
13230 sv = PAD_SVl(obase->op_targ);
13234 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
13235 /* @global, %global */
13236 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
13239 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
13241 else /* @{expr}, %{expr} */
13242 return find_uninit_var(cUNOPx(obase)->op_first,
13246 /* attempt to find a match within the aggregate */
13248 keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13250 subscript_type = FUV_SUBSCRIPT_HASH;
13253 index = find_array_subscript((const AV *)sv, uninit_sv);
13255 subscript_type = FUV_SUBSCRIPT_ARRAY;
13258 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
13261 return varname(gv, hash ? '%' : '@', obase->op_targ,
13262 keysv, index, subscript_type);
13266 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
13268 return varname(NULL, '$', obase->op_targ,
13269 NULL, 0, FUV_SUBSCRIPT_NONE);
13272 gv = cGVOPx_gv(obase);
13273 if (!gv || (match && GvSV(gv) != uninit_sv))
13275 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
13278 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
13281 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
13282 if (!av || SvRMAGICAL(av))
13284 svp = av_fetch(av, (I32)obase->op_private, FALSE);
13285 if (!svp || *svp != uninit_sv)
13288 return varname(NULL, '$', obase->op_targ,
13289 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
13292 gv = cGVOPx_gv(obase);
13297 AV *const av = GvAV(gv);
13298 if (!av || SvRMAGICAL(av))
13300 svp = av_fetch(av, (I32)obase->op_private, FALSE);
13301 if (!svp || *svp != uninit_sv)
13304 return varname(gv, '$', 0,
13305 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
13310 o = cUNOPx(obase)->op_first;
13311 if (!o || o->op_type != OP_NULL ||
13312 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
13314 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
13318 if (PL_op == obase)
13319 /* $a[uninit_expr] or $h{uninit_expr} */
13320 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
13323 o = cBINOPx(obase)->op_first;
13324 kid = cBINOPx(obase)->op_last;
13326 /* get the av or hv, and optionally the gv */
13328 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
13329 sv = PAD_SV(o->op_targ);
13331 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
13332 && cUNOPo->op_first->op_type == OP_GV)
13334 gv = cGVOPx_gv(cUNOPo->op_first);
13338 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
13343 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
13344 /* index is constant */
13348 if (obase->op_type == OP_HELEM) {
13349 HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
13350 if (!he || HeVAL(he) != uninit_sv)
13354 SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
13355 if (!svp || *svp != uninit_sv)
13359 if (obase->op_type == OP_HELEM)
13360 return varname(gv, '%', o->op_targ,
13361 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
13363 return varname(gv, '@', o->op_targ, NULL,
13364 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
13367 /* index is an expression;
13368 * attempt to find a match within the aggregate */
13369 if (obase->op_type == OP_HELEM) {
13370 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13372 return varname(gv, '%', o->op_targ,
13373 keysv, 0, FUV_SUBSCRIPT_HASH);
13377 = find_array_subscript((const AV *)sv, uninit_sv);
13379 return varname(gv, '@', o->op_targ,
13380 NULL, index, FUV_SUBSCRIPT_ARRAY);
13385 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
13387 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
13392 /* only examine RHS */
13393 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
13396 o = cUNOPx(obase)->op_first;
13397 if (o->op_type == OP_PUSHMARK)
13400 if (!o->op_sibling) {
13401 /* one-arg version of open is highly magical */
13403 if (o->op_type == OP_GV) { /* open FOO; */
13405 if (match && GvSV(gv) != uninit_sv)
13407 return varname(gv, '$', 0,
13408 NULL, 0, FUV_SUBSCRIPT_NONE);
13410 /* other possibilities not handled are:
13411 * open $x; or open my $x; should return '${*$x}'
13412 * open expr; should return '$'.expr ideally
13418 /* ops where $_ may be an implicit arg */
13422 if ( !(obase->op_flags & OPf_STACKED)) {
13423 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
13424 ? PAD_SVl(obase->op_targ)
13427 sv = sv_newmortal();
13428 sv_setpvs(sv, "$_");
13437 match = 1; /* print etc can return undef on defined args */
13438 /* skip filehandle as it can't produce 'undef' warning */
13439 o = cUNOPx(obase)->op_first;
13440 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
13441 o = o->op_sibling->op_sibling;
13445 case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
13447 case OP_CUSTOM: /* XS or custom code could trigger random warnings */
13449 /* the following ops are capable of returning PL_sv_undef even for
13450 * defined arg(s) */
13469 case OP_GETPEERNAME:
13517 case OP_SMARTMATCH:
13526 /* XXX tmp hack: these two may call an XS sub, and currently
13527 XS subs don't have a SUB entry on the context stack, so CV and
13528 pad determination goes wrong, and BAD things happen. So, just
13529 don't try to determine the value under those circumstances.
13530 Need a better fix at dome point. DAPM 11/2007 */
13536 GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
13537 if (gv && GvSV(gv) == uninit_sv)
13538 return newSVpvs_flags("$.", SVs_TEMP);
13543 /* def-ness of rval pos() is independent of the def-ness of its arg */
13544 if ( !(obase->op_flags & OPf_MOD))
13549 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
13550 return newSVpvs_flags("${$/}", SVs_TEMP);
13555 if (!(obase->op_flags & OPf_KIDS))
13557 o = cUNOPx(obase)->op_first;
13563 /* if all except one arg are constant, or have no side-effects,
13564 * or are optimized away, then it's unambiguous */
13566 for (kid=o; kid; kid = kid->op_sibling) {
13568 const OPCODE type = kid->op_type;
13569 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
13570 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
13571 || (type == OP_PUSHMARK)
13575 if (o2) { /* more than one found */
13582 return find_uninit_var(o2, uninit_sv, match);
13584 /* scan all args */
13586 sv = find_uninit_var(o, uninit_sv, 1);
13598 =for apidoc report_uninit
13600 Print appropriate "Use of uninitialized variable" warning
13606 Perl_report_uninit(pTHX_ const SV *uninit_sv)
13610 SV* varname = NULL;
13612 varname = find_uninit_var(PL_op, uninit_sv,0);
13614 sv_insert(varname, 0, 0, " ", 1);
13616 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13617 varname ? SvPV_nolen_const(varname) : "",
13618 " in ", OP_DESC(PL_op));
13621 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13627 * c-indentation-style: bsd
13628 * c-basic-offset: 4
13629 * indent-tabs-mode: t
13632 * ex: set ts=8 sts=4 sw=4 noet: