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
36 # if __STDC_VERSION__ >= 199901L && !defined(VMS)
47 /* Missing proto on LynxOS */
48 char *gconvert(double, int, int, char *);
51 #ifdef PERL_UTF8_CACHE_ASSERT
52 /* if adding more checks watch out for the following tests:
53 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
54 * lib/utf8.t lib/Unicode/Collate/t/index.t
57 # define ASSERT_UTF8_CACHE(cache) \
58 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
59 assert((cache)[2] <= (cache)[3]); \
60 assert((cache)[3] <= (cache)[1]);} \
63 # define ASSERT_UTF8_CACHE(cache) NOOP
66 #ifdef PERL_OLD_COPY_ON_WRITE
67 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
68 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
69 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
73 /* ============================================================================
75 =head1 Allocation and deallocation of SVs.
77 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
78 sv, av, hv...) contains type and reference count information, and for
79 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
80 contains fields specific to each type. Some types store all they need
81 in the head, so don't have a body.
83 In all but the most memory-paranoid configurations (ex: PURIFY), heads
84 and bodies are allocated out of arenas, which by default are
85 approximately 4K chunks of memory parcelled up into N heads or bodies.
86 Sv-bodies are allocated by their sv-type, guaranteeing size
87 consistency needed to allocate safely from arrays.
89 For SV-heads, the first slot in each arena is reserved, and holds a
90 link to the next arena, some flags, and a note of the number of slots.
91 Snaked through each arena chain is a linked list of free items; when
92 this becomes empty, an extra arena is allocated and divided up into N
93 items which are threaded into the free list.
95 SV-bodies are similar, but they use arena-sets by default, which
96 separate the link and info from the arena itself, and reclaim the 1st
97 slot in the arena. SV-bodies are further described later.
99 The following global variables are associated with arenas:
101 PL_sv_arenaroot pointer to list of SV arenas
102 PL_sv_root pointer to list of free SV structures
104 PL_body_arenas head of linked-list of body arenas
105 PL_body_roots[] array of pointers to list of free bodies of svtype
106 arrays are indexed by the svtype needed
108 A few special SV heads are not allocated from an arena, but are
109 instead directly created in the interpreter structure, eg PL_sv_undef.
110 The size of arenas can be changed from the default by setting
111 PERL_ARENA_SIZE appropriately at compile time.
113 The SV arena serves the secondary purpose of allowing still-live SVs
114 to be located and destroyed during final cleanup.
116 At the lowest level, the macros new_SV() and del_SV() grab and free
117 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
118 to return the SV to the free list with error checking.) new_SV() calls
119 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
120 SVs in the free list have their SvTYPE field set to all ones.
122 At the time of very final cleanup, sv_free_arenas() is called from
123 perl_destruct() to physically free all the arenas allocated since the
124 start of the interpreter.
126 The function visit() scans the SV arenas list, and calls a specified
127 function for each SV it finds which is still live - ie which has an SvTYPE
128 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
129 following functions (specified as [function that calls visit()] / [function
130 called by visit() for each SV]):
132 sv_report_used() / do_report_used()
133 dump all remaining SVs (debugging aid)
135 sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
136 do_clean_named_io_objs()
137 Attempt to free all objects pointed to by RVs,
138 and try to do the same for all objects indirectly
139 referenced by typeglobs too. Called once from
140 perl_destruct(), prior to calling sv_clean_all()
143 sv_clean_all() / do_clean_all()
144 SvREFCNT_dec(sv) each remaining SV, possibly
145 triggering an sv_free(). It also sets the
146 SVf_BREAK flag on the SV to indicate that the
147 refcnt has been artificially lowered, and thus
148 stopping sv_free() from giving spurious warnings
149 about SVs which unexpectedly have a refcnt
150 of zero. called repeatedly from perl_destruct()
151 until there are no SVs left.
153 =head2 Arena allocator API Summary
155 Private API to rest of sv.c
159 new_XPVNV(), del_XPVGV(),
164 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
168 * ========================================================================= */
171 * "A time to plant, and a time to uproot what was planted..."
175 # define MEM_LOG_NEW_SV(sv, file, line, func) \
176 Perl_mem_log_new_sv(sv, file, line, func)
177 # define MEM_LOG_DEL_SV(sv, file, line, func) \
178 Perl_mem_log_del_sv(sv, file, line, func)
180 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
181 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
184 #ifdef DEBUG_LEAKING_SCALARS
185 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
186 # define DEBUG_SV_SERIAL(sv) \
187 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
188 PTR2UV(sv), (long)(sv)->sv_debug_serial))
190 # define FREE_SV_DEBUG_FILE(sv)
191 # define DEBUG_SV_SERIAL(sv) NOOP
195 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
196 # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
197 /* Whilst I'd love to do this, it seems that things like to check on
199 # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
201 # define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
202 PoisonNew(&SvREFCNT(sv), 1, U32)
204 # define SvARENA_CHAIN(sv) SvANY(sv)
205 # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
206 # define POSION_SV_HEAD(sv)
209 /* Mark an SV head as unused, and add to free list.
211 * If SVf_BREAK is set, skip adding it to the free list, as this SV had
212 * its refcount artificially decremented during global destruction, so
213 * there may be dangling pointers to it. The last thing we want in that
214 * case is for it to be reused. */
216 #define plant_SV(p) \
218 const U32 old_flags = SvFLAGS(p); \
219 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
220 DEBUG_SV_SERIAL(p); \
221 FREE_SV_DEBUG_FILE(p); \
223 SvFLAGS(p) = SVTYPEMASK; \
224 if (!(old_flags & SVf_BREAK)) { \
225 SvARENA_CHAIN_SET(p, PL_sv_root); \
231 #define uproot_SV(p) \
234 PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
239 /* make some more SVs by adding another arena */
246 char *chunk; /* must use New here to match call to */
247 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
248 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
253 /* new_SV(): return a new, empty SV head */
255 #ifdef DEBUG_LEAKING_SCALARS
256 /* provide a real function for a debugger to play with */
258 S_new_SV(pTHX_ const char *file, int line, const char *func)
265 sv = S_more_sv(aTHX);
269 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
270 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
276 sv->sv_debug_inpad = 0;
277 sv->sv_debug_parent = NULL;
278 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
280 sv->sv_debug_serial = PL_sv_serial++;
282 MEM_LOG_NEW_SV(sv, file, line, func);
283 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
284 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
288 # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
296 (p) = S_more_sv(aTHX); \
300 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
305 /* del_SV(): return an empty SV head to the free list */
318 S_del_sv(pTHX_ SV *p)
322 PERL_ARGS_ASSERT_DEL_SV;
327 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
328 const SV * const sv = sva + 1;
329 const SV * const svend = &sva[SvREFCNT(sva)];
330 if (p >= sv && p < svend) {
336 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
337 "Attempt to free non-arena SV: 0x%"UVxf
338 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
345 #else /* ! DEBUGGING */
347 #define del_SV(p) plant_SV(p)
349 #endif /* DEBUGGING */
353 =head1 SV Manipulation Functions
355 =for apidoc sv_add_arena
357 Given a chunk of memory, link it to the head of the list of arenas,
358 and split it into a list of free SVs.
364 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
367 SV *const sva = MUTABLE_SV(ptr);
371 PERL_ARGS_ASSERT_SV_ADD_ARENA;
373 /* The first SV in an arena isn't an SV. */
374 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
375 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
376 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
378 PL_sv_arenaroot = sva;
379 PL_sv_root = sva + 1;
381 svend = &sva[SvREFCNT(sva) - 1];
384 SvARENA_CHAIN_SET(sv, (sv + 1));
388 /* Must always set typemask because it's always checked in on cleanup
389 when the arenas are walked looking for objects. */
390 SvFLAGS(sv) = SVTYPEMASK;
393 SvARENA_CHAIN_SET(sv, 0);
397 SvFLAGS(sv) = SVTYPEMASK;
400 /* visit(): call the named function for each non-free SV in the arenas
401 * whose flags field matches the flags/mask args. */
404 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
410 PERL_ARGS_ASSERT_VISIT;
412 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
413 register const SV * const svend = &sva[SvREFCNT(sva)];
415 for (sv = sva + 1; sv < svend; ++sv) {
416 if (SvTYPE(sv) != SVTYPEMASK
417 && (sv->sv_flags & mask) == flags
430 /* called by sv_report_used() for each live SV */
433 do_report_used(pTHX_ SV *const sv)
435 if (SvTYPE(sv) != SVTYPEMASK) {
436 PerlIO_printf(Perl_debug_log, "****\n");
443 =for apidoc sv_report_used
445 Dump the contents of all SVs not yet freed. (Debugging aid).
451 Perl_sv_report_used(pTHX)
454 visit(do_report_used, 0, 0);
460 /* called by sv_clean_objs() for each live SV */
463 do_clean_objs(pTHX_ SV *const ref)
468 SV * const target = SvRV(ref);
469 if (SvOBJECT(target)) {
470 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
471 if (SvWEAKREF(ref)) {
472 sv_del_backref(target, ref);
478 SvREFCNT_dec(target);
483 /* XXX Might want to check arrays, etc. */
487 /* clear any slots in a GV which hold objects - except IO;
488 * called by sv_clean_objs() for each live GV */
491 do_clean_named_objs(pTHX_ SV *const sv)
495 assert(SvTYPE(sv) == SVt_PVGV);
496 assert(isGV_with_GP(sv));
500 /* freeing GP entries may indirectly free the current GV;
501 * hold onto it while we mess with the GP slots */
504 if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
505 DEBUG_D((PerlIO_printf(Perl_debug_log,
506 "Cleaning named glob SV object:\n "), sv_dump(obj)));
510 if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
511 DEBUG_D((PerlIO_printf(Perl_debug_log,
512 "Cleaning named glob AV object:\n "), sv_dump(obj)));
516 if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
517 DEBUG_D((PerlIO_printf(Perl_debug_log,
518 "Cleaning named glob HV object:\n "), sv_dump(obj)));
522 if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
523 DEBUG_D((PerlIO_printf(Perl_debug_log,
524 "Cleaning named glob CV object:\n "), sv_dump(obj)));
528 SvREFCNT_dec(sv); /* undo the inc above */
531 /* clear any IO slots in a GV which hold objects (except stderr, defout);
532 * called by sv_clean_objs() for each live GV */
535 do_clean_named_io_objs(pTHX_ SV *const sv)
539 assert(SvTYPE(sv) == SVt_PVGV);
540 assert(isGV_with_GP(sv));
541 if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
545 if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
546 DEBUG_D((PerlIO_printf(Perl_debug_log,
547 "Cleaning named glob IO object:\n "), sv_dump(obj)));
551 SvREFCNT_dec(sv); /* undo the inc above */
554 /* Void wrapper to pass to visit() */
557 do_curse(pTHX_ SV * const sv) {
558 if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
559 || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
566 =for apidoc sv_clean_objs
568 Attempt to destroy all objects not yet freed
574 Perl_sv_clean_objs(pTHX)
578 PL_in_clean_objs = TRUE;
579 visit(do_clean_objs, SVf_ROK, SVf_ROK);
580 /* Some barnacles may yet remain, clinging to typeglobs.
581 * Run the non-IO destructors first: they may want to output
582 * error messages, close files etc */
583 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
584 visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
585 /* And if there are some very tenacious barnacles clinging to arrays,
586 closures, or what have you.... */
587 /* XXX This line breaks Tk and Gtk2. See [perl #82542].
588 visit(do_curse, SVs_OBJECT, SVs_OBJECT);
590 olddef = PL_defoutgv;
591 PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
592 if (olddef && isGV_with_GP(olddef))
593 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
594 olderr = PL_stderrgv;
595 PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
596 if (olderr && isGV_with_GP(olderr))
597 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
598 SvREFCNT_dec(olddef);
599 PL_in_clean_objs = FALSE;
602 /* called by sv_clean_all() for each live SV */
605 do_clean_all(pTHX_ SV *const sv)
608 if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
609 /* don't clean pid table and strtab */
612 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
613 SvFLAGS(sv) |= SVf_BREAK;
618 =for apidoc sv_clean_all
620 Decrement the refcnt of each remaining SV, possibly triggering a
621 cleanup. This function may have to be called multiple times to free
622 SVs which are in complex self-referential hierarchies.
628 Perl_sv_clean_all(pTHX)
632 PL_in_clean_all = TRUE;
633 cleaned = visit(do_clean_all, 0,0);
638 ARENASETS: a meta-arena implementation which separates arena-info
639 into struct arena_set, which contains an array of struct
640 arena_descs, each holding info for a single arena. By separating
641 the meta-info from the arena, we recover the 1st slot, formerly
642 borrowed for list management. The arena_set is about the size of an
643 arena, avoiding the needless malloc overhead of a naive linked-list.
645 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
646 memory in the last arena-set (1/2 on average). In trade, we get
647 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
648 smaller types). The recovery of the wasted space allows use of
649 small arenas for large, rare body types, by changing array* fields
650 in body_details_by_type[] below.
653 char *arena; /* the raw storage, allocated aligned */
654 size_t size; /* its size ~4k typ */
655 svtype utype; /* bodytype stored in arena */
660 /* Get the maximum number of elements in set[] such that struct arena_set
661 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
662 therefore likely to be 1 aligned memory page. */
664 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
665 - 2 * sizeof(int)) / sizeof (struct arena_desc))
668 struct arena_set* next;
669 unsigned int set_size; /* ie ARENAS_PER_SET */
670 unsigned int curr; /* index of next available arena-desc */
671 struct arena_desc set[ARENAS_PER_SET];
675 =for apidoc sv_free_arenas
677 Deallocate the memory used by all arenas. Note that all the individual SV
678 heads and bodies within the arenas must already have been freed.
683 Perl_sv_free_arenas(pTHX)
690 /* Free arenas here, but be careful about fake ones. (We assume
691 contiguity of the fake ones with the corresponding real ones.) */
693 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
694 svanext = MUTABLE_SV(SvANY(sva));
695 while (svanext && SvFAKE(svanext))
696 svanext = MUTABLE_SV(SvANY(svanext));
703 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
706 struct arena_set *current = aroot;
709 assert(aroot->set[i].arena);
710 Safefree(aroot->set[i].arena);
718 i = PERL_ARENA_ROOTS_SIZE;
720 PL_body_roots[i] = 0;
727 Here are mid-level routines that manage the allocation of bodies out
728 of the various arenas. There are 5 kinds of arenas:
730 1. SV-head arenas, which are discussed and handled above
731 2. regular body arenas
732 3. arenas for reduced-size bodies
735 Arena types 2 & 3 are chained by body-type off an array of
736 arena-root pointers, which is indexed by svtype. Some of the
737 larger/less used body types are malloced singly, since a large
738 unused block of them is wasteful. Also, several svtypes dont have
739 bodies; the data fits into the sv-head itself. The arena-root
740 pointer thus has a few unused root-pointers (which may be hijacked
741 later for arena types 4,5)
743 3 differs from 2 as an optimization; some body types have several
744 unused fields in the front of the structure (which are kept in-place
745 for consistency). These bodies can be allocated in smaller chunks,
746 because the leading fields arent accessed. Pointers to such bodies
747 are decremented to point at the unused 'ghost' memory, knowing that
748 the pointers are used with offsets to the real memory.
751 =head1 SV-Body Allocation
753 Allocation of SV-bodies is similar to SV-heads, differing as follows;
754 the allocation mechanism is used for many body types, so is somewhat
755 more complicated, it uses arena-sets, and has no need for still-live
758 At the outermost level, (new|del)_X*V macros return bodies of the
759 appropriate type. These macros call either (new|del)_body_type or
760 (new|del)_body_allocated macro pairs, depending on specifics of the
761 type. Most body types use the former pair, the latter pair is used to
762 allocate body types with "ghost fields".
764 "ghost fields" are fields that are unused in certain types, and
765 consequently don't need to actually exist. They are declared because
766 they're part of a "base type", which allows use of functions as
767 methods. The simplest examples are AVs and HVs, 2 aggregate types
768 which don't use the fields which support SCALAR semantics.
770 For these types, the arenas are carved up into appropriately sized
771 chunks, we thus avoid wasted memory for those unaccessed members.
772 When bodies are allocated, we adjust the pointer back in memory by the
773 size of the part not allocated, so it's as if we allocated the full
774 structure. (But things will all go boom if you write to the part that
775 is "not there", because you'll be overwriting the last members of the
776 preceding structure in memory.)
778 We calculate the correction using the STRUCT_OFFSET macro on the first
779 member present. If the allocated structure is smaller (no initial NV
780 actually allocated) then the net effect is to subtract the size of the NV
781 from the pointer, to return a new pointer as if an initial NV were actually
782 allocated. (We were using structures named *_allocated for this, but
783 this turned out to be a subtle bug, because a structure without an NV
784 could have a lower alignment constraint, but the compiler is allowed to
785 optimised accesses based on the alignment constraint of the actual pointer
786 to the full structure, for example, using a single 64 bit load instruction
787 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
789 This is the same trick as was used for NV and IV bodies. Ironically it
790 doesn't need to be used for NV bodies any more, because NV is now at
791 the start of the structure. IV bodies don't need it either, because
792 they are no longer allocated.
794 In turn, the new_body_* allocators call S_new_body(), which invokes
795 new_body_inline macro, which takes a lock, and takes a body off the
796 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
797 necessary to refresh an empty list. Then the lock is released, and
798 the body is returned.
800 Perl_more_bodies allocates a new arena, and carves it up into an array of N
801 bodies, which it strings into a linked list. It looks up arena-size
802 and body-size from the body_details table described below, thus
803 supporting the multiple body-types.
805 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
806 the (new|del)_X*V macros are mapped directly to malloc/free.
808 For each sv-type, struct body_details bodies_by_type[] carries
809 parameters which control these aspects of SV handling:
811 Arena_size determines whether arenas are used for this body type, and if
812 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
813 zero, forcing individual mallocs and frees.
815 Body_size determines how big a body is, and therefore how many fit into
816 each arena. Offset carries the body-pointer adjustment needed for
817 "ghost fields", and is used in *_allocated macros.
819 But its main purpose is to parameterize info needed in
820 Perl_sv_upgrade(). The info here dramatically simplifies the function
821 vs the implementation in 5.8.8, making it table-driven. All fields
822 are used for this, except for arena_size.
824 For the sv-types that have no bodies, arenas are not used, so those
825 PL_body_roots[sv_type] are unused, and can be overloaded. In
826 something of a special case, SVt_NULL is borrowed for HE arenas;
827 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
828 bodies_by_type[SVt_NULL] slot is not used, as the table is not
833 struct body_details {
834 U8 body_size; /* Size to allocate */
835 U8 copy; /* Size of structure to copy (may be shorter) */
837 unsigned int type : 4; /* We have space for a sanity check. */
838 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
839 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
840 unsigned int arena : 1; /* Allocated from an arena */
841 size_t arena_size; /* Size of arena to allocate */
849 /* With -DPURFIY we allocate everything directly, and don't use arenas.
850 This seems a rather elegant way to simplify some of the code below. */
851 #define HASARENA FALSE
853 #define HASARENA TRUE
855 #define NOARENA FALSE
857 /* Size the arenas to exactly fit a given number of bodies. A count
858 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
859 simplifying the default. If count > 0, the arena is sized to fit
860 only that many bodies, allowing arenas to be used for large, rare
861 bodies (XPVFM, XPVIO) without undue waste. The arena size is
862 limited by PERL_ARENA_SIZE, so we can safely oversize the
865 #define FIT_ARENA0(body_size) \
866 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
867 #define FIT_ARENAn(count,body_size) \
868 ( count * body_size <= PERL_ARENA_SIZE) \
869 ? count * body_size \
870 : FIT_ARENA0 (body_size)
871 #define FIT_ARENA(count,body_size) \
873 ? FIT_ARENAn (count, body_size) \
874 : FIT_ARENA0 (body_size)
876 /* Calculate the length to copy. Specifically work out the length less any
877 final padding the compiler needed to add. See the comment in sv_upgrade
878 for why copying the padding proved to be a bug. */
880 #define copy_length(type, last_member) \
881 STRUCT_OFFSET(type, last_member) \
882 + sizeof (((type*)SvANY((const SV *)0))->last_member)
884 static const struct body_details bodies_by_type[] = {
885 /* HEs use this offset for their arena. */
886 { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
888 /* The bind placeholder pretends to be an RV for now.
889 Also it's marked as "can't upgrade" to stop anyone using it before it's
891 { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
893 /* IVs are in the head, so the allocation size is 0. */
895 sizeof(IV), /* This is used to copy out the IV body. */
896 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
897 NOARENA /* IVS don't need an arena */, 0
900 /* 8 bytes on most ILP32 with IEEE doubles */
901 { sizeof(NV), sizeof(NV),
902 STRUCT_OFFSET(XPVNV, xnv_u),
903 SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
905 /* 8 bytes on most ILP32 with IEEE doubles */
906 { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
907 copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
908 + STRUCT_OFFSET(XPV, xpv_cur),
909 SVt_PV, FALSE, NONV, HASARENA,
910 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
913 { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
914 copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
915 + STRUCT_OFFSET(XPV, xpv_cur),
916 SVt_PVIV, FALSE, NONV, HASARENA,
917 FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
920 { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
921 copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
922 + STRUCT_OFFSET(XPV, xpv_cur),
923 SVt_PVNV, FALSE, HADNV, HASARENA,
924 FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
927 { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
928 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
934 SVt_REGEXP, FALSE, NONV, HASARENA,
935 FIT_ARENA(0, sizeof(regexp))
939 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
940 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
943 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
944 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
947 copy_length(XPVAV, xav_alloc),
949 SVt_PVAV, TRUE, NONV, HASARENA,
950 FIT_ARENA(0, sizeof(XPVAV)) },
953 copy_length(XPVHV, xhv_max),
955 SVt_PVHV, TRUE, NONV, HASARENA,
956 FIT_ARENA(0, sizeof(XPVHV)) },
962 SVt_PVCV, TRUE, NONV, HASARENA,
963 FIT_ARENA(0, sizeof(XPVCV)) },
968 SVt_PVFM, TRUE, NONV, NOARENA,
969 FIT_ARENA(20, sizeof(XPVFM)) },
971 /* XPVIO is 84 bytes, fits 48x */
975 SVt_PVIO, TRUE, NONV, HASARENA,
976 FIT_ARENA(24, sizeof(XPVIO)) },
979 #define new_body_allocated(sv_type) \
980 (void *)((char *)S_new_body(aTHX_ sv_type) \
981 - bodies_by_type[sv_type].offset)
983 /* return a thing to the free list */
985 #define del_body(thing, root) \
987 void ** const thing_copy = (void **)thing; \
988 *thing_copy = *root; \
989 *root = (void*)thing_copy; \
994 #define new_XNV() safemalloc(sizeof(XPVNV))
995 #define new_XPVNV() safemalloc(sizeof(XPVNV))
996 #define new_XPVMG() safemalloc(sizeof(XPVMG))
998 #define del_XPVGV(p) safefree(p)
1002 #define new_XNV() new_body_allocated(SVt_NV)
1003 #define new_XPVNV() new_body_allocated(SVt_PVNV)
1004 #define new_XPVMG() new_body_allocated(SVt_PVMG)
1006 #define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \
1007 &PL_body_roots[SVt_PVGV])
1011 /* no arena for you! */
1013 #define new_NOARENA(details) \
1014 safemalloc((details)->body_size + (details)->offset)
1015 #define new_NOARENAZ(details) \
1016 safecalloc((details)->body_size + (details)->offset, 1)
1019 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1020 const size_t arena_size)
1023 void ** const root = &PL_body_roots[sv_type];
1024 struct arena_desc *adesc;
1025 struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1029 const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1030 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1031 static bool done_sanity_check;
1033 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1034 * variables like done_sanity_check. */
1035 if (!done_sanity_check) {
1036 unsigned int i = SVt_LAST;
1038 done_sanity_check = TRUE;
1041 assert (bodies_by_type[i].type == i);
1047 /* may need new arena-set to hold new arena */
1048 if (!aroot || aroot->curr >= aroot->set_size) {
1049 struct arena_set *newroot;
1050 Newxz(newroot, 1, struct arena_set);
1051 newroot->set_size = ARENAS_PER_SET;
1052 newroot->next = aroot;
1054 PL_body_arenas = (void *) newroot;
1055 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1058 /* ok, now have arena-set with at least 1 empty/available arena-desc */
1059 curr = aroot->curr++;
1060 adesc = &(aroot->set[curr]);
1061 assert(!adesc->arena);
1063 Newx(adesc->arena, good_arena_size, char);
1064 adesc->size = good_arena_size;
1065 adesc->utype = sv_type;
1066 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
1067 curr, (void*)adesc->arena, (UV)good_arena_size));
1069 start = (char *) adesc->arena;
1071 /* Get the address of the byte after the end of the last body we can fit.
1072 Remember, this is integer division: */
1073 end = start + good_arena_size / body_size * body_size;
1075 /* computed count doesn't reflect the 1st slot reservation */
1076 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1077 DEBUG_m(PerlIO_printf(Perl_debug_log,
1078 "arena %p end %p arena-size %d (from %d) type %d "
1080 (void*)start, (void*)end, (int)good_arena_size,
1081 (int)arena_size, sv_type, (int)body_size,
1082 (int)good_arena_size / (int)body_size));
1084 DEBUG_m(PerlIO_printf(Perl_debug_log,
1085 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1086 (void*)start, (void*)end,
1087 (int)arena_size, sv_type, (int)body_size,
1088 (int)good_arena_size / (int)body_size));
1090 *root = (void *)start;
1093 /* Where the next body would start: */
1094 char * const next = start + body_size;
1097 /* This is the last body: */
1098 assert(next == end);
1100 *(void **)start = 0;
1104 *(void**) start = (void *)next;
1109 /* grab a new thing from the free list, allocating more if necessary.
1110 The inline version is used for speed in hot routines, and the
1111 function using it serves the rest (unless PURIFY).
1113 #define new_body_inline(xpv, sv_type) \
1115 void ** const r3wt = &PL_body_roots[sv_type]; \
1116 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1117 ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1118 bodies_by_type[sv_type].body_size,\
1119 bodies_by_type[sv_type].arena_size)); \
1120 *(r3wt) = *(void**)(xpv); \
1126 S_new_body(pTHX_ const svtype sv_type)
1130 new_body_inline(xpv, sv_type);
1136 static const struct body_details fake_rv =
1137 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1140 =for apidoc sv_upgrade
1142 Upgrade an SV to a more complex form. Generally adds a new body type to the
1143 SV, then copies across as much information as possible from the old body.
1144 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1150 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1155 const svtype old_type = SvTYPE(sv);
1156 const struct body_details *new_type_details;
1157 const struct body_details *old_type_details
1158 = bodies_by_type + old_type;
1159 SV *referant = NULL;
1161 PERL_ARGS_ASSERT_SV_UPGRADE;
1163 if (old_type == new_type)
1166 /* This clause was purposefully added ahead of the early return above to
1167 the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1168 inference by Nick I-S that it would fix other troublesome cases. See
1169 changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1171 Given that shared hash key scalars are no longer PVIV, but PV, there is
1172 no longer need to unshare so as to free up the IVX slot for its proper
1173 purpose. So it's safe to move the early return earlier. */
1175 if (new_type != SVt_PV && SvIsCOW(sv)) {
1176 sv_force_normal_flags(sv, 0);
1179 old_body = SvANY(sv);
1181 /* Copying structures onto other structures that have been neatly zeroed
1182 has a subtle gotcha. Consider XPVMG
1184 +------+------+------+------+------+-------+-------+
1185 | NV | CUR | LEN | IV | MAGIC | STASH |
1186 +------+------+------+------+------+-------+-------+
1187 0 4 8 12 16 20 24 28
1189 where NVs are aligned to 8 bytes, so that sizeof that structure is
1190 actually 32 bytes long, with 4 bytes of padding at the end:
1192 +------+------+------+------+------+-------+-------+------+
1193 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1194 +------+------+------+------+------+-------+-------+------+
1195 0 4 8 12 16 20 24 28 32
1197 so what happens if you allocate memory for this structure:
1199 +------+------+------+------+------+-------+-------+------+------+...
1200 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1201 +------+------+------+------+------+-------+-------+------+------+...
1202 0 4 8 12 16 20 24 28 32 36
1204 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1205 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1206 started out as zero once, but it's quite possible that it isn't. So now,
1207 rather than a nicely zeroed GP, you have it pointing somewhere random.
1210 (In fact, GP ends up pointing at a previous GP structure, because the
1211 principle cause of the padding in XPVMG getting garbage is a copy of
1212 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1213 this happens to be moot because XPVGV has been re-ordered, with GP
1214 no longer after STASH)
1216 So we are careful and work out the size of used parts of all the
1224 referant = SvRV(sv);
1225 old_type_details = &fake_rv;
1226 if (new_type == SVt_NV)
1227 new_type = SVt_PVNV;
1229 if (new_type < SVt_PVIV) {
1230 new_type = (new_type == SVt_NV)
1231 ? SVt_PVNV : SVt_PVIV;
1236 if (new_type < SVt_PVNV) {
1237 new_type = SVt_PVNV;
1241 assert(new_type > SVt_PV);
1242 assert(SVt_IV < SVt_PV);
1243 assert(SVt_NV < SVt_PV);
1250 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1251 there's no way that it can be safely upgraded, because perl.c
1252 expects to Safefree(SvANY(PL_mess_sv)) */
1253 assert(sv != PL_mess_sv);
1254 /* This flag bit is used to mean other things in other scalar types.
1255 Given that it only has meaning inside the pad, it shouldn't be set
1256 on anything that can get upgraded. */
1257 assert(!SvPAD_TYPED(sv));
1260 if (old_type_details->cant_upgrade)
1261 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1262 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1265 if (old_type > new_type)
1266 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1267 (int)old_type, (int)new_type);
1269 new_type_details = bodies_by_type + new_type;
1271 SvFLAGS(sv) &= ~SVTYPEMASK;
1272 SvFLAGS(sv) |= new_type;
1274 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1275 the return statements above will have triggered. */
1276 assert (new_type != SVt_NULL);
1279 assert(old_type == SVt_NULL);
1280 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1284 assert(old_type == SVt_NULL);
1285 SvANY(sv) = new_XNV();
1290 assert(new_type_details->body_size);
1293 assert(new_type_details->arena);
1294 assert(new_type_details->arena_size);
1295 /* This points to the start of the allocated area. */
1296 new_body_inline(new_body, new_type);
1297 Zero(new_body, new_type_details->body_size, char);
1298 new_body = ((char *)new_body) - new_type_details->offset;
1300 /* We always allocated the full length item with PURIFY. To do this
1301 we fake things so that arena is false for all 16 types.. */
1302 new_body = new_NOARENAZ(new_type_details);
1304 SvANY(sv) = new_body;
1305 if (new_type == SVt_PVAV) {
1309 if (old_type_details->body_size) {
1312 /* It will have been zeroed when the new body was allocated.
1313 Lets not write to it, in case it confuses a write-back
1319 #ifndef NODEFAULT_SHAREKEYS
1320 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1322 HvMAX(sv) = 7; /* (start with 8 buckets) */
1325 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1326 The target created by newSVrv also is, and it can have magic.
1327 However, it never has SvPVX set.
1329 if (old_type == SVt_IV) {
1331 } else if (old_type >= SVt_PV) {
1332 assert(SvPVX_const(sv) == 0);
1335 if (old_type >= SVt_PVMG) {
1336 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1337 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1339 sv->sv_u.svu_array = NULL; /* or svu_hash */
1345 /* This ensures that SvTHINKFIRST(sv) is true, and hence that
1346 sv_force_normal_flags(sv) is called. */
1349 /* XXX Is this still needed? Was it ever needed? Surely as there is
1350 no route from NV to PVIV, NOK can never be true */
1351 assert(!SvNOKp(sv));
1362 assert(new_type_details->body_size);
1363 /* We always allocated the full length item with PURIFY. To do this
1364 we fake things so that arena is false for all 16 types.. */
1365 if(new_type_details->arena) {
1366 /* This points to the start of the allocated area. */
1367 new_body_inline(new_body, new_type);
1368 Zero(new_body, new_type_details->body_size, char);
1369 new_body = ((char *)new_body) - new_type_details->offset;
1371 new_body = new_NOARENAZ(new_type_details);
1373 SvANY(sv) = new_body;
1375 if (old_type_details->copy) {
1376 /* There is now the potential for an upgrade from something without
1377 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1378 int offset = old_type_details->offset;
1379 int length = old_type_details->copy;
1381 if (new_type_details->offset > old_type_details->offset) {
1382 const int difference
1383 = new_type_details->offset - old_type_details->offset;
1384 offset += difference;
1385 length -= difference;
1387 assert (length >= 0);
1389 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1393 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1394 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1395 * correct 0.0 for us. Otherwise, if the old body didn't have an
1396 * NV slot, but the new one does, then we need to initialise the
1397 * freshly created NV slot with whatever the correct bit pattern is
1399 if (old_type_details->zero_nv && !new_type_details->zero_nv
1400 && !isGV_with_GP(sv))
1404 if (new_type == SVt_PVIO) {
1405 IO * const io = MUTABLE_IO(sv);
1406 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1409 /* Clear the stashcache because a new IO could overrule a package
1411 hv_clear(PL_stashcache);
1413 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1414 IoPAGE_LEN(sv) = 60;
1416 if (old_type < SVt_PV) {
1417 /* referant will be NULL unless the old type was SVt_IV emulating
1419 sv->sv_u.svu_rv = referant;
1423 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1424 (unsigned long)new_type);
1427 if (old_type > SVt_IV) {
1431 /* Note that there is an assumption that all bodies of types that
1432 can be upgraded came from arenas. Only the more complex non-
1433 upgradable types are allowed to be directly malloc()ed. */
1434 assert(old_type_details->arena);
1435 del_body((void*)((char*)old_body + old_type_details->offset),
1436 &PL_body_roots[old_type]);
1442 =for apidoc sv_backoff
1444 Remove any string offset. You should normally use the C<SvOOK_off> macro
1451 Perl_sv_backoff(pTHX_ register SV *const sv)
1454 const char * const s = SvPVX_const(sv);
1456 PERL_ARGS_ASSERT_SV_BACKOFF;
1457 PERL_UNUSED_CONTEXT;
1460 assert(SvTYPE(sv) != SVt_PVHV);
1461 assert(SvTYPE(sv) != SVt_PVAV);
1463 SvOOK_offset(sv, delta);
1465 SvLEN_set(sv, SvLEN(sv) + delta);
1466 SvPV_set(sv, SvPVX(sv) - delta);
1467 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1468 SvFLAGS(sv) &= ~SVf_OOK;
1475 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1476 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1477 Use the C<SvGROW> wrapper instead.
1483 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1487 PERL_ARGS_ASSERT_SV_GROW;
1489 if (PL_madskills && newlen >= 0x100000) {
1490 PerlIO_printf(Perl_debug_log,
1491 "Allocation too large: %"UVxf"\n", (UV)newlen);
1493 #ifdef HAS_64K_LIMIT
1494 if (newlen >= 0x10000) {
1495 PerlIO_printf(Perl_debug_log,
1496 "Allocation too large: %"UVxf"\n", (UV)newlen);
1499 #endif /* HAS_64K_LIMIT */
1502 if (SvTYPE(sv) < SVt_PV) {
1503 sv_upgrade(sv, SVt_PV);
1504 s = SvPVX_mutable(sv);
1506 else if (SvOOK(sv)) { /* pv is offset? */
1508 s = SvPVX_mutable(sv);
1509 if (newlen > SvLEN(sv))
1510 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1511 #ifdef HAS_64K_LIMIT
1512 if (newlen >= 0x10000)
1517 s = SvPVX_mutable(sv);
1519 if (newlen > SvLEN(sv)) { /* need more room? */
1520 STRLEN minlen = SvCUR(sv);
1521 minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1522 if (newlen < minlen)
1524 #ifndef Perl_safesysmalloc_size
1525 newlen = PERL_STRLEN_ROUNDUP(newlen);
1527 if (SvLEN(sv) && s) {
1528 s = (char*)saferealloc(s, newlen);
1531 s = (char*)safemalloc(newlen);
1532 if (SvPVX_const(sv) && SvCUR(sv)) {
1533 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1537 #ifdef Perl_safesysmalloc_size
1538 /* Do this here, do it once, do it right, and then we will never get
1539 called back into sv_grow() unless there really is some growing
1541 SvLEN_set(sv, Perl_safesysmalloc_size(s));
1543 SvLEN_set(sv, newlen);
1550 =for apidoc sv_setiv
1552 Copies an integer into the given SV, upgrading first if necessary.
1553 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1559 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1563 PERL_ARGS_ASSERT_SV_SETIV;
1565 SV_CHECK_THINKFIRST_COW_DROP(sv);
1566 switch (SvTYPE(sv)) {
1569 sv_upgrade(sv, SVt_IV);
1572 sv_upgrade(sv, SVt_PVIV);
1576 if (!isGV_with_GP(sv))
1583 /* diag_listed_as: Can't coerce %s to %s in %s */
1584 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1588 (void)SvIOK_only(sv); /* validate number */
1594 =for apidoc sv_setiv_mg
1596 Like C<sv_setiv>, but also handles 'set' magic.
1602 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1604 PERL_ARGS_ASSERT_SV_SETIV_MG;
1611 =for apidoc sv_setuv
1613 Copies an unsigned integer into the given SV, upgrading first if necessary.
1614 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1620 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1622 PERL_ARGS_ASSERT_SV_SETUV;
1624 /* With these two if statements:
1625 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1628 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1630 If you wish to remove them, please benchmark to see what the effect is
1632 if (u <= (UV)IV_MAX) {
1633 sv_setiv(sv, (IV)u);
1642 =for apidoc sv_setuv_mg
1644 Like C<sv_setuv>, but also handles 'set' magic.
1650 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1652 PERL_ARGS_ASSERT_SV_SETUV_MG;
1659 =for apidoc sv_setnv
1661 Copies a double into the given SV, upgrading first if necessary.
1662 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1668 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1672 PERL_ARGS_ASSERT_SV_SETNV;
1674 SV_CHECK_THINKFIRST_COW_DROP(sv);
1675 switch (SvTYPE(sv)) {
1678 sv_upgrade(sv, SVt_NV);
1682 sv_upgrade(sv, SVt_PVNV);
1686 if (!isGV_with_GP(sv))
1693 /* diag_listed_as: Can't coerce %s to %s in %s */
1694 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1699 (void)SvNOK_only(sv); /* validate number */
1704 =for apidoc sv_setnv_mg
1706 Like C<sv_setnv>, but also handles 'set' magic.
1712 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1714 PERL_ARGS_ASSERT_SV_SETNV_MG;
1720 /* Print an "isn't numeric" warning, using a cleaned-up,
1721 * printable version of the offending string
1725 S_not_a_number(pTHX_ SV *const sv)
1732 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1735 dsv = newSVpvs_flags("", SVs_TEMP);
1736 pv = sv_uni_display(dsv, sv, 10, 0);
1739 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1740 /* each *s can expand to 4 chars + "...\0",
1741 i.e. need room for 8 chars */
1743 const char *s = SvPVX_const(sv);
1744 const char * const end = s + SvCUR(sv);
1745 for ( ; s < end && d < limit; s++ ) {
1747 if (ch & 128 && !isPRINT_LC(ch)) {
1756 else if (ch == '\r') {
1760 else if (ch == '\f') {
1764 else if (ch == '\\') {
1768 else if (ch == '\0') {
1772 else if (isPRINT_LC(ch))
1789 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1790 "Argument \"%s\" isn't numeric in %s", pv,
1793 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1794 "Argument \"%s\" isn't numeric", pv);
1798 =for apidoc looks_like_number
1800 Test if the content of an SV looks like a number (or is a number).
1801 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1802 non-numeric warning), even if your atof() doesn't grok them.
1808 Perl_looks_like_number(pTHX_ SV *const sv)
1810 register const char *sbegin;
1813 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1816 sbegin = SvPVX_const(sv);
1819 else if (SvPOKp(sv))
1820 sbegin = SvPV_const(sv, len);
1822 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1823 return grok_number(sbegin, len, NULL);
1827 S_glob_2number(pTHX_ GV * const gv)
1829 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1830 SV *const buffer = sv_newmortal();
1832 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1834 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1837 gv_efullname3(buffer, gv, "*");
1838 SvFLAGS(gv) |= wasfake;
1840 /* We know that all GVs stringify to something that is not-a-number,
1841 so no need to test that. */
1842 if (ckWARN(WARN_NUMERIC))
1843 not_a_number(buffer);
1844 /* We just want something true to return, so that S_sv_2iuv_common
1845 can tail call us and return true. */
1849 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1850 until proven guilty, assume that things are not that bad... */
1855 As 64 bit platforms often have an NV that doesn't preserve all bits of
1856 an IV (an assumption perl has been based on to date) it becomes necessary
1857 to remove the assumption that the NV always carries enough precision to
1858 recreate the IV whenever needed, and that the NV is the canonical form.
1859 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1860 precision as a side effect of conversion (which would lead to insanity
1861 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1862 1) to distinguish between IV/UV/NV slots that have cached a valid
1863 conversion where precision was lost and IV/UV/NV slots that have a
1864 valid conversion which has lost no precision
1865 2) to ensure that if a numeric conversion to one form is requested that
1866 would lose precision, the precise conversion (or differently
1867 imprecise conversion) is also performed and cached, to prevent
1868 requests for different numeric formats on the same SV causing
1869 lossy conversion chains. (lossless conversion chains are perfectly
1874 SvIOKp is true if the IV slot contains a valid value
1875 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1876 SvNOKp is true if the NV slot contains a valid value
1877 SvNOK is true only if the NV value is accurate
1880 while converting from PV to NV, check to see if converting that NV to an
1881 IV(or UV) would lose accuracy over a direct conversion from PV to
1882 IV(or UV). If it would, cache both conversions, return NV, but mark
1883 SV as IOK NOKp (ie not NOK).
1885 While converting from PV to IV, check to see if converting that IV to an
1886 NV would lose accuracy over a direct conversion from PV to NV. If it
1887 would, cache both conversions, flag similarly.
1889 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1890 correctly because if IV & NV were set NV *always* overruled.
1891 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1892 changes - now IV and NV together means that the two are interchangeable:
1893 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1895 The benefit of this is that operations such as pp_add know that if
1896 SvIOK is true for both left and right operands, then integer addition
1897 can be used instead of floating point (for cases where the result won't
1898 overflow). Before, floating point was always used, which could lead to
1899 loss of precision compared with integer addition.
1901 * making IV and NV equal status should make maths accurate on 64 bit
1903 * may speed up maths somewhat if pp_add and friends start to use
1904 integers when possible instead of fp. (Hopefully the overhead in
1905 looking for SvIOK and checking for overflow will not outweigh the
1906 fp to integer speedup)
1907 * will slow down integer operations (callers of SvIV) on "inaccurate"
1908 values, as the change from SvIOK to SvIOKp will cause a call into
1909 sv_2iv each time rather than a macro access direct to the IV slot
1910 * should speed up number->string conversion on integers as IV is
1911 favoured when IV and NV are equally accurate
1913 ####################################################################
1914 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1915 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1916 On the other hand, SvUOK is true iff UV.
1917 ####################################################################
1919 Your mileage will vary depending your CPU's relative fp to integer
1923 #ifndef NV_PRESERVES_UV
1924 # define IS_NUMBER_UNDERFLOW_IV 1
1925 # define IS_NUMBER_UNDERFLOW_UV 2
1926 # define IS_NUMBER_IV_AND_UV 2
1927 # define IS_NUMBER_OVERFLOW_IV 4
1928 # define IS_NUMBER_OVERFLOW_UV 5
1930 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1932 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1934 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1942 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1944 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));
1945 if (SvNVX(sv) < (NV)IV_MIN) {
1946 (void)SvIOKp_on(sv);
1948 SvIV_set(sv, IV_MIN);
1949 return IS_NUMBER_UNDERFLOW_IV;
1951 if (SvNVX(sv) > (NV)UV_MAX) {
1952 (void)SvIOKp_on(sv);
1955 SvUV_set(sv, UV_MAX);
1956 return IS_NUMBER_OVERFLOW_UV;
1958 (void)SvIOKp_on(sv);
1960 /* Can't use strtol etc to convert this string. (See truth table in
1962 if (SvNVX(sv) <= (UV)IV_MAX) {
1963 SvIV_set(sv, I_V(SvNVX(sv)));
1964 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1965 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1967 /* Integer is imprecise. NOK, IOKp */
1969 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1972 SvUV_set(sv, U_V(SvNVX(sv)));
1973 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1974 if (SvUVX(sv) == UV_MAX) {
1975 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1976 possibly be preserved by NV. Hence, it must be overflow.
1978 return IS_NUMBER_OVERFLOW_UV;
1980 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1982 /* Integer is imprecise. NOK, IOKp */
1984 return IS_NUMBER_OVERFLOW_IV;
1986 #endif /* !NV_PRESERVES_UV*/
1989 S_sv_2iuv_common(pTHX_ SV *const sv)
1993 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
1996 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1997 * without also getting a cached IV/UV from it at the same time
1998 * (ie PV->NV conversion should detect loss of accuracy and cache
1999 * IV or UV at same time to avoid this. */
2000 /* IV-over-UV optimisation - choose to cache IV if possible */
2002 if (SvTYPE(sv) == SVt_NV)
2003 sv_upgrade(sv, SVt_PVNV);
2005 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2006 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2007 certainly cast into the IV range at IV_MAX, whereas the correct
2008 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2010 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2011 if (Perl_isnan(SvNVX(sv))) {
2017 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2018 SvIV_set(sv, I_V(SvNVX(sv)));
2019 if (SvNVX(sv) == (NV) SvIVX(sv)
2020 #ifndef NV_PRESERVES_UV
2021 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2022 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2023 /* Don't flag it as "accurately an integer" if the number
2024 came from a (by definition imprecise) NV operation, and
2025 we're outside the range of NV integer precision */
2029 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2031 /* scalar has trailing garbage, eg "42a" */
2033 DEBUG_c(PerlIO_printf(Perl_debug_log,
2034 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2040 /* IV not precise. No need to convert from PV, as NV
2041 conversion would already have cached IV if it detected
2042 that PV->IV would be better than PV->NV->IV
2043 flags already correct - don't set public IOK. */
2044 DEBUG_c(PerlIO_printf(Perl_debug_log,
2045 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2050 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2051 but the cast (NV)IV_MIN rounds to a the value less (more
2052 negative) than IV_MIN which happens to be equal to SvNVX ??
2053 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2054 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2055 (NV)UVX == NVX are both true, but the values differ. :-(
2056 Hopefully for 2s complement IV_MIN is something like
2057 0x8000000000000000 which will be exact. NWC */
2060 SvUV_set(sv, U_V(SvNVX(sv)));
2062 (SvNVX(sv) == (NV) SvUVX(sv))
2063 #ifndef NV_PRESERVES_UV
2064 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2065 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2066 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2067 /* Don't flag it as "accurately an integer" if the number
2068 came from a (by definition imprecise) NV operation, and
2069 we're outside the range of NV integer precision */
2075 DEBUG_c(PerlIO_printf(Perl_debug_log,
2076 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2082 else if (SvPOKp(sv) && SvLEN(sv)) {
2084 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2085 /* We want to avoid a possible problem when we cache an IV/ a UV which
2086 may be later translated to an NV, and the resulting NV is not
2087 the same as the direct translation of the initial string
2088 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2089 be careful to ensure that the value with the .456 is around if the
2090 NV value is requested in the future).
2092 This means that if we cache such an IV/a UV, we need to cache the
2093 NV as well. Moreover, we trade speed for space, and do not
2094 cache the NV if we are sure it's not needed.
2097 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2098 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2099 == IS_NUMBER_IN_UV) {
2100 /* It's definitely an integer, only upgrade to PVIV */
2101 if (SvTYPE(sv) < SVt_PVIV)
2102 sv_upgrade(sv, SVt_PVIV);
2104 } else if (SvTYPE(sv) < SVt_PVNV)
2105 sv_upgrade(sv, SVt_PVNV);
2107 /* If NVs preserve UVs then we only use the UV value if we know that
2108 we aren't going to call atof() below. If NVs don't preserve UVs
2109 then the value returned may have more precision than atof() will
2110 return, even though value isn't perfectly accurate. */
2111 if ((numtype & (IS_NUMBER_IN_UV
2112 #ifdef NV_PRESERVES_UV
2115 )) == IS_NUMBER_IN_UV) {
2116 /* This won't turn off the public IOK flag if it was set above */
2117 (void)SvIOKp_on(sv);
2119 if (!(numtype & IS_NUMBER_NEG)) {
2121 if (value <= (UV)IV_MAX) {
2122 SvIV_set(sv, (IV)value);
2124 /* it didn't overflow, and it was positive. */
2125 SvUV_set(sv, value);
2129 /* 2s complement assumption */
2130 if (value <= (UV)IV_MIN) {
2131 SvIV_set(sv, -(IV)value);
2133 /* Too negative for an IV. This is a double upgrade, but
2134 I'm assuming it will be rare. */
2135 if (SvTYPE(sv) < SVt_PVNV)
2136 sv_upgrade(sv, SVt_PVNV);
2140 SvNV_set(sv, -(NV)value);
2141 SvIV_set(sv, IV_MIN);
2145 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2146 will be in the previous block to set the IV slot, and the next
2147 block to set the NV slot. So no else here. */
2149 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2150 != IS_NUMBER_IN_UV) {
2151 /* It wasn't an (integer that doesn't overflow the UV). */
2152 SvNV_set(sv, Atof(SvPVX_const(sv)));
2154 if (! numtype && ckWARN(WARN_NUMERIC))
2157 #if defined(USE_LONG_DOUBLE)
2158 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2159 PTR2UV(sv), SvNVX(sv)));
2161 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2162 PTR2UV(sv), SvNVX(sv)));
2165 #ifdef NV_PRESERVES_UV
2166 (void)SvIOKp_on(sv);
2168 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2169 SvIV_set(sv, I_V(SvNVX(sv)));
2170 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2173 NOOP; /* Integer is imprecise. NOK, IOKp */
2175 /* UV will not work better than IV */
2177 if (SvNVX(sv) > (NV)UV_MAX) {
2179 /* Integer is inaccurate. NOK, IOKp, is UV */
2180 SvUV_set(sv, UV_MAX);
2182 SvUV_set(sv, U_V(SvNVX(sv)));
2183 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2184 NV preservse UV so can do correct comparison. */
2185 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2188 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
2193 #else /* NV_PRESERVES_UV */
2194 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2195 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2196 /* The IV/UV slot will have been set from value returned by
2197 grok_number above. The NV slot has just been set using
2200 assert (SvIOKp(sv));
2202 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2203 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2204 /* Small enough to preserve all bits. */
2205 (void)SvIOKp_on(sv);
2207 SvIV_set(sv, I_V(SvNVX(sv)));
2208 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2210 /* Assumption: first non-preserved integer is < IV_MAX,
2211 this NV is in the preserved range, therefore: */
2212 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2214 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);
2218 0 0 already failed to read UV.
2219 0 1 already failed to read UV.
2220 1 0 you won't get here in this case. IV/UV
2221 slot set, public IOK, Atof() unneeded.
2222 1 1 already read UV.
2223 so there's no point in sv_2iuv_non_preserve() attempting
2224 to use atol, strtol, strtoul etc. */
2226 sv_2iuv_non_preserve (sv, numtype);
2228 sv_2iuv_non_preserve (sv);
2232 #endif /* NV_PRESERVES_UV */
2233 /* It might be more code efficient to go through the entire logic above
2234 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2235 gets complex and potentially buggy, so more programmer efficient
2236 to do it this way, by turning off the public flags: */
2238 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2242 if (isGV_with_GP(sv))
2243 return glob_2number(MUTABLE_GV(sv));
2245 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2246 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2249 if (SvTYPE(sv) < SVt_IV)
2250 /* Typically the caller expects that sv_any is not NULL now. */
2251 sv_upgrade(sv, SVt_IV);
2252 /* Return 0 from the caller. */
2259 =for apidoc sv_2iv_flags
2261 Return the integer value of an SV, doing any necessary string
2262 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2263 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2269 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2274 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2275 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2276 cache IVs just in case. In practice it seems that they never
2277 actually anywhere accessible by user Perl code, let alone get used
2278 in anything other than a string context. */
2279 if (flags & SV_GMAGIC)
2284 return I_V(SvNVX(sv));
2286 if (SvPOKp(sv) && SvLEN(sv)) {
2289 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2291 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2292 == IS_NUMBER_IN_UV) {
2293 /* It's definitely an integer */
2294 if (numtype & IS_NUMBER_NEG) {
2295 if (value < (UV)IV_MIN)
2298 if (value < (UV)IV_MAX)
2303 if (ckWARN(WARN_NUMERIC))
2306 return I_V(Atof(SvPVX_const(sv)));
2311 assert(SvTYPE(sv) >= SVt_PVMG);
2312 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2313 } else if (SvTHINKFIRST(sv)) {
2318 if (flags & SV_SKIP_OVERLOAD)
2320 tmpstr = AMG_CALLunary(sv, numer_amg);
2321 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2322 return SvIV(tmpstr);
2325 return PTR2IV(SvRV(sv));
2328 sv_force_normal_flags(sv, 0);
2330 if (SvREADONLY(sv) && !SvOK(sv)) {
2331 if (ckWARN(WARN_UNINITIALIZED))
2337 if (S_sv_2iuv_common(aTHX_ sv))
2340 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2341 PTR2UV(sv),SvIVX(sv)));
2342 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2346 =for apidoc sv_2uv_flags
2348 Return the unsigned integer value of an SV, doing any necessary string
2349 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2350 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2356 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2361 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2362 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2363 cache IVs just in case. */
2364 if (flags & SV_GMAGIC)
2369 return U_V(SvNVX(sv));
2370 if (SvPOKp(sv) && SvLEN(sv)) {
2373 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2375 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2376 == IS_NUMBER_IN_UV) {
2377 /* It's definitely an integer */
2378 if (!(numtype & IS_NUMBER_NEG))
2382 if (ckWARN(WARN_NUMERIC))
2385 return U_V(Atof(SvPVX_const(sv)));
2390 assert(SvTYPE(sv) >= SVt_PVMG);
2391 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2392 } else if (SvTHINKFIRST(sv)) {
2397 if (flags & SV_SKIP_OVERLOAD)
2399 tmpstr = AMG_CALLunary(sv, numer_amg);
2400 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2401 return SvUV(tmpstr);
2404 return PTR2UV(SvRV(sv));
2407 sv_force_normal_flags(sv, 0);
2409 if (SvREADONLY(sv) && !SvOK(sv)) {
2410 if (ckWARN(WARN_UNINITIALIZED))
2416 if (S_sv_2iuv_common(aTHX_ sv))
2420 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2421 PTR2UV(sv),SvUVX(sv)));
2422 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2426 =for apidoc sv_2nv_flags
2428 Return the num value of an SV, doing any necessary string or integer
2429 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2430 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2436 Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
2441 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2442 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2443 cache IVs just in case. */
2444 if (flags & SV_GMAGIC)
2448 if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2449 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2450 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2452 return Atof(SvPVX_const(sv));
2456 return (NV)SvUVX(sv);
2458 return (NV)SvIVX(sv);
2463 assert(SvTYPE(sv) >= SVt_PVMG);
2464 /* This falls through to the report_uninit near the end of the
2466 } else if (SvTHINKFIRST(sv)) {
2471 if (flags & SV_SKIP_OVERLOAD)
2473 tmpstr = AMG_CALLunary(sv, numer_amg);
2474 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2475 return SvNV(tmpstr);
2478 return PTR2NV(SvRV(sv));
2481 sv_force_normal_flags(sv, 0);
2483 if (SvREADONLY(sv) && !SvOK(sv)) {
2484 if (ckWARN(WARN_UNINITIALIZED))
2489 if (SvTYPE(sv) < SVt_NV) {
2490 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2491 sv_upgrade(sv, SVt_NV);
2492 #ifdef USE_LONG_DOUBLE
2494 STORE_NUMERIC_LOCAL_SET_STANDARD();
2495 PerlIO_printf(Perl_debug_log,
2496 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2497 PTR2UV(sv), SvNVX(sv));
2498 RESTORE_NUMERIC_LOCAL();
2502 STORE_NUMERIC_LOCAL_SET_STANDARD();
2503 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2504 PTR2UV(sv), SvNVX(sv));
2505 RESTORE_NUMERIC_LOCAL();
2509 else if (SvTYPE(sv) < SVt_PVNV)
2510 sv_upgrade(sv, SVt_PVNV);
2515 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2516 #ifdef NV_PRESERVES_UV
2522 /* Only set the public NV OK flag if this NV preserves the IV */
2523 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2525 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2526 : (SvIVX(sv) == I_V(SvNVX(sv))))
2532 else if (SvPOKp(sv) && SvLEN(sv)) {
2534 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2535 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2537 #ifdef NV_PRESERVES_UV
2538 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2539 == IS_NUMBER_IN_UV) {
2540 /* It's definitely an integer */
2541 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2543 SvNV_set(sv, Atof(SvPVX_const(sv)));
2549 SvNV_set(sv, Atof(SvPVX_const(sv)));
2550 /* Only set the public NV OK flag if this NV preserves the value in
2551 the PV at least as well as an IV/UV would.
2552 Not sure how to do this 100% reliably. */
2553 /* if that shift count is out of range then Configure's test is
2554 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2556 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2557 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2558 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2559 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2560 /* Can't use strtol etc to convert this string, so don't try.
2561 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2564 /* value has been set. It may not be precise. */
2565 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2566 /* 2s complement assumption for (UV)IV_MIN */
2567 SvNOK_on(sv); /* Integer is too negative. */
2572 if (numtype & IS_NUMBER_NEG) {
2573 SvIV_set(sv, -(IV)value);
2574 } else if (value <= (UV)IV_MAX) {
2575 SvIV_set(sv, (IV)value);
2577 SvUV_set(sv, value);
2581 if (numtype & IS_NUMBER_NOT_INT) {
2582 /* I believe that even if the original PV had decimals,
2583 they are lost beyond the limit of the FP precision.
2584 However, neither is canonical, so both only get p
2585 flags. NWC, 2000/11/25 */
2586 /* Both already have p flags, so do nothing */
2588 const NV nv = SvNVX(sv);
2589 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2590 if (SvIVX(sv) == I_V(nv)) {
2593 /* It had no "." so it must be integer. */
2597 /* between IV_MAX and NV(UV_MAX).
2598 Could be slightly > UV_MAX */
2600 if (numtype & IS_NUMBER_NOT_INT) {
2601 /* UV and NV both imprecise. */
2603 const UV nv_as_uv = U_V(nv);
2605 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2614 /* It might be more code efficient to go through the entire logic above
2615 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2616 gets complex and potentially buggy, so more programmer efficient
2617 to do it this way, by turning off the public flags: */
2619 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2620 #endif /* NV_PRESERVES_UV */
2623 if (isGV_with_GP(sv)) {
2624 glob_2number(MUTABLE_GV(sv));
2628 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2630 assert (SvTYPE(sv) >= SVt_NV);
2631 /* Typically the caller expects that sv_any is not NULL now. */
2632 /* XXX Ilya implies that this is a bug in callers that assume this
2633 and ideally should be fixed. */
2636 #if defined(USE_LONG_DOUBLE)
2638 STORE_NUMERIC_LOCAL_SET_STANDARD();
2639 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2640 PTR2UV(sv), SvNVX(sv));
2641 RESTORE_NUMERIC_LOCAL();
2645 STORE_NUMERIC_LOCAL_SET_STANDARD();
2646 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2647 PTR2UV(sv), SvNVX(sv));
2648 RESTORE_NUMERIC_LOCAL();
2657 Return an SV with the numeric value of the source SV, doing any necessary
2658 reference or overload conversion. You must use the C<SvNUM(sv)> macro to
2659 access this function.
2665 Perl_sv_2num(pTHX_ register SV *const sv)
2667 PERL_ARGS_ASSERT_SV_2NUM;
2672 SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2673 TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2674 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2675 return sv_2num(tmpsv);
2677 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2680 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2681 * UV as a string towards the end of buf, and return pointers to start and
2684 * We assume that buf is at least TYPE_CHARS(UV) long.
2688 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2690 char *ptr = buf + TYPE_CHARS(UV);
2691 char * const ebuf = ptr;
2694 PERL_ARGS_ASSERT_UIV_2BUF;
2706 *--ptr = '0' + (char)(uv % 10);
2715 =for apidoc sv_2pv_flags
2717 Returns a pointer to the string value of an SV, and sets *lp to its length.
2718 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2720 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2721 usually end up here too.
2727 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2737 if (SvGMAGICAL(sv)) {
2738 if (flags & SV_GMAGIC)
2743 if (flags & SV_MUTABLE_RETURN)
2744 return SvPVX_mutable(sv);
2745 if (flags & SV_CONST_RETURN)
2746 return (char *)SvPVX_const(sv);
2749 if (SvIOKp(sv) || SvNOKp(sv)) {
2750 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2755 ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2756 : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2757 } else if(SvNVX(sv) == 0.0) {
2762 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2769 SvUPGRADE(sv, SVt_PV);
2772 s = SvGROW_mutable(sv, len + 1);
2775 return (char*)memcpy(s, tbuf, len + 1);
2781 assert(SvTYPE(sv) >= SVt_PVMG);
2782 /* This falls through to the report_uninit near the end of the
2784 } else if (SvTHINKFIRST(sv)) {
2789 if (flags & SV_SKIP_OVERLOAD)
2791 tmpstr = AMG_CALLunary(sv, string_amg);
2792 TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2793 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2795 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2799 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2800 if (flags & SV_CONST_RETURN) {
2801 pv = (char *) SvPVX_const(tmpstr);
2803 pv = (flags & SV_MUTABLE_RETURN)
2804 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2807 *lp = SvCUR(tmpstr);
2809 pv = sv_2pv_flags(tmpstr, lp, flags);
2822 SV *const referent = SvRV(sv);
2826 retval = buffer = savepvn("NULLREF", len);
2827 } else if (SvTYPE(referent) == SVt_REGEXP) {
2828 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2833 /* If the regex is UTF-8 we want the containing scalar to
2834 have an UTF-8 flag too */
2840 if ((seen_evals = RX_SEEN_EVALS(re)))
2841 PL_reginterp_cnt += seen_evals;
2844 *lp = RX_WRAPLEN(re);
2846 return RX_WRAPPED(re);
2848 const char *const typestr = sv_reftype(referent, 0);
2849 const STRLEN typelen = strlen(typestr);
2850 UV addr = PTR2UV(referent);
2851 const char *stashname = NULL;
2852 STRLEN stashnamelen = 0; /* hush, gcc */
2853 const char *buffer_end;
2855 if (SvOBJECT(referent)) {
2856 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2859 stashname = HEK_KEY(name);
2860 stashnamelen = HEK_LEN(name);
2862 if (HEK_UTF8(name)) {
2868 stashname = "__ANON__";
2871 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2872 + 2 * sizeof(UV) + 2 /* )\0 */;
2874 len = typelen + 3 /* (0x */
2875 + 2 * sizeof(UV) + 2 /* )\0 */;
2878 Newx(buffer, len, char);
2879 buffer_end = retval = buffer + len;
2881 /* Working backwards */
2885 *--retval = PL_hexdigit[addr & 15];
2886 } while (addr >>= 4);
2892 memcpy(retval, typestr, typelen);
2896 retval -= stashnamelen;
2897 memcpy(retval, stashname, stashnamelen);
2899 /* retval may not necessarily have reached the start of the
2901 assert (retval >= buffer);
2903 len = buffer_end - retval - 1; /* -1 for that \0 */
2911 if (SvREADONLY(sv) && !SvOK(sv)) {
2914 if (flags & SV_UNDEF_RETURNS_NULL)
2916 if (ckWARN(WARN_UNINITIALIZED))
2921 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2922 /* I'm assuming that if both IV and NV are equally valid then
2923 converting the IV is going to be more efficient */
2924 const U32 isUIOK = SvIsUV(sv);
2925 char buf[TYPE_CHARS(UV)];
2929 if (SvTYPE(sv) < SVt_PVIV)
2930 sv_upgrade(sv, SVt_PVIV);
2931 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2933 /* inlined from sv_setpvn */
2934 s = SvGROW_mutable(sv, len + 1);
2935 Move(ptr, s, len, char);
2939 else if (SvNOKp(sv)) {
2940 if (SvTYPE(sv) < SVt_PVNV)
2941 sv_upgrade(sv, SVt_PVNV);
2942 if (SvNVX(sv) == 0.0) {
2943 s = SvGROW_mutable(sv, 2);
2948 /* The +20 is pure guesswork. Configure test needed. --jhi */
2949 s = SvGROW_mutable(sv, NV_DIG + 20);
2950 /* some Xenix systems wipe out errno here */
2951 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2961 if (isGV_with_GP(sv)) {
2962 GV *const gv = MUTABLE_GV(sv);
2963 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
2964 SV *const buffer = sv_newmortal();
2966 /* FAKE globs can get coerced, so need to turn this off temporarily
2969 gv_efullname3(buffer, gv, "*");
2970 SvFLAGS(gv) |= wasfake;
2972 if (SvPOK(buffer)) {
2974 *lp = SvCUR(buffer);
2976 return SvPVX(buffer);
2987 if (flags & SV_UNDEF_RETURNS_NULL)
2989 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2991 if (SvTYPE(sv) < SVt_PV)
2992 /* Typically the caller expects that sv_any is not NULL now. */
2993 sv_upgrade(sv, SVt_PV);
2997 const STRLEN len = s - SvPVX_const(sv);
3003 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3004 PTR2UV(sv),SvPVX_const(sv)));
3005 if (flags & SV_CONST_RETURN)
3006 return (char *)SvPVX_const(sv);
3007 if (flags & SV_MUTABLE_RETURN)
3008 return SvPVX_mutable(sv);
3013 =for apidoc sv_copypv
3015 Copies a stringified representation of the source SV into the
3016 destination SV. Automatically performs any necessary mg_get and
3017 coercion of numeric values into strings. Guaranteed to preserve
3018 UTF8 flag even from overloaded objects. Similar in nature to
3019 sv_2pv[_flags] but operates directly on an SV instead of just the
3020 string. Mostly uses sv_2pv_flags to do its work, except when that
3021 would lose the UTF-8'ness of the PV.
3027 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3030 const char * const s = SvPV_const(ssv,len);
3032 PERL_ARGS_ASSERT_SV_COPYPV;
3034 sv_setpvn(dsv,s,len);
3042 =for apidoc sv_2pvbyte
3044 Return a pointer to the byte-encoded representation of the SV, and set *lp
3045 to its length. May cause the SV to be downgraded from UTF-8 as a
3048 Usually accessed via the C<SvPVbyte> macro.
3054 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3056 PERL_ARGS_ASSERT_SV_2PVBYTE;
3059 sv_utf8_downgrade(sv,0);
3060 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3064 =for apidoc sv_2pvutf8
3066 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3067 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3069 Usually accessed via the C<SvPVutf8> macro.
3075 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3077 PERL_ARGS_ASSERT_SV_2PVUTF8;
3079 sv_utf8_upgrade(sv);
3080 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3085 =for apidoc sv_2bool
3087 This macro is only used by sv_true() or its macro equivalent, and only if
3088 the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3089 It calls sv_2bool_flags with the SV_GMAGIC flag.
3091 =for apidoc sv_2bool_flags
3093 This function is only used by sv_true() and friends, and only if
3094 the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
3095 contain SV_GMAGIC, then it does an mg_get() first.
3102 Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags)
3106 PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3108 if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3114 SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3115 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3116 return cBOOL(SvTRUE(tmpsv));
3118 return SvRV(sv) != 0;
3121 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3123 (*sv->sv_u.svu_pv > '0' ||
3124 Xpvtmp->xpv_cur > 1 ||
3125 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3132 return SvIVX(sv) != 0;
3135 return SvNVX(sv) != 0.0;
3137 if (isGV_with_GP(sv))
3147 =for apidoc sv_utf8_upgrade
3149 Converts the PV of an SV to its UTF-8-encoded form.
3150 Forces the SV to string form if it is not already.
3151 Will C<mg_get> on C<sv> if appropriate.
3152 Always sets the SvUTF8 flag to avoid future validity checks even
3153 if the whole string is the same in UTF-8 as not.
3154 Returns the number of bytes in the converted string
3156 This is not as a general purpose byte encoding to Unicode interface:
3157 use the Encode extension for that.
3159 =for apidoc sv_utf8_upgrade_nomg
3161 Like sv_utf8_upgrade, but doesn't do magic on C<sv>
3163 =for apidoc sv_utf8_upgrade_flags
3165 Converts the PV of an SV to its UTF-8-encoded form.
3166 Forces the SV to string form if it is not already.
3167 Always sets the SvUTF8 flag to avoid future validity checks even
3168 if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
3169 will C<mg_get> on C<sv> if appropriate, else not.
3170 Returns the number of bytes in the converted string
3171 C<sv_utf8_upgrade> and
3172 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3174 This is not as a general purpose byte encoding to Unicode interface:
3175 use the Encode extension for that.
3179 The grow version is currently not externally documented. It adds a parameter,
3180 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3181 have free after it upon return. This allows the caller to reserve extra space
3182 that it intends to fill, to avoid extra grows.
3184 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3185 which can be used to tell this function to not first check to see if there are
3186 any characters that are different in UTF-8 (variant characters) which would
3187 force it to allocate a new string to sv, but to assume there are. Typically
3188 this flag is used by a routine that has already parsed the string to find that
3189 there are such characters, and passes this information on so that the work
3190 doesn't have to be repeated.
3192 (One might think that the calling routine could pass in the position of the
3193 first such variant, so it wouldn't have to be found again. But that is not the
3194 case, because typically when the caller is likely to use this flag, it won't be
3195 calling this routine unless it finds something that won't fit into a byte.
3196 Otherwise it tries to not upgrade and just use bytes. But some things that
3197 do fit into a byte are variants in utf8, and the caller may not have been
3198 keeping track of these.)
3200 If the routine itself changes the string, it adds a trailing NUL. Such a NUL
3201 isn't guaranteed due to having other routines do the work in some input cases,
3202 or if the input is already flagged as being in utf8.
3204 The speed of this could perhaps be improved for many cases if someone wanted to
3205 write a fast function that counts the number of variant characters in a string,
3206 especially if it could return the position of the first one.
3211 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
3215 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3217 if (sv == &PL_sv_undef)
3221 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3222 (void) sv_2pv_flags(sv,&len, flags);
3224 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3228 (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3233 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3238 sv_force_normal_flags(sv, 0);
3241 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3242 sv_recode_to_utf8(sv, PL_encoding);
3243 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3247 if (SvCUR(sv) == 0) {
3248 if (extra) SvGROW(sv, extra);
3249 } else { /* Assume Latin-1/EBCDIC */
3250 /* This function could be much more efficient if we
3251 * had a FLAG in SVs to signal if there are any variant
3252 * chars in the PV. Given that there isn't such a flag
3253 * make the loop as fast as possible (although there are certainly ways
3254 * to speed this up, eg. through vectorization) */
3255 U8 * s = (U8 *) SvPVX_const(sv);
3256 U8 * e = (U8 *) SvEND(sv);
3258 STRLEN two_byte_count = 0;
3260 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3262 /* See if really will need to convert to utf8. We mustn't rely on our
3263 * incoming SV being well formed and having a trailing '\0', as certain
3264 * code in pp_formline can send us partially built SVs. */
3268 if (NATIVE_IS_INVARIANT(ch)) continue;
3270 t--; /* t already incremented; re-point to first variant */
3275 /* utf8 conversion not needed because all are invariants. Mark as
3276 * UTF-8 even if no variant - saves scanning loop */
3282 /* Here, the string should be converted to utf8, either because of an
3283 * input flag (two_byte_count = 0), or because a character that
3284 * requires 2 bytes was found (two_byte_count = 1). t points either to
3285 * the beginning of the string (if we didn't examine anything), or to
3286 * the first variant. In either case, everything from s to t - 1 will
3287 * occupy only 1 byte each on output.
3289 * There are two main ways to convert. One is to create a new string
3290 * and go through the input starting from the beginning, appending each
3291 * converted value onto the new string as we go along. It's probably
3292 * best to allocate enough space in the string for the worst possible
3293 * case rather than possibly running out of space and having to
3294 * reallocate and then copy what we've done so far. Since everything
3295 * from s to t - 1 is invariant, the destination can be initialized
3296 * with these using a fast memory copy
3298 * The other way is to figure out exactly how big the string should be
3299 * by parsing the entire input. Then you don't have to make it big
3300 * enough to handle the worst possible case, and more importantly, if
3301 * the string you already have is large enough, you don't have to
3302 * allocate a new string, you can copy the last character in the input
3303 * string to the final position(s) that will be occupied by the
3304 * converted string and go backwards, stopping at t, since everything
3305 * before that is invariant.
3307 * There are advantages and disadvantages to each method.
3309 * In the first method, we can allocate a new string, do the memory
3310 * copy from the s to t - 1, and then proceed through the rest of the
3311 * string byte-by-byte.
3313 * In the second method, we proceed through the rest of the input
3314 * string just calculating how big the converted string will be. Then
3315 * there are two cases:
3316 * 1) if the string has enough extra space to handle the converted
3317 * value. We go backwards through the string, converting until we
3318 * get to the position we are at now, and then stop. If this
3319 * position is far enough along in the string, this method is
3320 * faster than the other method. If the memory copy were the same
3321 * speed as the byte-by-byte loop, that position would be about
3322 * half-way, as at the half-way mark, parsing to the end and back
3323 * is one complete string's parse, the same amount as starting
3324 * over and going all the way through. Actually, it would be
3325 * somewhat less than half-way, as it's faster to just count bytes
3326 * than to also copy, and we don't have the overhead of allocating
3327 * a new string, changing the scalar to use it, and freeing the
3328 * existing one. But if the memory copy is fast, the break-even
3329 * point is somewhere after half way. The counting loop could be
3330 * sped up by vectorization, etc, to move the break-even point
3331 * further towards the beginning.
3332 * 2) if the string doesn't have enough space to handle the converted
3333 * value. A new string will have to be allocated, and one might
3334 * as well, given that, start from the beginning doing the first
3335 * method. We've spent extra time parsing the string and in
3336 * exchange all we've gotten is that we know precisely how big to
3337 * make the new one. Perl is more optimized for time than space,
3338 * so this case is a loser.
3339 * So what I've decided to do is not use the 2nd method unless it is
3340 * guaranteed that a new string won't have to be allocated, assuming
3341 * the worst case. I also decided not to put any more conditions on it
3342 * than this, for now. It seems likely that, since the worst case is
3343 * twice as big as the unknown portion of the string (plus 1), we won't
3344 * be guaranteed enough space, causing us to go to the first method,
3345 * unless the string is short, or the first variant character is near
3346 * the end of it. In either of these cases, it seems best to use the
3347 * 2nd method. The only circumstance I can think of where this would
3348 * be really slower is if the string had once had much more data in it
3349 * than it does now, but there is still a substantial amount in it */
3352 STRLEN invariant_head = t - s;
3353 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3354 if (SvLEN(sv) < size) {
3356 /* Here, have decided to allocate a new string */
3361 Newx(dst, size, U8);
3363 /* If no known invariants at the beginning of the input string,
3364 * set so starts from there. Otherwise, can use memory copy to
3365 * get up to where we are now, and then start from here */
3367 if (invariant_head <= 0) {
3370 Copy(s, dst, invariant_head, char);
3371 d = dst + invariant_head;
3375 const UV uv = NATIVE8_TO_UNI(*t++);
3376 if (UNI_IS_INVARIANT(uv))
3377 *d++ = (U8)UNI_TO_NATIVE(uv);
3379 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3380 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3384 SvPV_free(sv); /* No longer using pre-existing string */
3385 SvPV_set(sv, (char*)dst);
3386 SvCUR_set(sv, d - dst);
3387 SvLEN_set(sv, size);
3390 /* Here, have decided to get the exact size of the string.
3391 * Currently this happens only when we know that there is
3392 * guaranteed enough space to fit the converted string, so
3393 * don't have to worry about growing. If two_byte_count is 0,
3394 * then t points to the first byte of the string which hasn't
3395 * been examined yet. Otherwise two_byte_count is 1, and t
3396 * points to the first byte in the string that will expand to
3397 * two. Depending on this, start examining at t or 1 after t.
3400 U8 *d = t + two_byte_count;
3403 /* Count up the remaining bytes that expand to two */
3406 const U8 chr = *d++;
3407 if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3410 /* The string will expand by just the number of bytes that
3411 * occupy two positions. But we are one afterwards because of
3412 * the increment just above. This is the place to put the
3413 * trailing NUL, and to set the length before we decrement */
3415 d += two_byte_count;
3416 SvCUR_set(sv, d - s);
3420 /* Having decremented d, it points to the position to put the
3421 * very last byte of the expanded string. Go backwards through
3422 * the string, copying and expanding as we go, stopping when we
3423 * get to the part that is invariant the rest of the way down */
3427 const U8 ch = NATIVE8_TO_UNI(*e--);
3428 if (UNI_IS_INVARIANT(ch)) {
3429 *d-- = UNI_TO_NATIVE(ch);
3431 *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3432 *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3437 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3438 /* Update pos. We do it at the end rather than during
3439 * the upgrade, to avoid slowing down the common case
3440 * (upgrade without pos) */
3441 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3443 I32 pos = mg->mg_len;
3444 if (pos > 0 && (U32)pos > invariant_head) {
3445 U8 *d = (U8*) SvPVX(sv) + invariant_head;
3446 STRLEN n = (U32)pos - invariant_head;
3448 if (UTF8_IS_START(*d))
3453 mg->mg_len = d - (U8*)SvPVX(sv);
3456 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3457 magic_setutf8(sv,mg); /* clear UTF8 cache */
3462 /* Mark as UTF-8 even if no variant - saves scanning loop */
3468 =for apidoc sv_utf8_downgrade
3470 Attempts to convert the PV of an SV from characters to bytes.
3471 If the PV contains a character that cannot fit
3472 in a byte, this conversion will fail;
3473 in this case, either returns false or, if C<fail_ok> is not
3476 This is not as a general purpose Unicode to byte encoding interface:
3477 use the Encode extension for that.
3483 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3487 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3489 if (SvPOKp(sv) && SvUTF8(sv)) {
3493 int mg_flags = SV_GMAGIC;
3496 sv_force_normal_flags(sv, 0);
3498 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3500 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3502 I32 pos = mg->mg_len;
3504 sv_pos_b2u(sv, &pos);
3505 mg_flags = 0; /* sv_pos_b2u does get magic */
3509 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3510 magic_setutf8(sv,mg); /* clear UTF8 cache */
3513 s = (U8 *) SvPV_flags(sv, len, mg_flags);
3515 if (!utf8_to_bytes(s, &len)) {
3520 Perl_croak(aTHX_ "Wide character in %s",
3523 Perl_croak(aTHX_ "Wide character");
3534 =for apidoc sv_utf8_encode
3536 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3537 flag off so that it looks like octets again.
3543 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3545 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3548 sv_force_normal_flags(sv, 0);
3550 if (SvREADONLY(sv)) {
3551 Perl_croak_no_modify(aTHX);
3553 (void) sv_utf8_upgrade(sv);
3558 =for apidoc sv_utf8_decode
3560 If the PV of the SV is an octet sequence in UTF-8
3561 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3562 so that it looks like a character. If the PV contains only single-byte
3563 characters, the C<SvUTF8> flag stays being off.
3564 Scans PV for validity and returns false if the PV is invalid UTF-8.
3570 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3572 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3575 const U8 *start, *c;
3578 /* The octets may have got themselves encoded - get them back as
3581 if (!sv_utf8_downgrade(sv, TRUE))
3584 /* it is actually just a matter of turning the utf8 flag on, but
3585 * we want to make sure everything inside is valid utf8 first.
3587 c = start = (const U8 *) SvPVX_const(sv);
3588 if (!is_utf8_string(c, SvCUR(sv)+1))
3590 e = (const U8 *) SvEND(sv);
3593 if (!UTF8_IS_INVARIANT(ch)) {
3598 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3599 /* adjust pos to the start of a UTF8 char sequence */
3600 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3602 I32 pos = mg->mg_len;
3604 for (c = start + pos; c > start; c--) {
3605 if (UTF8_IS_START(*c))
3608 mg->mg_len = c - start;
3611 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3612 magic_setutf8(sv,mg); /* clear UTF8 cache */
3619 =for apidoc sv_setsv
3621 Copies the contents of the source SV C<ssv> into the destination SV
3622 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3623 function if the source SV needs to be reused. Does not handle 'set' magic.
3624 Loosely speaking, it performs a copy-by-value, obliterating any previous
3625 content of the destination.
3627 You probably want to use one of the assortment of wrappers, such as
3628 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3629 C<SvSetMagicSV_nosteal>.
3631 =for apidoc sv_setsv_flags
3633 Copies the contents of the source SV C<ssv> into the destination SV
3634 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3635 function if the source SV needs to be reused. Does not handle 'set' magic.
3636 Loosely speaking, it performs a copy-by-value, obliterating any previous
3637 content of the destination.
3638 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3639 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3640 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3641 and C<sv_setsv_nomg> are implemented in terms of this function.
3643 You probably want to use one of the assortment of wrappers, such as
3644 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3645 C<SvSetMagicSV_nosteal>.
3647 This is the primary function for copying scalars, and most other
3648 copy-ish functions and macros use this underneath.
3654 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3656 I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3657 HV *old_stash = NULL;
3659 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3661 if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3662 const char * const name = GvNAME(sstr);
3663 const STRLEN len = GvNAMELEN(sstr);
3665 if (dtype >= SVt_PV) {
3671 SvUPGRADE(dstr, SVt_PVGV);
3672 (void)SvOK_off(dstr);
3673 /* FIXME - why are we doing this, then turning it off and on again
3675 isGV_with_GP_on(dstr);
3677 GvSTASH(dstr) = GvSTASH(sstr);
3679 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3680 gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
3681 SvFAKE_on(dstr); /* can coerce to non-glob */
3684 if(GvGP(MUTABLE_GV(sstr))) {
3685 /* If source has method cache entry, clear it */
3687 SvREFCNT_dec(GvCV(sstr));
3688 GvCV_set(sstr, NULL);
3691 /* If source has a real method, then a method is
3694 GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3700 /* If dest already had a real method, that's a change as well */
3702 !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3703 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3708 /* We don’t need to check the name of the destination if it was not a
3709 glob to begin with. */
3710 if(dtype == SVt_PVGV) {
3711 const char * const name = GvNAME((const GV *)dstr);
3714 /* The stash may have been detached from the symbol table, so
3716 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3717 && GvAV((const GV *)sstr)
3721 const STRLEN len = GvNAMELEN(dstr);
3722 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3723 || (len == 1 && name[0] == ':')) {
3726 /* Set aside the old stash, so we can reset isa caches on
3728 if((old_stash = GvHV(dstr)))
3729 /* Make sure we do not lose it early. */
3730 SvREFCNT_inc_simple_void_NN(
3731 sv_2mortal((SV *)old_stash)
3737 gp_free(MUTABLE_GV(dstr));
3738 isGV_with_GP_off(dstr);
3739 (void)SvOK_off(dstr);
3740 isGV_with_GP_on(dstr);
3741 GvINTRO_off(dstr); /* one-shot flag */
3742 GvGP_set(dstr, gp_ref(GvGP(sstr)));
3743 if (SvTAINTED(sstr))
3745 if (GvIMPORTED(dstr) != GVf_IMPORTED
3746 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3748 GvIMPORTED_on(dstr);
3751 if(mro_changes == 2) {
3753 SV * const sref = (SV *)GvAV((const GV *)dstr);
3754 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3755 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3756 AV * const ary = newAV();
3757 av_push(ary, mg->mg_obj); /* takes the refcount */
3758 mg->mg_obj = (SV *)ary;
3760 av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3762 else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3763 mro_isa_changed_in(GvSTASH(dstr));
3765 else if(mro_changes == 3) {
3766 HV * const stash = GvHV(dstr);
3767 if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3773 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3778 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3780 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3782 const int intro = GvINTRO(dstr);
3785 const U32 stype = SvTYPE(sref);
3787 PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3790 GvINTRO_off(dstr); /* one-shot flag */
3791 GvLINE(dstr) = CopLINE(PL_curcop);
3792 GvEGV(dstr) = MUTABLE_GV(dstr);
3797 location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
3798 import_flag = GVf_IMPORTED_CV;
3801 location = (SV **) &GvHV(dstr);
3802 import_flag = GVf_IMPORTED_HV;
3805 location = (SV **) &GvAV(dstr);
3806 import_flag = GVf_IMPORTED_AV;
3809 location = (SV **) &GvIOp(dstr);
3812 location = (SV **) &GvFORM(dstr);
3815 location = &GvSV(dstr);
3816 import_flag = GVf_IMPORTED_SV;
3819 if (stype == SVt_PVCV) {
3820 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3821 if (GvCVGEN(dstr)) {
3822 SvREFCNT_dec(GvCV(dstr));
3823 GvCV_set(dstr, NULL);
3824 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3827 SAVEGENERICSV(*location);
3831 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3832 CV* const cv = MUTABLE_CV(*location);
3834 if (!GvCVGEN((const GV *)dstr) &&
3835 (CvROOT(cv) || CvXSUB(cv)))
3837 /* Redefining a sub - warning is mandatory if
3838 it was a const and its value changed. */
3839 if (CvCONST(cv) && CvCONST((const CV *)sref)
3841 == cv_const_sv((const CV *)sref)) {
3843 /* They are 2 constant subroutines generated from
3844 the same constant. This probably means that
3845 they are really the "same" proxy subroutine
3846 instantiated in 2 places. Most likely this is
3847 when a constant is exported twice. Don't warn.
3850 else if (ckWARN(WARN_REDEFINE)
3852 && (!CvCONST((const CV *)sref)
3853 || sv_cmp(cv_const_sv(cv),
3854 cv_const_sv((const CV *)
3856 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3859 ? "Constant subroutine %s::%s redefined"
3860 : "Subroutine %s::%s redefined"),
3861 HvNAME_get(GvSTASH((const GV *)dstr)),
3862 GvENAME(MUTABLE_GV(dstr)));
3866 cv_ckproto_len(cv, (const GV *)dstr,
3867 SvPOK(sref) ? SvPVX_const(sref) : NULL,
3868 SvPOK(sref) ? SvCUR(sref) : 0);
3870 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3871 GvASSUMECV_on(dstr);
3872 if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3875 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3876 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3877 GvFLAGS(dstr) |= import_flag;
3879 if (stype == SVt_PVHV) {
3880 const char * const name = GvNAME((GV*)dstr);
3881 const STRLEN len = GvNAMELEN(dstr);
3884 (len > 1 && name[len-2] == ':' && name[len-1] == ':')
3885 || (len == 1 && name[0] == ':')
3887 && (!dref || HvENAME_get(dref))
3890 (HV *)sref, (HV *)dref,
3896 stype == SVt_PVAV && sref != dref
3897 && strEQ(GvNAME((GV*)dstr), "ISA")
3898 /* The stash may have been detached from the symbol table, so
3899 check its name before doing anything. */
3900 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3903 MAGIC * const omg = dref && SvSMAGICAL(dref)
3904 ? mg_find(dref, PERL_MAGIC_isa)
3906 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3907 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3908 AV * const ary = newAV();
3909 av_push(ary, mg->mg_obj); /* takes the refcount */
3910 mg->mg_obj = (SV *)ary;
3913 if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
3914 SV **svp = AvARRAY((AV *)omg->mg_obj);
3915 I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
3919 SvREFCNT_inc_simple_NN(*svp++)
3925 SvREFCNT_inc_simple_NN(omg->mg_obj)
3929 av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
3934 sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
3936 mg = mg_find(sref, PERL_MAGIC_isa);
3938 /* Since the *ISA assignment could have affected more than
3939 one stash, don’t call mro_isa_changed_in directly, but let
3940 magic_clearisa do it for us, as it already has the logic for
3941 dealing with globs vs arrays of globs. */
3943 Perl_magic_clearisa(aTHX_ NULL, mg);
3948 if (SvTAINTED(sstr))
3954 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3957 register U32 sflags;
3959 register svtype stype;
3961 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3966 if (SvIS_FREED(dstr)) {
3967 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3968 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3970 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3972 sstr = &PL_sv_undef;
3973 if (SvIS_FREED(sstr)) {
3974 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3975 (void*)sstr, (void*)dstr);
3977 stype = SvTYPE(sstr);
3978 dtype = SvTYPE(dstr);
3980 (void)SvAMAGIC_off(dstr);
3983 /* need to nuke the magic */
3987 /* There's a lot of redundancy below but we're going for speed here */
3992 if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
3993 (void)SvOK_off(dstr);
4001 sv_upgrade(dstr, SVt_IV);
4005 sv_upgrade(dstr, SVt_PVIV);
4009 goto end_of_first_switch;
4011 (void)SvIOK_only(dstr);
4012 SvIV_set(dstr, SvIVX(sstr));
4015 /* SvTAINTED can only be true if the SV has taint magic, which in
4016 turn means that the SV type is PVMG (or greater). This is the
4017 case statement for SVt_IV, so this cannot be true (whatever gcov
4019 assert(!SvTAINTED(sstr));
4024 if (dtype < SVt_PV && dtype != SVt_IV)
4025 sv_upgrade(dstr, SVt_IV);
4033 sv_upgrade(dstr, SVt_NV);
4037 sv_upgrade(dstr, SVt_PVNV);
4041 goto end_of_first_switch;
4043 SvNV_set(dstr, SvNVX(sstr));
4044 (void)SvNOK_only(dstr);
4045 /* SvTAINTED can only be true if the SV has taint magic, which in
4046 turn means that the SV type is PVMG (or greater). This is the
4047 case statement for SVt_NV, so this cannot be true (whatever gcov
4049 assert(!SvTAINTED(sstr));
4055 #ifdef PERL_OLD_COPY_ON_WRITE
4056 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
4057 if (dtype < SVt_PVIV)
4058 sv_upgrade(dstr, SVt_PVIV);
4065 sv_upgrade(dstr, SVt_PV);
4068 if (dtype < SVt_PVIV)
4069 sv_upgrade(dstr, SVt_PVIV);
4072 if (dtype < SVt_PVNV)
4073 sv_upgrade(dstr, SVt_PVNV);
4077 const char * const type = sv_reftype(sstr,0);
4079 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4081 Perl_croak(aTHX_ "Bizarre copy of %s", type);
4086 if (dtype < SVt_REGEXP)
4087 sv_upgrade(dstr, SVt_REGEXP);
4090 /* case SVt_BIND: */
4093 /* SvVALID means that this PVGV is playing at being an FBM. */
4096 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4098 if (SvTYPE(sstr) != stype)
4099 stype = SvTYPE(sstr);
4101 if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4102 glob_assign_glob(dstr, sstr, dtype);
4105 if (stype == SVt_PVLV)
4106 SvUPGRADE(dstr, SVt_PVNV);
4108 SvUPGRADE(dstr, (svtype)stype);
4110 end_of_first_switch:
4112 /* dstr may have been upgraded. */
4113 dtype = SvTYPE(dstr);
4114 sflags = SvFLAGS(sstr);
4116 if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
4117 /* Assigning to a subroutine sets the prototype. */
4120 const char *const ptr = SvPV_const(sstr, len);
4122 SvGROW(dstr, len + 1);
4123 Copy(ptr, SvPVX(dstr), len + 1, char);
4124 SvCUR_set(dstr, len);
4126 SvFLAGS(dstr) |= sflags & SVf_UTF8;
4130 } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
4131 const char * const type = sv_reftype(dstr,0);
4133 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4135 Perl_croak(aTHX_ "Cannot copy to %s", type);
4136 } else if (sflags & SVf_ROK) {
4137 if (isGV_with_GP(dstr)
4138 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4141 if (GvIMPORTED(dstr) != GVf_IMPORTED
4142 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4144 GvIMPORTED_on(dstr);
4149 glob_assign_glob(dstr, sstr, dtype);
4153 if (dtype >= SVt_PV) {
4154 if (isGV_with_GP(dstr)) {
4155 glob_assign_ref(dstr, sstr);
4158 if (SvPVX_const(dstr)) {
4164 (void)SvOK_off(dstr);
4165 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4166 SvFLAGS(dstr) |= sflags & SVf_ROK;
4167 assert(!(sflags & SVp_NOK));
4168 assert(!(sflags & SVp_IOK));
4169 assert(!(sflags & SVf_NOK));
4170 assert(!(sflags & SVf_IOK));
4172 else if (isGV_with_GP(dstr)) {
4173 if (!(sflags & SVf_OK)) {
4174 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4175 "Undefined value assigned to typeglob");
4178 GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
4179 if (dstr != (const SV *)gv) {
4180 const char * const name = GvNAME((const GV *)dstr);
4181 const STRLEN len = GvNAMELEN(dstr);
4182 HV *old_stash = NULL;
4183 bool reset_isa = FALSE;
4184 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4185 || (len == 1 && name[0] == ':')) {
4186 /* Set aside the old stash, so we can reset isa caches
4187 on its subclasses. */
4188 if((old_stash = GvHV(dstr))) {
4189 /* Make sure we do not lose it early. */
4190 SvREFCNT_inc_simple_void_NN(
4191 sv_2mortal((SV *)old_stash)
4198 gp_free(MUTABLE_GV(dstr));
4199 GvGP_set(dstr, gp_ref(GvGP(gv)));
4202 HV * const stash = GvHV(dstr);
4204 old_stash ? (HV *)HvENAME_get(old_stash) : stash
4214 else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
4215 reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4217 else if (sflags & SVp_POK) {
4221 * Check to see if we can just swipe the string. If so, it's a
4222 * possible small lose on short strings, but a big win on long ones.
4223 * It might even be a win on short strings if SvPVX_const(dstr)
4224 * has to be allocated and SvPVX_const(sstr) has to be freed.
4225 * Likewise if we can set up COW rather than doing an actual copy, we
4226 * drop to the else clause, as the swipe code and the COW setup code
4227 * have much in common.
4230 /* Whichever path we take through the next code, we want this true,
4231 and doing it now facilitates the COW check. */
4232 (void)SvPOK_only(dstr);
4235 /* If we're already COW then this clause is not true, and if COW
4236 is allowed then we drop down to the else and make dest COW
4237 with us. If caller hasn't said that we're allowed to COW
4238 shared hash keys then we don't do the COW setup, even if the
4239 source scalar is a shared hash key scalar. */
4240 (((flags & SV_COW_SHARED_HASH_KEYS)
4241 ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4242 : 1 /* If making a COW copy is forbidden then the behaviour we
4243 desire is as if the source SV isn't actually already
4244 COW, even if it is. So we act as if the source flags
4245 are not COW, rather than actually testing them. */
4247 #ifndef PERL_OLD_COPY_ON_WRITE
4248 /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4249 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4250 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4251 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4252 but in turn, it's somewhat dead code, never expected to go
4253 live, but more kept as a placeholder on how to do it better
4254 in a newer implementation. */
4255 /* If we are COW and dstr is a suitable target then we drop down
4256 into the else and make dest a COW of us. */
4257 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4262 (sflags & SVs_TEMP) && /* slated for free anyway? */
4263 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4264 (!(flags & SV_NOSTEAL)) &&
4265 /* and we're allowed to steal temps */
4266 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4267 SvLEN(sstr)) /* and really is a string */
4268 #ifdef PERL_OLD_COPY_ON_WRITE
4269 && ((flags & SV_COW_SHARED_HASH_KEYS)
4270 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4271 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4272 && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4276 /* Failed the swipe test, and it's not a shared hash key either.
4277 Have to copy the string. */
4278 STRLEN len = SvCUR(sstr);
4279 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4280 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4281 SvCUR_set(dstr, len);
4282 *SvEND(dstr) = '\0';
4284 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4286 /* Either it's a shared hash key, or it's suitable for
4287 copy-on-write or we can swipe the string. */
4289 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4293 #ifdef PERL_OLD_COPY_ON_WRITE
4295 if ((sflags & (SVf_FAKE | SVf_READONLY))
4296 != (SVf_FAKE | SVf_READONLY)) {
4297 SvREADONLY_on(sstr);
4299 /* Make the source SV into a loop of 1.
4300 (about to become 2) */
4301 SV_COW_NEXT_SV_SET(sstr, sstr);
4305 /* Initial code is common. */
4306 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4311 /* making another shared SV. */
4312 STRLEN cur = SvCUR(sstr);
4313 STRLEN len = SvLEN(sstr);
4314 #ifdef PERL_OLD_COPY_ON_WRITE
4316 assert (SvTYPE(dstr) >= SVt_PVIV);
4317 /* SvIsCOW_normal */
4318 /* splice us in between source and next-after-source. */
4319 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4320 SV_COW_NEXT_SV_SET(sstr, dstr);
4321 SvPV_set(dstr, SvPVX_mutable(sstr));
4325 /* SvIsCOW_shared_hash */
4326 DEBUG_C(PerlIO_printf(Perl_debug_log,
4327 "Copy on write: Sharing hash\n"));
4329 assert (SvTYPE(dstr) >= SVt_PV);
4331 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4333 SvLEN_set(dstr, len);
4334 SvCUR_set(dstr, cur);
4335 SvREADONLY_on(dstr);
4339 { /* Passes the swipe test. */
4340 SvPV_set(dstr, SvPVX_mutable(sstr));
4341 SvLEN_set(dstr, SvLEN(sstr));
4342 SvCUR_set(dstr, SvCUR(sstr));
4345 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4346 SvPV_set(sstr, NULL);
4352 if (sflags & SVp_NOK) {
4353 SvNV_set(dstr, SvNVX(sstr));
4355 if (sflags & SVp_IOK) {
4356 SvIV_set(dstr, SvIVX(sstr));
4357 /* Must do this otherwise some other overloaded use of 0x80000000
4358 gets confused. I guess SVpbm_VALID */
4359 if (sflags & SVf_IVisUV)
4362 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4364 const MAGIC * const smg = SvVSTRING_mg(sstr);
4366 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4367 smg->mg_ptr, smg->mg_len);
4368 SvRMAGICAL_on(dstr);
4372 else if (sflags & (SVp_IOK|SVp_NOK)) {
4373 (void)SvOK_off(dstr);
4374 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4375 if (sflags & SVp_IOK) {
4376 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4377 SvIV_set(dstr, SvIVX(sstr));
4379 if (sflags & SVp_NOK) {
4380 SvNV_set(dstr, SvNVX(sstr));
4384 if (isGV_with_GP(sstr)) {
4385 /* This stringification rule for globs is spread in 3 places.
4386 This feels bad. FIXME. */
4387 const U32 wasfake = sflags & SVf_FAKE;
4389 /* FAKE globs can get coerced, so need to turn this off
4390 temporarily if it is on. */
4392 gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4393 SvFLAGS(sstr) |= wasfake;
4396 (void)SvOK_off(dstr);
4398 if (SvTAINTED(sstr))
4403 =for apidoc sv_setsv_mg
4405 Like C<sv_setsv>, but also handles 'set' magic.
4411 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4413 PERL_ARGS_ASSERT_SV_SETSV_MG;
4415 sv_setsv(dstr,sstr);
4419 #ifdef PERL_OLD_COPY_ON_WRITE
4421 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4423 STRLEN cur = SvCUR(sstr);
4424 STRLEN len = SvLEN(sstr);
4425 register char *new_pv;
4427 PERL_ARGS_ASSERT_SV_SETSV_COW;
4430 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4431 (void*)sstr, (void*)dstr);
4438 if (SvTHINKFIRST(dstr))
4439 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4440 else if (SvPVX_const(dstr))
4441 Safefree(SvPVX_const(dstr));
4445 SvUPGRADE(dstr, SVt_PVIV);
4447 assert (SvPOK(sstr));
4448 assert (SvPOKp(sstr));
4449 assert (!SvIOK(sstr));
4450 assert (!SvIOKp(sstr));
4451 assert (!SvNOK(sstr));
4452 assert (!SvNOKp(sstr));
4454 if (SvIsCOW(sstr)) {
4456 if (SvLEN(sstr) == 0) {
4457 /* source is a COW shared hash key. */
4458 DEBUG_C(PerlIO_printf(Perl_debug_log,
4459 "Fast copy on write: Sharing hash\n"));
4460 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4463 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4465 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4466 SvUPGRADE(sstr, SVt_PVIV);
4467 SvREADONLY_on(sstr);
4469 DEBUG_C(PerlIO_printf(Perl_debug_log,
4470 "Fast copy on write: Converting sstr to COW\n"));
4471 SV_COW_NEXT_SV_SET(dstr, sstr);
4473 SV_COW_NEXT_SV_SET(sstr, dstr);
4474 new_pv = SvPVX_mutable(sstr);
4477 SvPV_set(dstr, new_pv);
4478 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4481 SvLEN_set(dstr, len);
4482 SvCUR_set(dstr, cur);
4491 =for apidoc sv_setpvn
4493 Copies a string into an SV. The C<len> parameter indicates the number of
4494 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4495 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4501 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4504 register char *dptr;
4506 PERL_ARGS_ASSERT_SV_SETPVN;
4508 SV_CHECK_THINKFIRST_COW_DROP(sv);
4514 /* len is STRLEN which is unsigned, need to copy to signed */
4517 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4519 SvUPGRADE(sv, SVt_PV);
4521 dptr = SvGROW(sv, len + 1);
4522 Move(ptr,dptr,len,char);
4525 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4530 =for apidoc sv_setpvn_mg
4532 Like C<sv_setpvn>, but also handles 'set' magic.
4538 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4540 PERL_ARGS_ASSERT_SV_SETPVN_MG;
4542 sv_setpvn(sv,ptr,len);
4547 =for apidoc sv_setpv
4549 Copies a string into an SV. The string must be null-terminated. Does not
4550 handle 'set' magic. See C<sv_setpv_mg>.
4556 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4559 register STRLEN len;
4561 PERL_ARGS_ASSERT_SV_SETPV;
4563 SV_CHECK_THINKFIRST_COW_DROP(sv);
4569 SvUPGRADE(sv, SVt_PV);
4571 SvGROW(sv, len + 1);
4572 Move(ptr,SvPVX(sv),len+1,char);
4574 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4579 =for apidoc sv_setpv_mg
4581 Like C<sv_setpv>, but also handles 'set' magic.
4587 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4589 PERL_ARGS_ASSERT_SV_SETPV_MG;
4596 =for apidoc sv_usepvn_flags
4598 Tells an SV to use C<ptr> to find its string value. Normally the
4599 string is stored inside the SV but sv_usepvn allows the SV to use an
4600 outside string. The C<ptr> should point to memory that was allocated
4601 by C<malloc>. The string length, C<len>, must be supplied. By default
4602 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4603 so that pointer should not be freed or used by the programmer after
4604 giving it to sv_usepvn, and neither should any pointers from "behind"
4605 that pointer (e.g. ptr + 1) be used.
4607 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4608 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4609 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4610 C<len>, and already meets the requirements for storing in C<SvPVX>)
4616 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4621 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4623 SV_CHECK_THINKFIRST_COW_DROP(sv);
4624 SvUPGRADE(sv, SVt_PV);
4627 if (flags & SV_SMAGIC)
4631 if (SvPVX_const(sv))
4635 if (flags & SV_HAS_TRAILING_NUL)
4636 assert(ptr[len] == '\0');
4639 allocate = (flags & SV_HAS_TRAILING_NUL)
4641 #ifdef Perl_safesysmalloc_size
4644 PERL_STRLEN_ROUNDUP(len + 1);
4646 if (flags & SV_HAS_TRAILING_NUL) {
4647 /* It's long enough - do nothing.
4648 Specifically Perl_newCONSTSUB is relying on this. */
4651 /* Force a move to shake out bugs in callers. */
4652 char *new_ptr = (char*)safemalloc(allocate);
4653 Copy(ptr, new_ptr, len, char);
4654 PoisonFree(ptr,len,char);
4658 ptr = (char*) saferealloc (ptr, allocate);
4661 #ifdef Perl_safesysmalloc_size
4662 SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4664 SvLEN_set(sv, allocate);
4668 if (!(flags & SV_HAS_TRAILING_NUL)) {
4671 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4673 if (flags & SV_SMAGIC)
4677 #ifdef PERL_OLD_COPY_ON_WRITE
4678 /* Need to do this *after* making the SV normal, as we need the buffer
4679 pointer to remain valid until after we've copied it. If we let go too early,
4680 another thread could invalidate it by unsharing last of the same hash key
4681 (which it can do by means other than releasing copy-on-write Svs)
4682 or by changing the other copy-on-write SVs in the loop. */
4684 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4686 PERL_ARGS_ASSERT_SV_RELEASE_COW;
4688 { /* this SV was SvIsCOW_normal(sv) */
4689 /* we need to find the SV pointing to us. */
4690 SV *current = SV_COW_NEXT_SV(after);
4692 if (current == sv) {
4693 /* The SV we point to points back to us (there were only two of us
4695 Hence other SV is no longer copy on write either. */
4697 SvREADONLY_off(after);
4699 /* We need to follow the pointers around the loop. */
4701 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4704 /* don't loop forever if the structure is bust, and we have
4705 a pointer into a closed loop. */
4706 assert (current != after);
4707 assert (SvPVX_const(current) == pvx);
4709 /* Make the SV before us point to the SV after us. */
4710 SV_COW_NEXT_SV_SET(current, after);
4716 =for apidoc sv_force_normal_flags
4718 Undo various types of fakery on an SV: if the PV is a shared string, make
4719 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4720 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4721 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4722 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4723 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4724 set to some other value.) In addition, the C<flags> parameter gets passed to
4725 C<sv_unref_flags()> when unreffing. C<sv_force_normal> calls this function
4726 with flags set to 0.
4732 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4736 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4738 #ifdef PERL_OLD_COPY_ON_WRITE
4739 if (SvREADONLY(sv)) {
4741 const char * const pvx = SvPVX_const(sv);
4742 const STRLEN len = SvLEN(sv);
4743 const STRLEN cur = SvCUR(sv);
4744 /* next COW sv in the loop. If len is 0 then this is a shared-hash
4745 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4746 we'll fail an assertion. */
4747 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4750 PerlIO_printf(Perl_debug_log,
4751 "Copy on write: Force normal %ld\n",
4757 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4760 if (flags & SV_COW_DROP_PV) {
4761 /* OK, so we don't need to copy our buffer. */
4764 SvGROW(sv, cur + 1);
4765 Move(pvx,SvPVX(sv),cur,char);
4770 sv_release_COW(sv, pvx, next);
4772 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4778 else if (IN_PERL_RUNTIME)
4779 Perl_croak_no_modify(aTHX);
4782 if (SvREADONLY(sv)) {
4784 const char * const pvx = SvPVX_const(sv);
4785 const STRLEN len = SvCUR(sv);
4790 SvGROW(sv, len + 1);
4791 Move(pvx,SvPVX(sv),len,char);
4793 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4795 else if (IN_PERL_RUNTIME)
4796 Perl_croak_no_modify(aTHX);
4800 sv_unref_flags(sv, flags);
4801 else if (SvFAKE(sv) && isGV_with_GP(sv))
4803 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
4804 /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
4805 to sv_unglob. We only need it here, so inline it. */
4806 const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
4807 SV *const temp = newSV_type(new_type);
4808 void *const temp_p = SvANY(sv);
4810 if (new_type == SVt_PVMG) {
4811 SvMAGIC_set(temp, SvMAGIC(sv));
4812 SvMAGIC_set(sv, NULL);
4813 SvSTASH_set(temp, SvSTASH(sv));
4814 SvSTASH_set(sv, NULL);
4816 SvCUR_set(temp, SvCUR(sv));
4817 /* Remember that SvPVX is in the head, not the body. */
4819 SvLEN_set(temp, SvLEN(sv));
4820 /* This signals "buffer is owned by someone else" in sv_clear,
4821 which is the least effort way to stop it freeing the buffer.
4823 SvLEN_set(sv, SvLEN(sv)+1);
4825 /* Their buffer is already owned by someone else. */
4826 SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
4827 SvLEN_set(temp, SvCUR(sv)+1);
4830 /* Now swap the rest of the bodies. */
4832 SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
4833 SvFLAGS(sv) |= new_type;
4834 SvANY(sv) = SvANY(temp);
4836 SvFLAGS(temp) &= ~(SVTYPEMASK);
4837 SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
4838 SvANY(temp) = temp_p;
4847 Efficient removal of characters from the beginning of the string buffer.
4848 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4849 the string buffer. The C<ptr> becomes the first character of the adjusted
4850 string. Uses the "OOK hack".
4851 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4852 refer to the same chunk of data.
4858 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4864 const U8 *real_start;
4868 PERL_ARGS_ASSERT_SV_CHOP;
4870 if (!ptr || !SvPOKp(sv))
4872 delta = ptr - SvPVX_const(sv);
4874 /* Nothing to do. */
4877 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4878 nothing uses the value of ptr any more. */
4879 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4880 if (ptr <= SvPVX_const(sv))
4881 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4882 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4883 SV_CHECK_THINKFIRST(sv);
4884 if (delta > max_delta)
4885 Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4886 SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4887 SvPVX_const(sv) + max_delta);
4890 if (!SvLEN(sv)) { /* make copy of shared string */
4891 const char *pvx = SvPVX_const(sv);
4892 const STRLEN len = SvCUR(sv);
4893 SvGROW(sv, len + 1);
4894 Move(pvx,SvPVX(sv),len,char);
4897 SvFLAGS(sv) |= SVf_OOK;
4900 SvOOK_offset(sv, old_delta);
4902 SvLEN_set(sv, SvLEN(sv) - delta);
4903 SvCUR_set(sv, SvCUR(sv) - delta);
4904 SvPV_set(sv, SvPVX(sv) + delta);
4906 p = (U8 *)SvPVX_const(sv);
4911 real_start = p - delta;
4915 if (delta < 0x100) {
4919 p -= sizeof(STRLEN);
4920 Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4924 /* Fill the preceding buffer with sentinals to verify that no-one is
4926 while (p > real_start) {
4934 =for apidoc sv_catpvn
4936 Concatenates the string onto the end of the string which is in the SV. The
4937 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4938 status set, then the bytes appended should be valid UTF-8.
4939 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4941 =for apidoc sv_catpvn_flags
4943 Concatenates the string onto the end of the string which is in the SV. The
4944 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4945 status set, then the bytes appended should be valid UTF-8.
4946 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4947 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4948 in terms of this function.
4954 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4958 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4960 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4962 SvGROW(dsv, dlen + slen + 1);
4964 sstr = SvPVX_const(dsv);
4965 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4966 SvCUR_set(dsv, SvCUR(dsv) + slen);
4968 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4970 if (flags & SV_SMAGIC)
4975 =for apidoc sv_catsv
4977 Concatenates the string from SV C<ssv> onto the end of the string in
4978 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4979 not 'set' magic. See C<sv_catsv_mg>.
4981 =for apidoc sv_catsv_flags
4983 Concatenates the string from SV C<ssv> onto the end of the string in
4984 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4985 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4986 and C<sv_catsv_nomg> are implemented in terms of this function.
4991 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4995 PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4999 const char *spv = SvPV_flags_const(ssv, slen, flags);
5001 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
5002 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
5003 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
5004 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
5005 dsv->sv_flags doesn't have that bit set.
5006 Andy Dougherty 12 Oct 2001
5008 const I32 sutf8 = DO_UTF8(ssv);
5011 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
5013 dutf8 = DO_UTF8(dsv);
5015 if (dutf8 != sutf8) {
5017 /* Not modifying source SV, so taking a temporary copy. */
5018 SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
5020 sv_utf8_upgrade(csv);
5021 spv = SvPV_const(csv, slen);
5024 /* Leave enough space for the cat that's about to happen */
5025 sv_utf8_upgrade_flags_grow(dsv, 0, slen);
5027 sv_catpvn_nomg(dsv, spv, slen);
5030 if (flags & SV_SMAGIC)
5035 =for apidoc sv_catpv
5037 Concatenates the string onto the end of the string which is in the SV.
5038 If the SV has the UTF-8 status set, then the bytes appended should be
5039 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
5044 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
5047 register STRLEN len;
5051 PERL_ARGS_ASSERT_SV_CATPV;
5055 junk = SvPV_force(sv, tlen);
5057 SvGROW(sv, tlen + len + 1);
5059 ptr = SvPVX_const(sv);
5060 Move(ptr,SvPVX(sv)+tlen,len+1,char);
5061 SvCUR_set(sv, SvCUR(sv) + len);
5062 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5067 =for apidoc sv_catpv_flags
5069 Concatenates the string onto the end of the string which is in the SV.
5070 If the SV has the UTF-8 status set, then the bytes appended should
5071 be valid UTF-8. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get>
5072 on the SVs if appropriate, else not.
5078 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
5080 PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5081 sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
5085 =for apidoc sv_catpv_mg
5087 Like C<sv_catpv>, but also handles 'set' magic.
5093 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
5095 PERL_ARGS_ASSERT_SV_CATPV_MG;
5104 Creates a new SV. A non-zero C<len> parameter indicates the number of
5105 bytes of preallocated string space the SV should have. An extra byte for a
5106 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
5107 space is allocated.) The reference count for the new SV is set to 1.
5109 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
5110 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5111 This aid has been superseded by a new build option, PERL_MEM_LOG (see
5112 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
5113 modules supporting older perls.
5119 Perl_newSV(pTHX_ const STRLEN len)
5126 sv_upgrade(sv, SVt_PV);
5127 SvGROW(sv, len + 1);
5132 =for apidoc sv_magicext
5134 Adds magic to an SV, upgrading it if necessary. Applies the
5135 supplied vtable and returns a pointer to the magic added.
5137 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5138 In particular, you can add magic to SvREADONLY SVs, and add more than
5139 one instance of the same 'how'.
5141 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5142 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5143 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5144 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5146 (This is now used as a subroutine by C<sv_magic>.)
5151 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
5152 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5157 PERL_ARGS_ASSERT_SV_MAGICEXT;
5159 SvUPGRADE(sv, SVt_PVMG);
5160 Newxz(mg, 1, MAGIC);
5161 mg->mg_moremagic = SvMAGIC(sv);
5162 SvMAGIC_set(sv, mg);
5164 /* Sometimes a magic contains a reference loop, where the sv and
5165 object refer to each other. To prevent a reference loop that
5166 would prevent such objects being freed, we look for such loops
5167 and if we find one we avoid incrementing the object refcount.
5169 Note we cannot do this to avoid self-tie loops as intervening RV must
5170 have its REFCNT incremented to keep it in existence.
5173 if (!obj || obj == sv ||
5174 how == PERL_MAGIC_arylen ||
5175 how == PERL_MAGIC_symtab ||
5176 (SvTYPE(obj) == SVt_PVGV &&
5177 (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5178 || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5179 || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5184 mg->mg_obj = SvREFCNT_inc_simple(obj);
5185 mg->mg_flags |= MGf_REFCOUNTED;
5188 /* Normal self-ties simply pass a null object, and instead of
5189 using mg_obj directly, use the SvTIED_obj macro to produce a
5190 new RV as needed. For glob "self-ties", we are tieing the PVIO
5191 with an RV obj pointing to the glob containing the PVIO. In
5192 this case, to avoid a reference loop, we need to weaken the
5196 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5197 obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5203 mg->mg_len = namlen;
5206 mg->mg_ptr = savepvn(name, namlen);
5207 else if (namlen == HEf_SVKEY) {
5208 /* Yes, this is casting away const. This is only for the case of
5209 HEf_SVKEY. I think we need to document this aberation of the
5210 constness of the API, rather than making name non-const, as
5211 that change propagating outwards a long way. */
5212 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5214 mg->mg_ptr = (char *) name;
5216 mg->mg_virtual = (MGVTBL *) vtable;
5220 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5225 =for apidoc sv_magic
5227 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5228 then adds a new magic item of type C<how> to the head of the magic list.
5230 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5231 handling of the C<name> and C<namlen> arguments.
5233 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5234 to add more than one instance of the same 'how'.
5240 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
5241 const char *const name, const I32 namlen)
5244 const MGVTBL *vtable;
5247 PERL_ARGS_ASSERT_SV_MAGIC;
5249 #ifdef PERL_OLD_COPY_ON_WRITE
5251 sv_force_normal_flags(sv, 0);
5253 if (SvREADONLY(sv)) {
5255 /* its okay to attach magic to shared strings; the subsequent
5256 * upgrade to PVMG will unshare the string */
5257 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
5260 && how != PERL_MAGIC_regex_global
5261 && how != PERL_MAGIC_bm
5262 && how != PERL_MAGIC_fm
5263 && how != PERL_MAGIC_sv
5264 && how != PERL_MAGIC_backref
5267 Perl_croak_no_modify(aTHX);
5270 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5271 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5272 /* sv_magic() refuses to add a magic of the same 'how' as an
5275 if (how == PERL_MAGIC_taint) {
5277 /* Any scalar which already had taint magic on which someone
5278 (erroneously?) did SvIOK_on() or similar will now be
5279 incorrectly sporting public "OK" flags. */
5280 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5288 vtable = &PL_vtbl_sv;
5290 case PERL_MAGIC_overload:
5291 vtable = &PL_vtbl_amagic;
5293 case PERL_MAGIC_overload_elem:
5294 vtable = &PL_vtbl_amagicelem;
5296 case PERL_MAGIC_overload_table:
5297 vtable = &PL_vtbl_ovrld;
5300 vtable = &PL_vtbl_bm;
5302 case PERL_MAGIC_regdata:
5303 vtable = &PL_vtbl_regdata;
5305 case PERL_MAGIC_regdatum:
5306 vtable = &PL_vtbl_regdatum;
5308 case PERL_MAGIC_env:
5309 vtable = &PL_vtbl_env;
5312 vtable = &PL_vtbl_fm;
5314 case PERL_MAGIC_envelem:
5315 vtable = &PL_vtbl_envelem;
5317 case PERL_MAGIC_regex_global:
5318 vtable = &PL_vtbl_mglob;
5320 case PERL_MAGIC_isa:
5321 vtable = &PL_vtbl_isa;
5323 case PERL_MAGIC_isaelem:
5324 vtable = &PL_vtbl_isaelem;
5326 case PERL_MAGIC_nkeys:
5327 vtable = &PL_vtbl_nkeys;
5329 case PERL_MAGIC_dbfile:
5332 case PERL_MAGIC_dbline:
5333 vtable = &PL_vtbl_dbline;
5335 #ifdef USE_LOCALE_COLLATE
5336 case PERL_MAGIC_collxfrm:
5337 vtable = &PL_vtbl_collxfrm;
5339 #endif /* USE_LOCALE_COLLATE */
5340 case PERL_MAGIC_tied:
5341 vtable = &PL_vtbl_pack;
5343 case PERL_MAGIC_tiedelem:
5344 case PERL_MAGIC_tiedscalar:
5345 vtable = &PL_vtbl_packelem;
5348 vtable = &PL_vtbl_regexp;
5350 case PERL_MAGIC_sig:
5351 vtable = &PL_vtbl_sig;
5353 case PERL_MAGIC_sigelem:
5354 vtable = &PL_vtbl_sigelem;
5356 case PERL_MAGIC_taint:
5357 vtable = &PL_vtbl_taint;
5359 case PERL_MAGIC_uvar:
5360 vtable = &PL_vtbl_uvar;
5362 case PERL_MAGIC_vec:
5363 vtable = &PL_vtbl_vec;
5365 case PERL_MAGIC_arylen_p:
5366 case PERL_MAGIC_rhash:
5367 case PERL_MAGIC_symtab:
5368 case PERL_MAGIC_vstring:
5369 case PERL_MAGIC_checkcall:
5372 case PERL_MAGIC_utf8:
5373 vtable = &PL_vtbl_utf8;
5375 case PERL_MAGIC_substr:
5376 vtable = &PL_vtbl_substr;
5378 case PERL_MAGIC_defelem:
5379 vtable = &PL_vtbl_defelem;
5381 case PERL_MAGIC_arylen:
5382 vtable = &PL_vtbl_arylen;
5384 case PERL_MAGIC_pos:
5385 vtable = &PL_vtbl_pos;
5387 case PERL_MAGIC_backref:
5388 vtable = &PL_vtbl_backref;
5390 case PERL_MAGIC_hintselem:
5391 vtable = &PL_vtbl_hintselem;
5393 case PERL_MAGIC_hints:
5394 vtable = &PL_vtbl_hints;
5396 case PERL_MAGIC_ext:
5397 /* Reserved for use by extensions not perl internals. */
5398 /* Useful for attaching extension internal data to perl vars. */
5399 /* Note that multiple extensions may clash if magical scalars */
5400 /* etc holding private data from one are passed to another. */
5404 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5407 /* Rest of work is done else where */
5408 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5411 case PERL_MAGIC_taint:
5414 case PERL_MAGIC_ext:
5415 case PERL_MAGIC_dbfile:
5422 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
5429 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5431 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5432 for (mg = *mgp; mg; mg = *mgp) {
5433 const MGVTBL* const virt = mg->mg_virtual;
5434 if (mg->mg_type == type && (!flags || virt == vtbl)) {
5435 *mgp = mg->mg_moremagic;
5436 if (virt && virt->svt_free)
5437 virt->svt_free(aTHX_ sv, mg);
5438 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5440 Safefree(mg->mg_ptr);
5441 else if (mg->mg_len == HEf_SVKEY)
5442 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5443 else if (mg->mg_type == PERL_MAGIC_utf8)
5444 Safefree(mg->mg_ptr);
5446 if (mg->mg_flags & MGf_REFCOUNTED)
5447 SvREFCNT_dec(mg->mg_obj);
5451 mgp = &mg->mg_moremagic;
5454 if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
5455 mg_magical(sv); /* else fix the flags now */
5459 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5465 =for apidoc sv_unmagic
5467 Removes all magic of type C<type> from an SV.
5473 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5475 PERL_ARGS_ASSERT_SV_UNMAGIC;
5476 return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5480 =for apidoc sv_unmagicext
5482 Removes all magic of type C<type> with the specified C<vtbl> from an SV.
5488 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
5490 PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5491 return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5495 =for apidoc sv_rvweaken
5497 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5498 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5499 push a back-reference to this RV onto the array of backreferences
5500 associated with that magic. If the RV is magical, set magic will be
5501 called after the RV is cleared.
5507 Perl_sv_rvweaken(pTHX_ SV *const sv)
5511 PERL_ARGS_ASSERT_SV_RVWEAKEN;
5513 if (!SvOK(sv)) /* let undefs pass */
5516 Perl_croak(aTHX_ "Can't weaken a nonreference");
5517 else if (SvWEAKREF(sv)) {
5518 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5522 Perl_sv_add_backref(aTHX_ tsv, sv);
5528 /* Give tsv backref magic if it hasn't already got it, then push a
5529 * back-reference to sv onto the array associated with the backref magic.
5531 * As an optimisation, if there's only one backref and it's not an AV,
5532 * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5533 * allocate an AV. (Whether the slot holds an AV tells us whether this is
5536 * If an HV's backref is stored in magic, it is moved back to HvAUX.
5539 /* A discussion about the backreferences array and its refcount:
5541 * The AV holding the backreferences is pointed to either as the mg_obj of
5542 * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
5543 * structure, from the xhv_backreferences field. (A HV without hv_aux will
5544 * have the standard magic instead.) The array is created with a refcount
5545 * of 2. This means that if during global destruction the array gets
5546 * picked on before its parent to have its refcount decremented by the
5547 * random zapper, it won't actually be freed, meaning it's still there for
5548 * when its parent gets freed.
5550 * When the parent SV is freed, the extra ref is killed by
5551 * Perl_sv_kill_backrefs. The other ref is killed, in the case of magic,
5552 * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5554 * When a single backref SV is stored directly, it is not reference
5559 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5566 PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5568 /* find slot to store array or singleton backref */
5570 if (SvTYPE(tsv) == SVt_PVHV) {
5571 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5574 if ((mg = mg_find(tsv, PERL_MAGIC_backref))) {
5575 /* Aha. They've got it stowed in magic instead.
5576 * Move it back to xhv_backreferences */
5578 /* Stop mg_free decreasing the reference count. */
5580 /* Stop mg_free even calling the destructor, given that
5581 there's no AV to free up. */
5583 sv_unmagic(tsv, PERL_MAGIC_backref);
5589 (SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
5591 sv_magic(tsv, NULL, PERL_MAGIC_backref, NULL, 0);
5592 mg = mg_find(tsv, PERL_MAGIC_backref);
5594 svp = &(mg->mg_obj);
5597 /* create or retrieve the array */
5599 if ( (!*svp && SvTYPE(sv) == SVt_PVAV)
5600 || (*svp && SvTYPE(*svp) != SVt_PVAV)
5605 SvREFCNT_inc_simple_void(av);
5606 /* av now has a refcnt of 2; see discussion above */
5608 /* move single existing backref to the array */
5610 AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5614 mg->mg_flags |= MGf_REFCOUNTED;
5617 av = MUTABLE_AV(*svp);
5620 /* optimisation: store single backref directly in HvAUX or mg_obj */
5624 /* push new backref */
5625 assert(SvTYPE(av) == SVt_PVAV);
5626 if (AvFILLp(av) >= AvMAX(av)) {
5627 av_extend(av, AvFILLp(av)+1);
5629 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5632 /* delete a back-reference to ourselves from the backref magic associated
5633 * with the SV we point to.
5637 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5642 PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5644 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5645 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5647 if (!svp || !*svp) {
5649 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5650 svp = mg ? &(mg->mg_obj) : NULL;
5654 Perl_croak(aTHX_ "panic: del_backref");
5656 if (SvTYPE(*svp) == SVt_PVAV) {
5660 AV * const av = (AV*)*svp;
5662 assert(!SvIS_FREED(av));
5666 /* for an SV with N weak references to it, if all those
5667 * weak refs are deleted, then sv_del_backref will be called
5668 * N times and O(N^2) compares will be done within the backref
5669 * array. To ameliorate this potential slowness, we:
5670 * 1) make sure this code is as tight as possible;
5671 * 2) when looking for SV, look for it at both the head and tail of the
5672 * array first before searching the rest, since some create/destroy
5673 * patterns will cause the backrefs to be freed in order.
5680 SV **p = &svp[fill];
5681 SV *const topsv = *p;
5688 /* We weren't the last entry.
5689 An unordered list has this property that you
5690 can take the last element off the end to fill
5691 the hole, and it's still an unordered list :-)
5697 break; /* should only be one */
5704 AvFILLp(av) = fill-1;
5707 /* optimisation: only a single backref, stored directly */
5709 Perl_croak(aTHX_ "panic: del_backref");
5716 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5722 PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5727 /* after multiple passes through Perl_sv_clean_all() for a thinngy
5728 * that has badly leaked, the backref array may have gotten freed,
5729 * since we only protect it against 1 round of cleanup */
5730 if (SvIS_FREED(av)) {
5731 if (PL_in_clean_all) /* All is fair */
5734 "panic: magic_killbackrefs (freed backref AV/SV)");
5738 is_array = (SvTYPE(av) == SVt_PVAV);
5740 assert(!SvIS_FREED(av));
5743 last = svp + AvFILLp(av);
5746 /* optimisation: only a single backref, stored directly */
5752 while (svp <= last) {
5754 SV *const referrer = *svp;
5755 if (SvWEAKREF(referrer)) {
5756 /* XXX Should we check that it hasn't changed? */
5757 assert(SvROK(referrer));
5758 SvRV_set(referrer, 0);
5760 SvWEAKREF_off(referrer);
5761 SvSETMAGIC(referrer);
5762 } else if (SvTYPE(referrer) == SVt_PVGV ||
5763 SvTYPE(referrer) == SVt_PVLV) {
5764 assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
5765 /* You lookin' at me? */
5766 assert(GvSTASH(referrer));
5767 assert(GvSTASH(referrer) == (const HV *)sv);
5768 GvSTASH(referrer) = 0;
5769 } else if (SvTYPE(referrer) == SVt_PVCV ||
5770 SvTYPE(referrer) == SVt_PVFM) {
5771 if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
5772 /* You lookin' at me? */
5773 assert(CvSTASH(referrer));
5774 assert(CvSTASH(referrer) == (const HV *)sv);
5775 SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
5778 assert(SvTYPE(sv) == SVt_PVGV);
5779 /* You lookin' at me? */
5780 assert(CvGV(referrer));
5781 assert(CvGV(referrer) == (const GV *)sv);
5782 anonymise_cv_maybe(MUTABLE_GV(sv),
5783 MUTABLE_CV(referrer));
5788 "panic: magic_killbackrefs (flags=%"UVxf")",
5789 (UV)SvFLAGS(referrer));
5800 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5806 =for apidoc sv_insert
5808 Inserts a string at the specified offset/length within the SV. Similar to
5809 the Perl substr() function. Handles get magic.
5811 =for apidoc sv_insert_flags
5813 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5819 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5824 register char *midend;
5825 register char *bigend;
5829 PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5832 Perl_croak(aTHX_ "Can't modify non-existent substring");
5833 SvPV_force_flags(bigstr, curlen, flags);
5834 (void)SvPOK_only_UTF8(bigstr);
5835 if (offset + len > curlen) {
5836 SvGROW(bigstr, offset+len+1);
5837 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5838 SvCUR_set(bigstr, offset+len);
5842 i = littlelen - len;
5843 if (i > 0) { /* string might grow */
5844 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5845 mid = big + offset + len;
5846 midend = bigend = big + SvCUR(bigstr);
5849 while (midend > mid) /* shove everything down */
5850 *--bigend = *--midend;
5851 Move(little,big+offset,littlelen,char);
5852 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5857 Move(little,SvPVX(bigstr)+offset,len,char);
5862 big = SvPVX(bigstr);
5865 bigend = big + SvCUR(bigstr);
5867 if (midend > bigend)
5868 Perl_croak(aTHX_ "panic: sv_insert");
5870 if (mid - big > bigend - midend) { /* faster to shorten from end */
5872 Move(little, mid, littlelen,char);
5875 i = bigend - midend;
5877 Move(midend, mid, i,char);
5881 SvCUR_set(bigstr, mid - big);
5883 else if ((i = mid - big)) { /* faster from front */
5884 midend -= littlelen;
5886 Move(big, midend - i, i, char);
5887 sv_chop(bigstr,midend-i);
5889 Move(little, mid, littlelen,char);
5891 else if (littlelen) {
5892 midend -= littlelen;
5893 sv_chop(bigstr,midend);
5894 Move(little,midend,littlelen,char);
5897 sv_chop(bigstr,midend);
5903 =for apidoc sv_replace
5905 Make the first argument a copy of the second, then delete the original.
5906 The target SV physically takes over ownership of the body of the source SV
5907 and inherits its flags; however, the target keeps any magic it owns,
5908 and any magic in the source is discarded.
5909 Note that this is a rather specialist SV copying operation; most of the
5910 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5916 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5919 const U32 refcnt = SvREFCNT(sv);
5921 PERL_ARGS_ASSERT_SV_REPLACE;
5923 SV_CHECK_THINKFIRST_COW_DROP(sv);
5924 if (SvREFCNT(nsv) != 1) {
5925 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
5926 " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
5928 if (SvMAGICAL(sv)) {
5932 sv_upgrade(nsv, SVt_PVMG);
5933 SvMAGIC_set(nsv, SvMAGIC(sv));
5934 SvFLAGS(nsv) |= SvMAGICAL(sv);
5936 SvMAGIC_set(sv, NULL);
5940 assert(!SvREFCNT(sv));
5941 #ifdef DEBUG_LEAKING_SCALARS
5942 sv->sv_flags = nsv->sv_flags;
5943 sv->sv_any = nsv->sv_any;
5944 sv->sv_refcnt = nsv->sv_refcnt;
5945 sv->sv_u = nsv->sv_u;
5947 StructCopy(nsv,sv,SV);
5949 if(SvTYPE(sv) == SVt_IV) {
5951 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5955 #ifdef PERL_OLD_COPY_ON_WRITE
5956 if (SvIsCOW_normal(nsv)) {
5957 /* We need to follow the pointers around the loop to make the
5958 previous SV point to sv, rather than nsv. */
5961 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5964 assert(SvPVX_const(current) == SvPVX_const(nsv));
5966 /* Make the SV before us point to the SV after us. */
5968 PerlIO_printf(Perl_debug_log, "previous is\n");
5970 PerlIO_printf(Perl_debug_log,
5971 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5972 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5974 SV_COW_NEXT_SV_SET(current, sv);
5977 SvREFCNT(sv) = refcnt;
5978 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5983 /* We're about to free a GV which has a CV that refers back to us.
5984 * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
5988 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
5994 PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
5997 assert(SvREFCNT(gv) == 0);
5998 assert(isGV(gv) && isGV_with_GP(gv));
6000 assert(!CvANON(cv));
6001 assert(CvGV(cv) == gv);
6003 /* will the CV shortly be freed by gp_free() ? */
6004 if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
6005 SvANY(cv)->xcv_gv = NULL;
6009 /* if not, anonymise: */
6010 stash = GvSTASH(gv) && HvNAME(GvSTASH(gv))
6011 ? HvENAME(GvSTASH(gv)) : NULL;
6012 gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
6013 stash ? stash : "__ANON__");
6014 anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
6015 SvREFCNT_dec(gvname);
6019 SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
6024 =for apidoc sv_clear
6026 Clear an SV: call any destructors, free up any memory used by the body,
6027 and free the body itself. The SV's head is I<not> freed, although
6028 its type is set to all 1's so that it won't inadvertently be assumed
6029 to be live during global destruction etc.
6030 This function should only be called when REFCNT is zero. Most of the time
6031 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
6038 Perl_sv_clear(pTHX_ SV *const orig_sv)
6043 const struct body_details *sv_type_details;
6046 register SV *sv = orig_sv;
6048 PERL_ARGS_ASSERT_SV_CLEAR;
6050 /* within this loop, sv is the SV currently being freed, and
6051 * iter_sv is the most recent AV or whatever that's being iterated
6052 * over to provide more SVs */
6058 assert(SvREFCNT(sv) == 0);
6059 assert(SvTYPE(sv) != SVTYPEMASK);
6061 if (type <= SVt_IV) {
6062 /* See the comment in sv.h about the collusion between this
6063 * early return and the overloading of the NULL slots in the
6067 SvFLAGS(sv) &= SVf_BREAK;
6068 SvFLAGS(sv) |= SVTYPEMASK;
6073 if (!curse(sv, 1)) goto get_next_sv;
6075 if (type >= SVt_PVMG) {
6076 /* Free back-references before magic, in case the magic calls
6077 * Perl code that has weak references to sv. */
6078 if (type == SVt_PVHV)
6079 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6080 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
6081 SvREFCNT_dec(SvOURSTASH(sv));
6082 } else if (SvMAGIC(sv)) {
6083 /* Free back-references before other types of magic. */
6084 sv_unmagic(sv, PERL_MAGIC_backref);
6087 if (type == SVt_PVMG && SvPAD_TYPED(sv))
6088 SvREFCNT_dec(SvSTASH(sv));
6091 /* case SVt_BIND: */
6094 IoIFP(sv) != PerlIO_stdin() &&
6095 IoIFP(sv) != PerlIO_stdout() &&
6096 IoIFP(sv) != PerlIO_stderr() &&
6097 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6099 io_close(MUTABLE_IO(sv), FALSE);
6101 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6102 PerlDir_close(IoDIRP(sv));
6103 IoDIRP(sv) = (DIR*)NULL;
6104 Safefree(IoTOP_NAME(sv));
6105 Safefree(IoFMT_NAME(sv));
6106 Safefree(IoBOTTOM_NAME(sv));
6109 /* FIXME for plugins */
6110 pregfree2((REGEXP*) sv);
6114 cv_undef(MUTABLE_CV(sv));
6115 /* If we're in a stash, we don't own a reference to it.
6116 * However it does have a back reference to us, which needs to
6118 if ((stash = CvSTASH(sv)))
6119 sv_del_backref(MUTABLE_SV(stash), sv);
6122 if (PL_last_swash_hv == (const HV *)sv) {
6123 PL_last_swash_hv = NULL;
6125 Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6129 AV* av = MUTABLE_AV(sv);
6130 if (PL_comppad == av) {
6134 if (AvREAL(av) && AvFILLp(av) > -1) {
6135 next_sv = AvARRAY(av)[AvFILLp(av)--];
6136 /* save old iter_sv in top-most slot of AV,
6137 * and pray that it doesn't get wiped in the meantime */
6138 AvARRAY(av)[AvMAX(av)] = iter_sv;
6140 goto get_next_sv; /* process this new sv */
6142 Safefree(AvALLOC(av));
6147 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
6148 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
6149 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
6150 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
6152 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
6153 SvREFCNT_dec(LvTARG(sv));
6155 if (isGV_with_GP(sv)) {
6156 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
6157 && HvENAME_get(stash))
6158 mro_method_changed_in(stash);
6159 gp_free(MUTABLE_GV(sv));
6161 unshare_hek(GvNAME_HEK(sv));
6162 /* If we're in a stash, we don't own a reference to it.
6163 * However it does have a back reference to us, which
6164 * needs to be cleared. */
6165 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
6166 sv_del_backref(MUTABLE_SV(stash), sv);
6168 /* FIXME. There are probably more unreferenced pointers to SVs
6169 * in the interpreter struct that we should check and tidy in
6170 * a similar fashion to this: */
6171 if ((const GV *)sv == PL_last_in_gv)
6172 PL_last_in_gv = NULL;
6178 /* Don't bother with SvOOK_off(sv); as we're only going to
6182 SvOOK_offset(sv, offset);
6183 SvPV_set(sv, SvPVX_mutable(sv) - offset);
6184 /* Don't even bother with turning off the OOK flag. */
6189 SV * const target = SvRV(sv);
6191 sv_del_backref(target, sv);
6196 #ifdef PERL_OLD_COPY_ON_WRITE
6197 else if (SvPVX_const(sv)
6198 && !(SvTYPE(sv) == SVt_PVIO
6199 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6203 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6207 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
6209 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6213 } else if (SvLEN(sv)) {
6214 Safefree(SvPVX_const(sv));
6218 else if (SvPVX_const(sv) && SvLEN(sv)
6219 && !(SvTYPE(sv) == SVt_PVIO
6220 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6221 Safefree(SvPVX_mutable(sv));
6222 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
6223 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6234 SvFLAGS(sv) &= SVf_BREAK;
6235 SvFLAGS(sv) |= SVTYPEMASK;
6237 sv_type_details = bodies_by_type + type;
6238 if (sv_type_details->arena) {
6239 del_body(((char *)SvANY(sv) + sv_type_details->offset),
6240 &PL_body_roots[type]);
6242 else if (sv_type_details->body_size) {
6243 safefree(SvANY(sv));
6247 /* caller is responsible for freeing the head of the original sv */
6248 if (sv != orig_sv && !SvREFCNT(sv))
6251 /* grab and free next sv, if any */
6259 else if (!iter_sv) {
6261 } else if (SvTYPE(iter_sv) == SVt_PVAV) {
6262 AV *const av = (AV*)iter_sv;
6263 if (AvFILLp(av) > -1) {
6264 sv = AvARRAY(av)[AvFILLp(av)--];
6266 else { /* no more elements of current AV to free */
6269 /* restore previous value, squirrelled away */
6270 iter_sv = AvARRAY(av)[AvMAX(av)];
6271 Safefree(AvALLOC(av));
6276 /* unrolled SvREFCNT_dec and sv_free2 follows: */
6280 if (!SvREFCNT(sv)) {
6284 if (--(SvREFCNT(sv)))
6288 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6289 "Attempt to free temp prematurely: SV 0x%"UVxf
6290 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6294 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6295 /* make sure SvREFCNT(sv)==0 happens very seldom */
6296 SvREFCNT(sv) = (~(U32)0)/2;
6305 /* This routine curses the sv itself, not the object referenced by sv. So
6306 sv does not have to be ROK. */
6309 S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
6312 PERL_ARGS_ASSERT_CURSE;
6313 assert(SvOBJECT(sv));
6315 if (PL_defstash && /* Still have a symbol table? */
6322 stash = SvSTASH(sv);
6323 destructor = StashHANDLER(stash,DESTROY);
6325 /* A constant subroutine can have no side effects, so
6326 don't bother calling it. */
6327 && !CvCONST(destructor)
6328 /* Don't bother calling an empty destructor */
6329 && (CvISXSUB(destructor)
6330 || (CvSTART(destructor)
6331 && (CvSTART(destructor)->op_next->op_type
6334 SV* const tmpref = newRV(sv);
6335 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
6337 PUSHSTACKi(PERLSI_DESTROY);
6342 call_sv(MUTABLE_SV(destructor),
6343 G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
6347 if(SvREFCNT(tmpref) < 2) {
6348 /* tmpref is not kept alive! */
6350 SvRV_set(tmpref, NULL);
6353 SvREFCNT_dec(tmpref);
6355 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
6358 if (check_refcnt && SvREFCNT(sv)) {
6359 if (PL_in_clean_objs)
6361 "DESTROY created new reference to dead object '%s'",
6363 /* DESTROY gave object new lease on life */
6369 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
6370 SvOBJECT_off(sv); /* Curse the object. */
6371 if (SvTYPE(sv) != SVt_PVIO)
6372 --PL_sv_objcount;/* XXX Might want something more general */
6378 =for apidoc sv_newref
6380 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6387 Perl_sv_newref(pTHX_ SV *const sv)
6389 PERL_UNUSED_CONTEXT;
6398 Decrement an SV's reference count, and if it drops to zero, call
6399 C<sv_clear> to invoke destructors and free up any memory used by
6400 the body; finally, deallocate the SV's head itself.
6401 Normally called via a wrapper macro C<SvREFCNT_dec>.
6407 Perl_sv_free(pTHX_ SV *const sv)
6412 if (SvREFCNT(sv) == 0) {
6413 if (SvFLAGS(sv) & SVf_BREAK)
6414 /* this SV's refcnt has been artificially decremented to
6415 * trigger cleanup */
6417 if (PL_in_clean_all) /* All is fair */
6419 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6420 /* make sure SvREFCNT(sv)==0 happens very seldom */
6421 SvREFCNT(sv) = (~(U32)0)/2;
6424 if (ckWARN_d(WARN_INTERNAL)) {
6425 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
6426 Perl_dump_sv_child(aTHX_ sv);
6428 #ifdef DEBUG_LEAKING_SCALARS
6431 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6432 if (PL_warnhook == PERL_WARNHOOK_FATAL
6433 || ckDEAD(packWARN(WARN_INTERNAL))) {
6434 /* Don't let Perl_warner cause us to escape our fate: */
6438 /* This may not return: */
6439 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6440 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6441 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6444 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6449 if (--(SvREFCNT(sv)) > 0)
6451 Perl_sv_free2(aTHX_ sv);
6455 Perl_sv_free2(pTHX_ SV *const sv)
6459 PERL_ARGS_ASSERT_SV_FREE2;
6463 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6464 "Attempt to free temp prematurely: SV 0x%"UVxf
6465 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6469 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6470 /* make sure SvREFCNT(sv)==0 happens very seldom */
6471 SvREFCNT(sv) = (~(U32)0)/2;
6482 Returns the length of the string in the SV. Handles magic and type
6483 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6489 Perl_sv_len(pTHX_ register SV *const sv)
6497 len = mg_length(sv);
6499 (void)SvPV_const(sv, len);
6504 =for apidoc sv_len_utf8
6506 Returns the number of characters in the string in an SV, counting wide
6507 UTF-8 bytes as a single character. Handles magic and type coercion.
6513 * The length is cached in PERL_MAGIC_utf8, in the mg_len field. Also the
6514 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6515 * (Note that the mg_len is not the length of the mg_ptr field.
6516 * This allows the cache to store the character length of the string without
6517 * needing to malloc() extra storage to attach to the mg_ptr.)
6522 Perl_sv_len_utf8(pTHX_ register SV *const sv)
6528 return mg_length(sv);
6532 const U8 *s = (U8*)SvPV_const(sv, len);
6536 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6538 if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
6539 if (mg->mg_len != -1)
6542 /* We can use the offset cache for a headstart.
6543 The longer value is stored in the first pair. */
6544 STRLEN *cache = (STRLEN *) mg->mg_ptr;
6546 ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
6550 if (PL_utf8cache < 0) {
6551 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6552 assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
6556 ulen = Perl_utf8_length(aTHX_ s, s + len);
6557 utf8_mg_len_cache_update(sv, &mg, ulen);
6561 return Perl_utf8_length(aTHX_ s, s + len);
6565 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6568 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6569 STRLEN *const uoffset_p, bool *const at_end)
6571 const U8 *s = start;
6572 STRLEN uoffset = *uoffset_p;
6574 PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6576 while (s < send && uoffset) {
6583 else if (s > send) {
6585 /* This is the existing behaviour. Possibly it should be a croak, as
6586 it's actually a bounds error */
6589 *uoffset_p -= uoffset;
6593 /* Given the length of the string in both bytes and UTF-8 characters, decide
6594 whether to walk forwards or backwards to find the byte corresponding to
6595 the passed in UTF-8 offset. */
6597 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6598 STRLEN uoffset, const STRLEN uend)
6600 STRLEN backw = uend - uoffset;
6602 PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6604 if (uoffset < 2 * backw) {
6605 /* The assumption is that going forwards is twice the speed of going
6606 forward (that's where the 2 * backw comes from).
6607 (The real figure of course depends on the UTF-8 data.) */
6608 const U8 *s = start;
6610 while (s < send && uoffset--)
6620 while (UTF8_IS_CONTINUATION(*send))
6623 return send - start;
6626 /* For the string representation of the given scalar, find the byte
6627 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
6628 give another position in the string, *before* the sought offset, which
6629 (which is always true, as 0, 0 is a valid pair of positions), which should
6630 help reduce the amount of linear searching.
6631 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6632 will be used to reduce the amount of linear searching. The cache will be
6633 created if necessary, and the found value offered to it for update. */
6635 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6636 const U8 *const send, STRLEN uoffset,
6637 STRLEN uoffset0, STRLEN boffset0)
6639 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
6641 bool at_end = FALSE;
6643 PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6645 assert (uoffset >= uoffset0);
6652 && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
6653 (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
6654 if ((*mgp)->mg_ptr) {
6655 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6656 if (cache[0] == uoffset) {
6657 /* An exact match. */
6660 if (cache[2] == uoffset) {
6661 /* An exact match. */
6665 if (cache[0] < uoffset) {
6666 /* The cache already knows part of the way. */
6667 if (cache[0] > uoffset0) {
6668 /* The cache knows more than the passed in pair */
6669 uoffset0 = cache[0];
6670 boffset0 = cache[1];
6672 if ((*mgp)->mg_len != -1) {
6673 /* And we know the end too. */
6675 + sv_pos_u2b_midway(start + boffset0, send,
6677 (*mgp)->mg_len - uoffset0);
6679 uoffset -= uoffset0;
6681 + sv_pos_u2b_forwards(start + boffset0,
6682 send, &uoffset, &at_end);
6683 uoffset += uoffset0;
6686 else if (cache[2] < uoffset) {
6687 /* We're between the two cache entries. */
6688 if (cache[2] > uoffset0) {
6689 /* and the cache knows more than the passed in pair */
6690 uoffset0 = cache[2];
6691 boffset0 = cache[3];
6695 + sv_pos_u2b_midway(start + boffset0,
6698 cache[0] - uoffset0);
6701 + sv_pos_u2b_midway(start + boffset0,
6704 cache[2] - uoffset0);
6708 else if ((*mgp)->mg_len != -1) {
6709 /* If we can take advantage of a passed in offset, do so. */
6710 /* In fact, offset0 is either 0, or less than offset, so don't
6711 need to worry about the other possibility. */
6713 + sv_pos_u2b_midway(start + boffset0, send,
6715 (*mgp)->mg_len - uoffset0);
6720 if (!found || PL_utf8cache < 0) {
6721 STRLEN real_boffset;
6722 uoffset -= uoffset0;
6723 real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6724 send, &uoffset, &at_end);
6725 uoffset += uoffset0;
6727 if (found && PL_utf8cache < 0)
6728 assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
6730 boffset = real_boffset;
6735 utf8_mg_len_cache_update(sv, mgp, uoffset);
6737 utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6744 =for apidoc sv_pos_u2b_flags
6746 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6747 the start of the string, to a count of the equivalent number of bytes; if
6748 lenp is non-zero, it does the same to lenp, but this time starting from
6749 the offset, rather than from the start of the string. Handles type coercion.
6750 I<flags> is passed to C<SvPV_flags>, and usually should be
6751 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
6757 * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
6758 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6759 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6764 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
6771 PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
6773 start = (U8*)SvPV_flags(sv, len, flags);
6775 const U8 * const send = start + len;
6777 boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
6780 && *lenp /* don't bother doing work for 0, as its bytes equivalent
6781 is 0, and *lenp is already set to that. */) {
6782 /* Convert the relative offset to absolute. */
6783 const STRLEN uoffset2 = uoffset + *lenp;
6784 const STRLEN boffset2
6785 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6786 uoffset, boffset) - boffset;
6800 =for apidoc sv_pos_u2b
6802 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6803 the start of the string, to a count of the equivalent number of bytes; if
6804 lenp is non-zero, it does the same to lenp, but this time starting from
6805 the offset, rather than from the start of the string. Handles magic and
6808 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
6815 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6816 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6817 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6821 /* This function is subject to size and sign problems */
6824 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6826 PERL_ARGS_ASSERT_SV_POS_U2B;
6829 STRLEN ulen = (STRLEN)*lenp;
6830 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
6831 SV_GMAGIC|SV_CONST_RETURN);
6834 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
6835 SV_GMAGIC|SV_CONST_RETURN);
6840 S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
6843 PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
6847 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6848 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6849 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
6853 (*mgp)->mg_len = ulen;
6854 /* For now, treat "overflowed" as "still unknown". See RT #72924. */
6855 if (ulen != (STRLEN) (*mgp)->mg_len)
6856 (*mgp)->mg_len = -1;
6859 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6860 byte length pairing. The (byte) length of the total SV is passed in too,
6861 as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6862 may not have updated SvCUR, so we can't rely on reading it directly.
6864 The proffered utf8/byte length pairing isn't used if the cache already has
6865 two pairs, and swapping either for the proffered pair would increase the
6866 RMS of the intervals between known byte offsets.
6868 The cache itself consists of 4 STRLEN values
6869 0: larger UTF-8 offset
6870 1: corresponding byte offset
6871 2: smaller UTF-8 offset
6872 3: corresponding byte offset
6874 Unused cache pairs have the value 0, 0.
6875 Keeping the cache "backwards" means that the invariant of
6876 cache[0] >= cache[2] is maintained even with empty slots, which means that
6877 the code that uses it doesn't need to worry if only 1 entry has actually
6878 been set to non-zero. It also makes the "position beyond the end of the
6879 cache" logic much simpler, as the first slot is always the one to start
6883 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6884 const STRLEN utf8, const STRLEN blen)
6888 PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6893 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6894 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6895 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6897 (*mgp)->mg_len = -1;
6901 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6902 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6903 (*mgp)->mg_ptr = (char *) cache;
6907 if (PL_utf8cache < 0 && SvPOKp(sv)) {
6908 /* SvPOKp() because it's possible that sv has string overloading, and
6909 therefore is a reference, hence SvPVX() is actually a pointer.
6910 This cures the (very real) symptoms of RT 69422, but I'm not actually
6911 sure whether we should even be caching the results of UTF-8
6912 operations on overloading, given that nothing stops overloading
6913 returning a different value every time it's called. */
6914 const U8 *start = (const U8 *) SvPVX_const(sv);
6915 const STRLEN realutf8 = utf8_length(start, start + byte);
6917 assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
6921 /* Cache is held with the later position first, to simplify the code
6922 that deals with unbounded ends. */
6924 ASSERT_UTF8_CACHE(cache);
6925 if (cache[1] == 0) {
6926 /* Cache is totally empty */
6929 } else if (cache[3] == 0) {
6930 if (byte > cache[1]) {
6931 /* New one is larger, so goes first. */
6932 cache[2] = cache[0];
6933 cache[3] = cache[1];
6941 #define THREEWAY_SQUARE(a,b,c,d) \
6942 ((float)((d) - (c))) * ((float)((d) - (c))) \
6943 + ((float)((c) - (b))) * ((float)((c) - (b))) \
6944 + ((float)((b) - (a))) * ((float)((b) - (a)))
6946 /* Cache has 2 slots in use, and we know three potential pairs.
6947 Keep the two that give the lowest RMS distance. Do the
6948 calculation in bytes simply because we always know the byte
6949 length. squareroot has the same ordering as the positive value,
6950 so don't bother with the actual square root. */
6951 const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6952 if (byte > cache[1]) {
6953 /* New position is after the existing pair of pairs. */
6954 const float keep_earlier
6955 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6956 const float keep_later
6957 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6959 if (keep_later < keep_earlier) {
6960 if (keep_later < existing) {
6961 cache[2] = cache[0];
6962 cache[3] = cache[1];
6968 if (keep_earlier < existing) {
6974 else if (byte > cache[3]) {
6975 /* New position is between the existing pair of pairs. */
6976 const float keep_earlier
6977 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6978 const float keep_later
6979 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6981 if (keep_later < keep_earlier) {
6982 if (keep_later < existing) {
6988 if (keep_earlier < existing) {
6995 /* New position is before the existing pair of pairs. */
6996 const float keep_earlier
6997 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6998 const float keep_later
6999 = THREEWAY_SQUARE(0, byte, cache[1], blen);
7001 if (keep_later < keep_earlier) {
7002 if (keep_later < existing) {
7008 if (keep_earlier < existing) {
7009 cache[0] = cache[2];
7010 cache[1] = cache[3];
7017 ASSERT_UTF8_CACHE(cache);
7020 /* We already know all of the way, now we may be able to walk back. The same
7021 assumption is made as in S_sv_pos_u2b_midway(), namely that walking
7022 backward is half the speed of walking forward. */
7024 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
7025 const U8 *end, STRLEN endu)
7027 const STRLEN forw = target - s;
7028 STRLEN backw = end - target;
7030 PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
7032 if (forw < 2 * backw) {
7033 return utf8_length(s, target);
7036 while (end > target) {
7038 while (UTF8_IS_CONTINUATION(*end)) {
7047 =for apidoc sv_pos_b2u
7049 Converts the value pointed to by offsetp from a count of bytes from the
7050 start of the string, to a count of the equivalent number of UTF-8 chars.
7051 Handles magic and type coercion.
7057 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
7058 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7063 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
7066 const STRLEN byte = *offsetp;
7067 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
7073 PERL_ARGS_ASSERT_SV_POS_B2U;
7078 s = (const U8*)SvPV_const(sv, blen);
7081 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
7087 && SvTYPE(sv) >= SVt_PVMG
7088 && (mg = mg_find(sv, PERL_MAGIC_utf8)))
7091 STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7092 if (cache[1] == byte) {
7093 /* An exact match. */
7094 *offsetp = cache[0];
7097 if (cache[3] == byte) {
7098 /* An exact match. */
7099 *offsetp = cache[2];
7103 if (cache[1] < byte) {
7104 /* We already know part of the way. */
7105 if (mg->mg_len != -1) {
7106 /* Actually, we know the end too. */
7108 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
7109 s + blen, mg->mg_len - cache[0]);
7111 len = cache[0] + utf8_length(s + cache[1], send);
7114 else if (cache[3] < byte) {
7115 /* We're between the two cached pairs, so we do the calculation
7116 offset by the byte/utf-8 positions for the earlier pair,
7117 then add the utf-8 characters from the string start to
7119 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
7120 s + cache[1], cache[0] - cache[2])
7124 else { /* cache[3] > byte */
7125 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
7129 ASSERT_UTF8_CACHE(cache);
7131 } else if (mg->mg_len != -1) {
7132 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
7136 if (!found || PL_utf8cache < 0) {
7137 const STRLEN real_len = utf8_length(s, send);
7139 if (found && PL_utf8cache < 0)
7140 assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
7147 utf8_mg_len_cache_update(sv, &mg, len);
7149 utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
7154 S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
7155 STRLEN real, SV *const sv)
7157 PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
7159 /* As this is debugging only code, save space by keeping this test here,
7160 rather than inlining it in all the callers. */
7161 if (from_cache == real)
7164 /* Need to turn the assertions off otherwise we may recurse infinitely
7165 while printing error messages. */
7166 SAVEI8(PL_utf8cache);
7168 Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
7169 func, (UV) from_cache, (UV) real, SVfARG(sv));
7175 Returns a boolean indicating whether the strings in the two SVs are
7176 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7177 coerce its args to strings if necessary.
7179 =for apidoc sv_eq_flags
7181 Returns a boolean indicating whether the strings in the two SVs are
7182 identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings
7183 if necessary. If the flags include SV_GMAGIC, it handles get-magic, too.
7189 Perl_sv_eq_flags(pTHX_ register SV *sv1, register SV *sv2, const U32 flags)
7198 SV* svrecode = NULL;
7205 /* if pv1 and pv2 are the same, second SvPV_const call may
7206 * invalidate pv1 (if we are handling magic), so we may need to
7208 if (sv1 == sv2 && flags & SV_GMAGIC
7209 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
7210 pv1 = SvPV_const(sv1, cur1);
7211 sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
7213 pv1 = SvPV_flags_const(sv1, cur1, flags);
7221 pv2 = SvPV_flags_const(sv2, cur2, flags);
7223 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7224 /* Differing utf8ness.
7225 * Do not UTF8size the comparands as a side-effect. */
7228 svrecode = newSVpvn(pv2, cur2);
7229 sv_recode_to_utf8(svrecode, PL_encoding);
7230 pv2 = SvPV_const(svrecode, cur2);
7233 svrecode = newSVpvn(pv1, cur1);
7234 sv_recode_to_utf8(svrecode, PL_encoding);
7235 pv1 = SvPV_const(svrecode, cur1);
7237 /* Now both are in UTF-8. */
7239 SvREFCNT_dec(svrecode);
7245 /* sv1 is the UTF-8 one */
7246 return bytes_cmp_utf8((const U8*)pv2, cur2,
7247 (const U8*)pv1, cur1) == 0;
7250 /* sv2 is the UTF-8 one */
7251 return bytes_cmp_utf8((const U8*)pv1, cur1,
7252 (const U8*)pv2, cur2) == 0;
7258 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
7260 SvREFCNT_dec(svrecode);
7270 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7271 string in C<sv1> is less than, equal to, or greater than the string in
7272 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7273 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
7275 =for apidoc sv_cmp_flags
7277 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7278 string in C<sv1> is less than, equal to, or greater than the string in
7279 C<sv2>. Is UTF-8 and 'use bytes' aware and will coerce its args to strings
7280 if necessary. If the flags include SV_GMAGIC, it handles get magic. See
7281 also C<sv_cmp_locale_flags>.
7287 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
7289 return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
7293 Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2,
7298 const char *pv1, *pv2;
7301 SV *svrecode = NULL;
7308 pv1 = SvPV_flags_const(sv1, cur1, flags);
7315 pv2 = SvPV_flags_const(sv2, cur2, flags);
7317 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7318 /* Differing utf8ness.
7319 * Do not UTF8size the comparands as a side-effect. */
7322 svrecode = newSVpvn(pv2, cur2);
7323 sv_recode_to_utf8(svrecode, PL_encoding);
7324 pv2 = SvPV_const(svrecode, cur2);
7327 const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2,
7328 (const U8*)pv1, cur1);
7329 return retval ? retval < 0 ? -1 : +1 : 0;
7334 svrecode = newSVpvn(pv1, cur1);
7335 sv_recode_to_utf8(svrecode, PL_encoding);
7336 pv1 = SvPV_const(svrecode, cur1);
7339 const int retval = bytes_cmp_utf8((const U8*)pv1, cur1,
7340 (const U8*)pv2, cur2);
7341 return retval ? retval < 0 ? -1 : +1 : 0;
7347 cmp = cur2 ? -1 : 0;
7351 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
7354 cmp = retval < 0 ? -1 : 1;
7355 } else if (cur1 == cur2) {
7358 cmp = cur1 < cur2 ? -1 : 1;
7362 SvREFCNT_dec(svrecode);
7370 =for apidoc sv_cmp_locale
7372 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7373 'use bytes' aware, handles get magic, and will coerce its args to strings
7374 if necessary. See also C<sv_cmp>.
7376 =for apidoc sv_cmp_locale_flags
7378 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7379 'use bytes' aware and will coerce its args to strings if necessary. If the
7380 flags contain SV_GMAGIC, it handles get magic. See also C<sv_cmp_flags>.
7386 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
7388 return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
7392 Perl_sv_cmp_locale_flags(pTHX_ register SV *const sv1, register SV *const sv2,
7396 #ifdef USE_LOCALE_COLLATE
7402 if (PL_collation_standard)
7406 pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
7408 pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
7410 if (!pv1 || !len1) {
7421 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
7424 return retval < 0 ? -1 : 1;
7427 * When the result of collation is equality, that doesn't mean
7428 * that there are no differences -- some locales exclude some
7429 * characters from consideration. So to avoid false equalities,
7430 * we use the raw string as a tiebreaker.
7436 #endif /* USE_LOCALE_COLLATE */
7438 return sv_cmp(sv1, sv2);
7442 #ifdef USE_LOCALE_COLLATE
7445 =for apidoc sv_collxfrm
7447 This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag. See
7448 C<sv_collxfrm_flags>.
7450 =for apidoc sv_collxfrm_flags
7452 Add Collate Transform magic to an SV if it doesn't already have it. If the
7453 flags contain SV_GMAGIC, it handles get-magic.
7455 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
7456 scalar data of the variable, but transformed to such a format that a normal
7457 memory comparison can be used to compare the data according to the locale
7464 Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
7469 PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
7471 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
7472 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
7478 Safefree(mg->mg_ptr);
7479 s = SvPV_flags_const(sv, len, flags);
7480 if ((xf = mem_collxfrm(s, len, &xlen))) {
7482 #ifdef PERL_OLD_COPY_ON_WRITE
7484 sv_force_normal_flags(sv, 0);
7486 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
7500 if (mg && mg->mg_ptr) {
7502 return mg->mg_ptr + sizeof(PL_collation_ix);
7510 #endif /* USE_LOCALE_COLLATE */
7513 S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7515 SV * const tsv = newSV(0);
7518 sv_gets(tsv, fp, 0);
7519 sv_utf8_upgrade_nomg(tsv);
7520 SvCUR_set(sv,append);
7523 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7527 S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7530 const U32 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7531 /* Grab the size of the record we're getting */
7532 char *const buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7539 /* VMS wants read instead of fread, because fread doesn't respect */
7540 /* RMS record boundaries. This is not necessarily a good thing to be */
7541 /* doing, but we've got no other real choice - except avoid stdio
7542 as implementation - perhaps write a :vms layer ?
7544 fd = PerlIO_fileno(fp);
7546 bytesread = PerlLIO_read(fd, buffer, recsize);
7548 else /* in-memory file from PerlIO::Scalar */
7551 bytesread = PerlIO_read(fp, buffer, recsize);
7556 SvCUR_set(sv, bytesread + append);
7557 buffer[bytesread] = '\0';
7558 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7564 Get a line from the filehandle and store it into the SV, optionally
7565 appending to the currently-stored string.
7571 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
7576 register STDCHAR rslast;
7577 register STDCHAR *bp;
7582 PERL_ARGS_ASSERT_SV_GETS;
7584 if (SvTHINKFIRST(sv))
7585 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
7586 /* XXX. If you make this PVIV, then copy on write can copy scalars read
7588 However, perlbench says it's slower, because the existing swipe code
7589 is faster than copy on write.
7590 Swings and roundabouts. */
7591 SvUPGRADE(sv, SVt_PV);
7596 if (PerlIO_isutf8(fp)) {
7598 sv_utf8_upgrade_nomg(sv);
7599 sv_pos_u2b(sv,&append,0);
7601 } else if (SvUTF8(sv)) {
7602 return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append);
7610 if (PerlIO_isutf8(fp))
7613 if (IN_PERL_COMPILETIME) {
7614 /* we always read code in line mode */
7618 else if (RsSNARF(PL_rs)) {
7619 /* If it is a regular disk file use size from stat() as estimate
7620 of amount we are going to read -- may result in mallocing
7621 more memory than we really need if the layers below reduce
7622 the size we read (e.g. CRLF or a gzip layer).
7625 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
7626 const Off_t offset = PerlIO_tell(fp);
7627 if (offset != (Off_t) -1 && st.st_size + append > offset) {
7628 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7634 else if (RsRECORD(PL_rs)) {
7635 return S_sv_gets_read_record(aTHX_ sv, fp, append);
7637 else if (RsPARA(PL_rs)) {
7643 /* Get $/ i.e. PL_rs into same encoding as stream wants */
7644 if (PerlIO_isutf8(fp)) {
7645 rsptr = SvPVutf8(PL_rs, rslen);
7648 if (SvUTF8(PL_rs)) {
7649 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7650 Perl_croak(aTHX_ "Wide character in $/");
7653 rsptr = SvPV_const(PL_rs, rslen);
7657 rslast = rslen ? rsptr[rslen - 1] : '\0';
7659 if (rspara) { /* have to do this both before and after */
7660 do { /* to make sure file boundaries work right */
7663 i = PerlIO_getc(fp);
7667 PerlIO_ungetc(fp,i);
7673 /* See if we know enough about I/O mechanism to cheat it ! */
7675 /* This used to be #ifdef test - it is made run-time test for ease
7676 of abstracting out stdio interface. One call should be cheap
7677 enough here - and may even be a macro allowing compile
7681 if (PerlIO_fast_gets(fp)) {
7684 * We're going to steal some values from the stdio struct
7685 * and put EVERYTHING in the innermost loop into registers.
7687 register STDCHAR *ptr;
7691 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7692 /* An ungetc()d char is handled separately from the regular
7693 * buffer, so we getc() it back out and stuff it in the buffer.
7695 i = PerlIO_getc(fp);
7696 if (i == EOF) return 0;
7697 *(--((*fp)->_ptr)) = (unsigned char) i;
7701 /* Here is some breathtakingly efficient cheating */
7703 cnt = PerlIO_get_cnt(fp); /* get count into register */
7704 /* make sure we have the room */
7705 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7706 /* Not room for all of it
7707 if we are looking for a separator and room for some
7709 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7710 /* just process what we have room for */
7711 shortbuffered = cnt - SvLEN(sv) + append + 1;
7712 cnt -= shortbuffered;
7716 /* remember that cnt can be negative */
7717 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7722 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
7723 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7724 DEBUG_P(PerlIO_printf(Perl_debug_log,
7725 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7726 DEBUG_P(PerlIO_printf(Perl_debug_log,
7727 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7728 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7729 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7734 while (cnt > 0) { /* this | eat */
7736 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7737 goto thats_all_folks; /* screams | sed :-) */
7741 Copy(ptr, bp, cnt, char); /* this | eat */
7742 bp += cnt; /* screams | dust */
7743 ptr += cnt; /* louder | sed :-) */
7745 assert (!shortbuffered);
7746 goto cannot_be_shortbuffered;
7750 if (shortbuffered) { /* oh well, must extend */
7751 cnt = shortbuffered;
7753 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7755 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7756 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7760 cannot_be_shortbuffered:
7761 DEBUG_P(PerlIO_printf(Perl_debug_log,
7762 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7763 PTR2UV(ptr),(long)cnt));
7764 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7766 DEBUG_Pv(PerlIO_printf(Perl_debug_log,
7767 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7768 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7769 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7771 /* This used to call 'filbuf' in stdio form, but as that behaves like
7772 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7773 another abstraction. */
7774 i = PerlIO_getc(fp); /* get more characters */
7776 DEBUG_Pv(PerlIO_printf(Perl_debug_log,
7777 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7778 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7779 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7781 cnt = PerlIO_get_cnt(fp);
7782 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7783 DEBUG_P(PerlIO_printf(Perl_debug_log,
7784 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7786 if (i == EOF) /* all done for ever? */
7787 goto thats_really_all_folks;
7789 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7791 SvGROW(sv, bpx + cnt + 2);
7792 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7794 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7796 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7797 goto thats_all_folks;
7801 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7802 memNE((char*)bp - rslen, rsptr, rslen))
7803 goto screamer; /* go back to the fray */
7804 thats_really_all_folks:
7806 cnt += shortbuffered;
7807 DEBUG_P(PerlIO_printf(Perl_debug_log,
7808 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7809 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7810 DEBUG_P(PerlIO_printf(Perl_debug_log,
7811 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7812 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7813 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7815 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
7816 DEBUG_P(PerlIO_printf(Perl_debug_log,
7817 "Screamer: done, len=%ld, string=|%.*s|\n",
7818 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7822 /*The big, slow, and stupid way. */
7823 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
7824 STDCHAR *buf = NULL;
7825 Newx(buf, 8192, STDCHAR);
7833 register const STDCHAR * const bpe = buf + sizeof(buf);
7835 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7836 ; /* keep reading */
7840 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7841 /* Accommodate broken VAXC compiler, which applies U8 cast to
7842 * both args of ?: operator, causing EOF to change into 255
7845 i = (U8)buf[cnt - 1];
7851 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7853 sv_catpvn(sv, (char *) buf, cnt);
7855 sv_setpvn(sv, (char *) buf, cnt);
7857 if (i != EOF && /* joy */
7859 SvCUR(sv) < rslen ||
7860 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7864 * If we're reading from a TTY and we get a short read,
7865 * indicating that the user hit his EOF character, we need
7866 * to notice it now, because if we try to read from the TTY
7867 * again, the EOF condition will disappear.
7869 * The comparison of cnt to sizeof(buf) is an optimization
7870 * that prevents unnecessary calls to feof().
7874 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7878 #ifdef USE_HEAP_INSTEAD_OF_STACK
7883 if (rspara) { /* have to do this both before and after */
7884 while (i != EOF) { /* to make sure file boundaries work right */
7885 i = PerlIO_getc(fp);
7887 PerlIO_ungetc(fp,i);
7893 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7899 Auto-increment of the value in the SV, doing string to numeric conversion
7900 if necessary. Handles 'get' magic and operator overloading.
7906 Perl_sv_inc(pTHX_ register SV *const sv)
7915 =for apidoc sv_inc_nomg
7917 Auto-increment of the value in the SV, doing string to numeric conversion
7918 if necessary. Handles operator overloading. Skips handling 'get' magic.
7924 Perl_sv_inc_nomg(pTHX_ register SV *const sv)
7932 if (SvTHINKFIRST(sv)) {
7934 sv_force_normal_flags(sv, 0);
7935 if (SvREADONLY(sv)) {
7936 if (IN_PERL_RUNTIME)
7937 Perl_croak_no_modify(aTHX);
7941 if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg))
7943 i = PTR2IV(SvRV(sv));
7948 flags = SvFLAGS(sv);
7949 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7950 /* It's (privately or publicly) a float, but not tested as an
7951 integer, so test it to see. */
7953 flags = SvFLAGS(sv);
7955 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7956 /* It's publicly an integer, or privately an integer-not-float */
7957 #ifdef PERL_PRESERVE_IVUV
7961 if (SvUVX(sv) == UV_MAX)
7962 sv_setnv(sv, UV_MAX_P1);
7964 (void)SvIOK_only_UV(sv);
7965 SvUV_set(sv, SvUVX(sv) + 1);
7967 if (SvIVX(sv) == IV_MAX)
7968 sv_setuv(sv, (UV)IV_MAX + 1);
7970 (void)SvIOK_only(sv);
7971 SvIV_set(sv, SvIVX(sv) + 1);
7976 if (flags & SVp_NOK) {
7977 const NV was = SvNVX(sv);
7978 if (NV_OVERFLOWS_INTEGERS_AT &&
7979 was >= NV_OVERFLOWS_INTEGERS_AT) {
7980 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7981 "Lost precision when incrementing %" NVff " by 1",
7984 (void)SvNOK_only(sv);
7985 SvNV_set(sv, was + 1.0);
7989 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7990 if ((flags & SVTYPEMASK) < SVt_PVIV)
7991 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
7992 (void)SvIOK_only(sv);
7997 while (isALPHA(*d)) d++;
7998 while (isDIGIT(*d)) d++;
7999 if (d < SvEND(sv)) {
8000 #ifdef PERL_PRESERVE_IVUV
8001 /* Got to punt this as an integer if needs be, but we don't issue
8002 warnings. Probably ought to make the sv_iv_please() that does
8003 the conversion if possible, and silently. */
8004 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8005 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
8006 /* Need to try really hard to see if it's an integer.
8007 9.22337203685478e+18 is an integer.
8008 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8009 so $a="9.22337203685478e+18"; $a+0; $a++
8010 needs to be the same as $a="9.22337203685478e+18"; $a++
8017 /* sv_2iv *should* have made this an NV */
8018 if (flags & SVp_NOK) {
8019 (void)SvNOK_only(sv);
8020 SvNV_set(sv, SvNVX(sv) + 1.0);
8023 /* I don't think we can get here. Maybe I should assert this
8024 And if we do get here I suspect that sv_setnv will croak. NWC
8026 #if defined(USE_LONG_DOUBLE)
8027 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",
8028 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8030 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8031 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8034 #endif /* PERL_PRESERVE_IVUV */
8035 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
8039 while (d >= SvPVX_const(sv)) {
8047 /* MKS: The original code here died if letters weren't consecutive.
8048 * at least it didn't have to worry about non-C locales. The
8049 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
8050 * arranged in order (although not consecutively) and that only
8051 * [A-Za-z] are accepted by isALPHA in the C locale.
8053 if (*d != 'z' && *d != 'Z') {
8054 do { ++*d; } while (!isALPHA(*d));
8057 *(d--) -= 'z' - 'a';
8062 *(d--) -= 'z' - 'a' + 1;
8066 /* oh,oh, the number grew */
8067 SvGROW(sv, SvCUR(sv) + 2);
8068 SvCUR_set(sv, SvCUR(sv) + 1);
8069 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
8080 Auto-decrement of the value in the SV, doing string to numeric conversion
8081 if necessary. Handles 'get' magic and operator overloading.
8087 Perl_sv_dec(pTHX_ register SV *const sv)
8097 =for apidoc sv_dec_nomg
8099 Auto-decrement of the value in the SV, doing string to numeric conversion
8100 if necessary. Handles operator overloading. Skips handling 'get' magic.
8106 Perl_sv_dec_nomg(pTHX_ register SV *const sv)
8113 if (SvTHINKFIRST(sv)) {
8115 sv_force_normal_flags(sv, 0);
8116 if (SvREADONLY(sv)) {
8117 if (IN_PERL_RUNTIME)
8118 Perl_croak_no_modify(aTHX);
8122 if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg))
8124 i = PTR2IV(SvRV(sv));
8129 /* Unlike sv_inc we don't have to worry about string-never-numbers
8130 and keeping them magic. But we mustn't warn on punting */
8131 flags = SvFLAGS(sv);
8132 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
8133 /* It's publicly an integer, or privately an integer-not-float */
8134 #ifdef PERL_PRESERVE_IVUV
8138 if (SvUVX(sv) == 0) {
8139 (void)SvIOK_only(sv);
8143 (void)SvIOK_only_UV(sv);
8144 SvUV_set(sv, SvUVX(sv) - 1);
8147 if (SvIVX(sv) == IV_MIN) {
8148 sv_setnv(sv, (NV)IV_MIN);
8152 (void)SvIOK_only(sv);
8153 SvIV_set(sv, SvIVX(sv) - 1);
8158 if (flags & SVp_NOK) {
8161 const NV was = SvNVX(sv);
8162 if (NV_OVERFLOWS_INTEGERS_AT &&
8163 was <= -NV_OVERFLOWS_INTEGERS_AT) {
8164 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
8165 "Lost precision when decrementing %" NVff " by 1",
8168 (void)SvNOK_only(sv);
8169 SvNV_set(sv, was - 1.0);
8173 if (!(flags & SVp_POK)) {
8174 if ((flags & SVTYPEMASK) < SVt_PVIV)
8175 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
8177 (void)SvIOK_only(sv);
8180 #ifdef PERL_PRESERVE_IVUV
8182 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8183 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
8184 /* Need to try really hard to see if it's an integer.
8185 9.22337203685478e+18 is an integer.
8186 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8187 so $a="9.22337203685478e+18"; $a+0; $a--
8188 needs to be the same as $a="9.22337203685478e+18"; $a--
8195 /* sv_2iv *should* have made this an NV */
8196 if (flags & SVp_NOK) {
8197 (void)SvNOK_only(sv);
8198 SvNV_set(sv, SvNVX(sv) - 1.0);
8201 /* I don't think we can get here. Maybe I should assert this
8202 And if we do get here I suspect that sv_setnv will croak. NWC
8204 #if defined(USE_LONG_DOUBLE)
8205 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",
8206 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8208 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8209 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8213 #endif /* PERL_PRESERVE_IVUV */
8214 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
8217 /* this define is used to eliminate a chunk of duplicated but shared logic
8218 * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
8219 * used anywhere but here - yves
8221 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
8224 PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
8228 =for apidoc sv_mortalcopy
8230 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
8231 The new SV is marked as mortal. It will be destroyed "soon", either by an
8232 explicit call to FREETMPS, or by an implicit call at places such as
8233 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
8238 /* Make a string that will exist for the duration of the expression
8239 * evaluation. Actually, it may have to last longer than that, but
8240 * hopefully we won't free it until it has been assigned to a
8241 * permanent location. */
8244 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
8250 sv_setsv(sv,oldstr);
8251 PUSH_EXTEND_MORTAL__SV_C(sv);
8257 =for apidoc sv_newmortal
8259 Creates a new null SV which is mortal. The reference count of the SV is
8260 set to 1. It will be destroyed "soon", either by an explicit call to
8261 FREETMPS, or by an implicit call at places such as statement boundaries.
8262 See also C<sv_mortalcopy> and C<sv_2mortal>.
8268 Perl_sv_newmortal(pTHX)
8274 SvFLAGS(sv) = SVs_TEMP;
8275 PUSH_EXTEND_MORTAL__SV_C(sv);
8281 =for apidoc newSVpvn_flags
8283 Creates a new SV and copies a string into it. The reference count for the
8284 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
8285 string. You are responsible for ensuring that the source string is at least
8286 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
8287 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
8288 If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before
8289 returning. If C<SVf_UTF8> is set, C<s> is considered to be in UTF-8 and the
8290 C<SVf_UTF8> flag will be set on the new SV.
8291 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
8293 #define newSVpvn_utf8(s, len, u) \
8294 newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
8300 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
8305 /* All the flags we don't support must be zero.
8306 And we're new code so I'm going to assert this from the start. */
8307 assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
8309 sv_setpvn(sv,s,len);
8311 /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal()
8312 * and do what it does ourselves here.
8313 * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags
8314 * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which
8315 * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we
8316 * eliminate quite a few steps than it looks - Yves (explaining patch by gfx)
8319 SvFLAGS(sv) |= flags;
8321 if(flags & SVs_TEMP){
8322 PUSH_EXTEND_MORTAL__SV_C(sv);
8329 =for apidoc sv_2mortal
8331 Marks an existing SV as mortal. The SV will be destroyed "soon", either
8332 by an explicit call to FREETMPS, or by an implicit call at places such as
8333 statement boundaries. SvTEMP() is turned on which means that the SV's
8334 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
8335 and C<sv_mortalcopy>.
8341 Perl_sv_2mortal(pTHX_ register SV *const sv)
8346 if (SvREADONLY(sv) && SvIMMORTAL(sv))
8348 PUSH_EXTEND_MORTAL__SV_C(sv);
8356 Creates a new SV and copies a string into it. The reference count for the
8357 SV is set to 1. If C<len> is zero, Perl will compute the length using
8358 strlen(). For efficiency, consider using C<newSVpvn> instead.
8364 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
8370 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
8375 =for apidoc newSVpvn
8377 Creates a new SV and copies a string into it. The reference count for the
8378 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
8379 string. You are responsible for ensuring that the source string is at least
8380 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
8386 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
8392 sv_setpvn(sv,s,len);
8397 =for apidoc newSVhek
8399 Creates a new SV from the hash key structure. It will generate scalars that
8400 point to the shared string table where possible. Returns a new (undefined)
8401 SV if the hek is NULL.
8407 Perl_newSVhek(pTHX_ const HEK *const hek)
8417 if (HEK_LEN(hek) == HEf_SVKEY) {
8418 return newSVsv(*(SV**)HEK_KEY(hek));
8420 const int flags = HEK_FLAGS(hek);
8421 if (flags & HVhek_WASUTF8) {
8423 Andreas would like keys he put in as utf8 to come back as utf8
8425 STRLEN utf8_len = HEK_LEN(hek);
8426 SV * const sv = newSV_type(SVt_PV);
8427 char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
8428 /* bytes_to_utf8() allocates a new string, which we can repurpose: */
8429 sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
8432 } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
8433 /* We don't have a pointer to the hv, so we have to replicate the
8434 flag into every HEK. This hv is using custom a hasing
8435 algorithm. Hence we can't return a shared string scalar, as
8436 that would contain the (wrong) hash value, and might get passed
8437 into an hv routine with a regular hash.
8438 Similarly, a hash that isn't using shared hash keys has to have
8439 the flag in every key so that we know not to try to call
8440 share_hek_kek on it. */
8442 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
8447 /* This will be overwhelminly the most common case. */
8449 /* Inline most of newSVpvn_share(), because share_hek_hek() is far
8450 more efficient than sharepvn(). */
8454 sv_upgrade(sv, SVt_PV);
8455 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
8456 SvCUR_set(sv, HEK_LEN(hek));
8469 =for apidoc newSVpvn_share
8471 Creates a new SV with its SvPVX_const pointing to a shared string in the string
8472 table. If the string does not already exist in the table, it is created
8473 first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
8474 value is used; otherwise the hash is computed. The string's hash can be later
8475 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
8476 that as the string table is used for shared hash keys these strings will have
8477 SvPVX_const == HeKEY and hash lookup will avoid string compare.
8483 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
8487 bool is_utf8 = FALSE;
8488 const char *const orig_src = src;
8491 STRLEN tmplen = -len;
8493 /* See the note in hv.c:hv_fetch() --jhi */
8494 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
8498 PERL_HASH(hash, src, len);
8500 /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
8501 changes here, update it there too. */
8502 sv_upgrade(sv, SVt_PV);
8503 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
8511 if (src != orig_src)
8517 =for apidoc newSVpv_share
8519 Like C<newSVpvn_share>, but takes a nul-terminated string instead of a
8526 Perl_newSVpv_share(pTHX_ const char *src, U32 hash)
8528 return newSVpvn_share(src, strlen(src), hash);
8531 #if defined(PERL_IMPLICIT_CONTEXT)
8533 /* pTHX_ magic can't cope with varargs, so this is a no-context
8534 * version of the main function, (which may itself be aliased to us).
8535 * Don't access this version directly.
8539 Perl_newSVpvf_nocontext(const char *const pat, ...)
8545 PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
8547 va_start(args, pat);
8548 sv = vnewSVpvf(pat, &args);
8555 =for apidoc newSVpvf
8557 Creates a new SV and initializes it with the string formatted like
8564 Perl_newSVpvf(pTHX_ const char *const pat, ...)
8569 PERL_ARGS_ASSERT_NEWSVPVF;
8571 va_start(args, pat);
8572 sv = vnewSVpvf(pat, &args);
8577 /* backend for newSVpvf() and newSVpvf_nocontext() */
8580 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
8585 PERL_ARGS_ASSERT_VNEWSVPVF;
8588 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8595 Creates a new SV and copies a floating point value into it.
8596 The reference count for the SV is set to 1.
8602 Perl_newSVnv(pTHX_ const NV n)
8615 Creates a new SV and copies an integer into it. The reference count for the
8622 Perl_newSViv(pTHX_ const IV i)
8635 Creates a new SV and copies an unsigned integer into it.
8636 The reference count for the SV is set to 1.
8642 Perl_newSVuv(pTHX_ const UV u)
8653 =for apidoc newSV_type
8655 Creates a new SV, of the type specified. The reference count for the new SV
8662 Perl_newSV_type(pTHX_ const svtype type)
8667 sv_upgrade(sv, type);
8672 =for apidoc newRV_noinc
8674 Creates an RV wrapper for an SV. The reference count for the original
8675 SV is B<not> incremented.
8681 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
8684 register SV *sv = newSV_type(SVt_IV);
8686 PERL_ARGS_ASSERT_NEWRV_NOINC;
8689 SvRV_set(sv, tmpRef);
8694 /* newRV_inc is the official function name to use now.
8695 * newRV_inc is in fact #defined to newRV in sv.h
8699 Perl_newRV(pTHX_ SV *const sv)
8703 PERL_ARGS_ASSERT_NEWRV;
8705 return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
8711 Creates a new SV which is an exact duplicate of the original SV.
8718 Perl_newSVsv(pTHX_ register SV *const old)
8725 if (SvTYPE(old) == SVTYPEMASK) {
8726 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
8730 /* SV_GMAGIC is the default for sv_setv()
8731 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
8732 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
8733 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
8738 =for apidoc sv_reset
8740 Underlying implementation for the C<reset> Perl function.
8741 Note that the perl-level function is vaguely deprecated.
8747 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
8750 char todo[PERL_UCHAR_MAX+1];
8752 PERL_ARGS_ASSERT_SV_RESET;
8757 if (!*s) { /* reset ?? searches */
8758 MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
8760 const U32 count = mg->mg_len / sizeof(PMOP**);
8761 PMOP **pmp = (PMOP**) mg->mg_ptr;
8762 PMOP *const *const end = pmp + count;
8766 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
8768 (*pmp)->op_pmflags &= ~PMf_USED;
8776 /* reset variables */
8778 if (!HvARRAY(stash))
8781 Zero(todo, 256, char);
8784 I32 i = (unsigned char)*s;
8788 max = (unsigned char)*s++;
8789 for ( ; i <= max; i++) {
8792 for (i = 0; i <= (I32) HvMAX(stash); i++) {
8794 for (entry = HvARRAY(stash)[i];
8796 entry = HeNEXT(entry))
8801 if (!todo[(U8)*HeKEY(entry)])
8803 gv = MUTABLE_GV(HeVAL(entry));
8806 if (SvTHINKFIRST(sv)) {
8807 if (!SvREADONLY(sv) && SvROK(sv))
8809 /* XXX Is this continue a bug? Why should THINKFIRST
8810 exempt us from resetting arrays and hashes? */
8814 if (SvTYPE(sv) >= SVt_PV) {
8816 if (SvPVX_const(sv) != NULL)
8824 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8826 Perl_die(aTHX_ "Can't reset %%ENV on this system");
8829 # if defined(USE_ENVIRON_ARRAY)
8832 # endif /* USE_ENVIRON_ARRAY */
8843 Using various gambits, try to get an IO from an SV: the IO slot if its a
8844 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8845 named after the PV if we're a string.
8851 Perl_sv_2io(pTHX_ SV *const sv)
8856 PERL_ARGS_ASSERT_SV_2IO;
8858 switch (SvTYPE(sv)) {
8860 io = MUTABLE_IO(sv);
8864 if (isGV_with_GP(sv)) {
8865 gv = MUTABLE_GV(sv);
8868 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8874 Perl_croak(aTHX_ PL_no_usym, "filehandle");
8876 return sv_2io(SvRV(sv));
8877 gv = gv_fetchsv(sv, 0, SVt_PVIO);
8883 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
8892 Using various gambits, try to get a CV from an SV; in addition, try if
8893 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8894 The flags in C<lref> are passed to gv_fetchsv.
8900 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8906 PERL_ARGS_ASSERT_SV_2CV;
8913 switch (SvTYPE(sv)) {
8917 return MUTABLE_CV(sv);
8924 if (isGV_with_GP(sv)) {
8925 gv = MUTABLE_GV(sv);
8936 sv = amagic_deref_call(sv, to_cv_amg);
8937 /* At this point I'd like to do SPAGAIN, but really I need to
8938 force it upon my callers. Hmmm. This is a mess... */
8941 if (SvTYPE(sv) == SVt_PVCV) {
8942 cv = MUTABLE_CV(sv);
8947 else if(isGV_with_GP(sv))
8948 gv = MUTABLE_GV(sv);
8950 Perl_croak(aTHX_ "Not a subroutine reference");
8952 else if (isGV_with_GP(sv)) {
8954 gv = MUTABLE_GV(sv);
8957 gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
8963 /* Some flags to gv_fetchsv mean don't really create the GV */
8964 if (!isGV_with_GP(gv)) {
8970 if (lref && !GvCVu(gv)) {
8974 gv_efullname3(tmpsv, gv, NULL);
8975 /* XXX this is probably not what they think they're getting.
8976 * It has the same effect as "sub name;", i.e. just a forward
8978 newSUB(start_subparse(FALSE, 0),
8979 newSVOP(OP_CONST, 0, tmpsv),
8983 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8984 SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8993 Returns true if the SV has a true value by Perl's rules.
8994 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8995 instead use an in-line version.
9001 Perl_sv_true(pTHX_ register SV *const sv)
9006 register const XPV* const tXpv = (XPV*)SvANY(sv);
9008 (tXpv->xpv_cur > 1 ||
9009 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
9016 return SvIVX(sv) != 0;
9019 return SvNVX(sv) != 0.0;
9021 return sv_2bool(sv);
9027 =for apidoc sv_pvn_force
9029 Get a sensible string out of the SV somehow.
9030 A private implementation of the C<SvPV_force> macro for compilers which
9031 can't cope with complex macro expressions. Always use the macro instead.
9033 =for apidoc sv_pvn_force_flags
9035 Get a sensible string out of the SV somehow.
9036 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
9037 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
9038 implemented in terms of this function.
9039 You normally want to use the various wrapper macros instead: see
9040 C<SvPV_force> and C<SvPV_force_nomg>
9046 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
9050 PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
9052 if (SvTHINKFIRST(sv) && !SvROK(sv))
9053 sv_force_normal_flags(sv, 0);
9063 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
9064 const char * const ref = sv_reftype(sv,0);
9066 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
9067 ref, OP_DESC(PL_op));
9069 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
9071 if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
9072 || isGV_with_GP(sv))
9073 /* diag_listed_as: Can't coerce %s to %s in %s */
9074 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
9076 s = sv_2pv_flags(sv, &len, flags);
9080 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
9083 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
9084 SvGROW(sv, len + 1);
9085 Move(s,SvPVX(sv),len,char);
9087 SvPVX(sv)[len] = '\0';
9090 SvPOK_on(sv); /* validate pointer */
9092 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
9093 PTR2UV(sv),SvPVX_const(sv)));
9096 return SvPVX_mutable(sv);
9100 =for apidoc sv_pvbyten_force
9102 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
9108 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
9110 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
9112 sv_pvn_force(sv,lp);
9113 sv_utf8_downgrade(sv,0);
9119 =for apidoc sv_pvutf8n_force
9121 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
9127 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
9129 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
9131 sv_pvn_force(sv,lp);
9132 sv_utf8_upgrade(sv);
9138 =for apidoc sv_reftype
9140 Returns a string describing what the SV is a reference to.
9146 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
9148 PERL_ARGS_ASSERT_SV_REFTYPE;
9150 /* The fact that I don't need to downcast to char * everywhere, only in ?:
9151 inside return suggests a const propagation bug in g++. */
9152 if (ob && SvOBJECT(sv)) {
9153 char * const name = HvNAME_get(SvSTASH(sv));
9154 return name ? name : (char *) "__ANON__";
9157 switch (SvTYPE(sv)) {
9172 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
9173 /* tied lvalues should appear to be
9174 * scalars for backwards compatibility */
9175 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
9176 ? "SCALAR" : "LVALUE");
9177 case SVt_PVAV: return "ARRAY";
9178 case SVt_PVHV: return "HASH";
9179 case SVt_PVCV: return "CODE";
9180 case SVt_PVGV: return (char *) (isGV_with_GP(sv)
9181 ? "GLOB" : "SCALAR");
9182 case SVt_PVFM: return "FORMAT";
9183 case SVt_PVIO: return "IO";
9184 case SVt_BIND: return "BIND";
9185 case SVt_REGEXP: return "REGEXP";
9186 default: return "UNKNOWN";
9192 =for apidoc sv_isobject
9194 Returns a boolean indicating whether the SV is an RV pointing to a blessed
9195 object. If the SV is not an RV, or if the object is not blessed, then this
9202 Perl_sv_isobject(pTHX_ SV *sv)
9218 Returns a boolean indicating whether the SV is blessed into the specified
9219 class. This does not check for subtypes; use C<sv_derived_from> to verify
9220 an inheritance relationship.
9226 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
9230 PERL_ARGS_ASSERT_SV_ISA;
9240 hvname = HvNAME_get(SvSTASH(sv));
9244 return strEQ(hvname, name);
9250 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
9251 it will be upgraded to one. If C<classname> is non-null then the new SV will
9252 be blessed in the specified package. The new SV is returned and its
9253 reference count is 1.
9259 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
9264 PERL_ARGS_ASSERT_NEWSVRV;
9268 SV_CHECK_THINKFIRST_COW_DROP(rv);
9269 (void)SvAMAGIC_off(rv);
9271 if (SvTYPE(rv) >= SVt_PVMG) {
9272 const U32 refcnt = SvREFCNT(rv);
9276 SvREFCNT(rv) = refcnt;
9278 sv_upgrade(rv, SVt_IV);
9279 } else if (SvROK(rv)) {
9280 SvREFCNT_dec(SvRV(rv));
9282 prepare_SV_for_RV(rv);
9290 HV* const stash = gv_stashpv(classname, GV_ADD);
9291 (void)sv_bless(rv, stash);
9297 =for apidoc sv_setref_pv
9299 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
9300 argument will be upgraded to an RV. That RV will be modified to point to
9301 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
9302 into the SV. The C<classname> argument indicates the package for the
9303 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9304 will have a reference count of 1, and the RV will be returned.
9306 Do not use with other Perl types such as HV, AV, SV, CV, because those
9307 objects will become corrupted by the pointer copy process.
9309 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
9315 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
9319 PERL_ARGS_ASSERT_SV_SETREF_PV;
9322 sv_setsv(rv, &PL_sv_undef);
9326 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
9331 =for apidoc sv_setref_iv
9333 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
9334 argument will be upgraded to an RV. That RV will be modified to point to
9335 the new SV. The C<classname> argument indicates the package for the
9336 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9337 will have a reference count of 1, and the RV will be returned.
9343 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
9345 PERL_ARGS_ASSERT_SV_SETREF_IV;
9347 sv_setiv(newSVrv(rv,classname), iv);
9352 =for apidoc sv_setref_uv
9354 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
9355 argument will be upgraded to an RV. That RV will be modified to point to
9356 the new SV. The C<classname> argument indicates the package for the
9357 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9358 will have a reference count of 1, and the RV will be returned.
9364 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
9366 PERL_ARGS_ASSERT_SV_SETREF_UV;
9368 sv_setuv(newSVrv(rv,classname), uv);
9373 =for apidoc sv_setref_nv
9375 Copies a double into a new SV, optionally blessing the SV. The C<rv>
9376 argument will be upgraded to an RV. That RV will be modified to point to
9377 the new SV. The C<classname> argument indicates the package for the
9378 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9379 will have a reference count of 1, and the RV will be returned.
9385 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
9387 PERL_ARGS_ASSERT_SV_SETREF_NV;
9389 sv_setnv(newSVrv(rv,classname), nv);
9394 =for apidoc sv_setref_pvn
9396 Copies a string into a new SV, optionally blessing the SV. The length of the
9397 string must be specified with C<n>. The C<rv> argument will be upgraded to
9398 an RV. That RV will be modified to point to the new SV. The C<classname>
9399 argument indicates the package for the blessing. Set C<classname> to
9400 C<NULL> to avoid the blessing. The new SV will have a reference count
9401 of 1, and the RV will be returned.
9403 Note that C<sv_setref_pv> copies the pointer while this copies the string.
9409 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
9410 const char *const pv, const STRLEN n)
9412 PERL_ARGS_ASSERT_SV_SETREF_PVN;
9414 sv_setpvn(newSVrv(rv,classname), pv, n);
9419 =for apidoc sv_bless
9421 Blesses an SV into a specified package. The SV must be an RV. The package
9422 must be designated by its stash (see C<gv_stashpv()>). The reference count
9423 of the SV is unaffected.
9429 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
9434 PERL_ARGS_ASSERT_SV_BLESS;
9437 Perl_croak(aTHX_ "Can't bless non-reference value");
9439 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
9440 if (SvIsCOW(tmpRef))
9441 sv_force_normal_flags(tmpRef, 0);
9442 if (SvREADONLY(tmpRef))
9443 Perl_croak_no_modify(aTHX);
9444 if (SvOBJECT(tmpRef)) {
9445 if (SvTYPE(tmpRef) != SVt_PVIO)
9447 SvREFCNT_dec(SvSTASH(tmpRef));
9450 SvOBJECT_on(tmpRef);
9451 if (SvTYPE(tmpRef) != SVt_PVIO)
9453 SvUPGRADE(tmpRef, SVt_PVMG);
9454 SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
9459 (void)SvAMAGIC_off(sv);
9461 if(SvSMAGICAL(tmpRef))
9462 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
9470 /* Downgrades a PVGV to a PVMG. If it’s actually a PVLV, we leave the type
9471 * as it is after unglobbing it.
9475 S_sv_unglob(pTHX_ SV *const sv)
9480 SV * const temp = sv_newmortal();
9482 PERL_ARGS_ASSERT_SV_UNGLOB;
9484 assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
9486 gv_efullname3(temp, MUTABLE_GV(sv), "*");
9489 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
9490 && HvNAME_get(stash))
9491 mro_method_changed_in(stash);
9492 gp_free(MUTABLE_GV(sv));
9495 sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
9499 if (GvNAME_HEK(sv)) {
9500 unshare_hek(GvNAME_HEK(sv));
9502 isGV_with_GP_off(sv);
9504 if(SvTYPE(sv) == SVt_PVGV) {
9505 /* need to keep SvANY(sv) in the right arena */
9506 xpvmg = new_XPVMG();
9507 StructCopy(SvANY(sv), xpvmg, XPVMG);
9508 del_XPVGV(SvANY(sv));
9511 SvFLAGS(sv) &= ~SVTYPEMASK;
9512 SvFLAGS(sv) |= SVt_PVMG;
9515 /* Intentionally not calling any local SET magic, as this isn't so much a
9516 set operation as merely an internal storage change. */
9517 sv_setsv_flags(sv, temp, 0);
9521 =for apidoc sv_unref_flags
9523 Unsets the RV status of the SV, and decrements the reference count of
9524 whatever was being referenced by the RV. This can almost be thought of
9525 as a reversal of C<newSVrv>. The C<cflags> argument can contain
9526 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
9527 (otherwise the decrementing is conditional on the reference count being
9528 different from one or the reference being a readonly SV).
9535 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
9537 SV* const target = SvRV(ref);
9539 PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
9541 if (SvWEAKREF(ref)) {
9542 sv_del_backref(target, ref);
9544 SvRV_set(ref, NULL);
9547 SvRV_set(ref, NULL);
9549 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
9550 assigned to as BEGIN {$a = \"Foo"} will fail. */
9551 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
9552 SvREFCNT_dec(target);
9553 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
9554 sv_2mortal(target); /* Schedule for freeing later */
9558 =for apidoc sv_untaint
9560 Untaint an SV. Use C<SvTAINTED_off> instead.
9565 Perl_sv_untaint(pTHX_ SV *const sv)
9567 PERL_ARGS_ASSERT_SV_UNTAINT;
9569 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9570 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9577 =for apidoc sv_tainted
9579 Test an SV for taintedness. Use C<SvTAINTED> instead.
9584 Perl_sv_tainted(pTHX_ SV *const sv)
9586 PERL_ARGS_ASSERT_SV_TAINTED;
9588 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9589 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9590 if (mg && (mg->mg_len & 1) )
9597 =for apidoc sv_setpviv
9599 Copies an integer into the given SV, also updating its string value.
9600 Does not handle 'set' magic. See C<sv_setpviv_mg>.
9606 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
9608 char buf[TYPE_CHARS(UV)];
9610 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
9612 PERL_ARGS_ASSERT_SV_SETPVIV;
9614 sv_setpvn(sv, ptr, ebuf - ptr);
9618 =for apidoc sv_setpviv_mg
9620 Like C<sv_setpviv>, but also handles 'set' magic.
9626 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
9628 PERL_ARGS_ASSERT_SV_SETPVIV_MG;
9634 #if defined(PERL_IMPLICIT_CONTEXT)
9636 /* pTHX_ magic can't cope with varargs, so this is a no-context
9637 * version of the main function, (which may itself be aliased to us).
9638 * Don't access this version directly.
9642 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
9647 PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
9649 va_start(args, pat);
9650 sv_vsetpvf(sv, pat, &args);
9654 /* pTHX_ magic can't cope with varargs, so this is a no-context
9655 * version of the main function, (which may itself be aliased to us).
9656 * Don't access this version directly.
9660 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9665 PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
9667 va_start(args, pat);
9668 sv_vsetpvf_mg(sv, pat, &args);
9674 =for apidoc sv_setpvf
9676 Works like C<sv_catpvf> but copies the text into the SV instead of
9677 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
9683 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
9687 PERL_ARGS_ASSERT_SV_SETPVF;
9689 va_start(args, pat);
9690 sv_vsetpvf(sv, pat, &args);
9695 =for apidoc sv_vsetpvf
9697 Works like C<sv_vcatpvf> but copies the text into the SV instead of
9698 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
9700 Usually used via its frontend C<sv_setpvf>.
9706 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9708 PERL_ARGS_ASSERT_SV_VSETPVF;
9710 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9714 =for apidoc sv_setpvf_mg
9716 Like C<sv_setpvf>, but also handles 'set' magic.
9722 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9726 PERL_ARGS_ASSERT_SV_SETPVF_MG;
9728 va_start(args, pat);
9729 sv_vsetpvf_mg(sv, pat, &args);
9734 =for apidoc sv_vsetpvf_mg
9736 Like C<sv_vsetpvf>, but also handles 'set' magic.
9738 Usually used via its frontend C<sv_setpvf_mg>.
9744 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9746 PERL_ARGS_ASSERT_SV_VSETPVF_MG;
9748 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9752 #if defined(PERL_IMPLICIT_CONTEXT)
9754 /* pTHX_ magic can't cope with varargs, so this is a no-context
9755 * version of the main function, (which may itself be aliased to us).
9756 * Don't access this version directly.
9760 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
9765 PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
9767 va_start(args, pat);
9768 sv_vcatpvf(sv, pat, &args);
9772 /* pTHX_ magic can't cope with varargs, so this is a no-context
9773 * version of the main function, (which may itself be aliased to us).
9774 * Don't access this version directly.
9778 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9783 PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9785 va_start(args, pat);
9786 sv_vcatpvf_mg(sv, pat, &args);
9792 =for apidoc sv_catpvf
9794 Processes its arguments like C<sprintf> and appends the formatted
9795 output to an SV. If the appended data contains "wide" characters
9796 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9797 and characters >255 formatted with %c), the original SV might get
9798 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
9799 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9800 valid UTF-8; if the original SV was bytes, the pattern should be too.
9805 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9809 PERL_ARGS_ASSERT_SV_CATPVF;
9811 va_start(args, pat);
9812 sv_vcatpvf(sv, pat, &args);
9817 =for apidoc sv_vcatpvf
9819 Processes its arguments like C<vsprintf> and appends the formatted output
9820 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
9822 Usually used via its frontend C<sv_catpvf>.
9828 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9830 PERL_ARGS_ASSERT_SV_VCATPVF;
9832 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9836 =for apidoc sv_catpvf_mg
9838 Like C<sv_catpvf>, but also handles 'set' magic.
9844 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9848 PERL_ARGS_ASSERT_SV_CATPVF_MG;
9850 va_start(args, pat);
9851 sv_vcatpvf_mg(sv, pat, &args);
9856 =for apidoc sv_vcatpvf_mg
9858 Like C<sv_vcatpvf>, but also handles 'set' magic.
9860 Usually used via its frontend C<sv_catpvf_mg>.
9866 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9868 PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9870 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9875 =for apidoc sv_vsetpvfn
9877 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9880 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9886 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9887 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9889 PERL_ARGS_ASSERT_SV_VSETPVFN;
9892 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9897 * Warn of missing argument to sprintf, and then return a defined value
9898 * to avoid inappropriate "use of uninit" warnings [perl #71000].
9900 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
9902 S_vcatpvfn_missing_argument(pTHX) {
9903 if (ckWARN(WARN_MISSING)) {
9904 Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
9905 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
9912 S_expect_number(pTHX_ char **const pattern)
9917 PERL_ARGS_ASSERT_EXPECT_NUMBER;
9919 switch (**pattern) {
9920 case '1': case '2': case '3':
9921 case '4': case '5': case '6':
9922 case '7': case '8': case '9':
9923 var = *(*pattern)++ - '0';
9924 while (isDIGIT(**pattern)) {
9925 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
9927 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
9935 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
9937 const int neg = nv < 0;
9940 PERL_ARGS_ASSERT_F0CONVERT;
9948 if (uv & 1 && uv == nv)
9949 uv--; /* Round to even */
9951 const unsigned dig = uv % 10;
9964 =for apidoc sv_vcatpvfn
9966 Processes its arguments like C<vsprintf> and appends the formatted output
9967 to an SV. Uses an array of SVs if the C style variable argument list is
9968 missing (NULL). When running with taint checks enabled, indicates via
9969 C<maybe_tainted> if results are untrustworthy (often due to the use of
9972 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9978 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
9979 vecstr = (U8*)SvPV_const(vecsv,veclen);\
9980 vec_utf8 = DO_UTF8(vecsv);
9982 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9985 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9986 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9994 static const char nullstr[] = "(null)";
9996 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
9997 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9999 /* Times 4: a decimal digit takes more than 3 binary digits.
10000 * NV_DIG: mantissa takes than many decimal digits.
10001 * Plus 32: Playing safe. */
10002 char ebuf[IV_DIG * 4 + NV_DIG + 32];
10003 /* large enough for "%#.#f" --chip */
10004 /* what about long double NVs? --jhi */
10006 PERL_ARGS_ASSERT_SV_VCATPVFN;
10007 PERL_UNUSED_ARG(maybe_tainted);
10009 /* no matter what, this is a string now */
10010 (void)SvPV_force(sv, origlen);
10012 /* special-case "", "%s", and "%-p" (SVf - see below) */
10015 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
10017 const char * const s = va_arg(*args, char*);
10018 sv_catpv(sv, s ? s : nullstr);
10020 else if (svix < svmax) {
10021 sv_catsv(sv, *svargs);
10024 S_vcatpvfn_missing_argument(aTHX);
10027 if (args && patlen == 3 && pat[0] == '%' &&
10028 pat[1] == '-' && pat[2] == 'p') {
10029 argsv = MUTABLE_SV(va_arg(*args, void*));
10030 sv_catsv(sv, argsv);
10034 #ifndef USE_LONG_DOUBLE
10035 /* special-case "%.<number>[gf]" */
10036 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
10037 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
10038 unsigned digits = 0;
10042 while (*pp >= '0' && *pp <= '9')
10043 digits = 10 * digits + (*pp++ - '0');
10044 if (pp - pat == (int)patlen - 1 && svix < svmax) {
10045 const NV nv = SvNV(*svargs);
10047 /* Add check for digits != 0 because it seems that some
10048 gconverts are buggy in this case, and we don't yet have
10049 a Configure test for this. */
10050 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
10051 /* 0, point, slack */
10052 Gconvert(nv, (int)digits, 0, ebuf);
10053 sv_catpv(sv, ebuf);
10054 if (*ebuf) /* May return an empty string for digits==0 */
10057 } else if (!digits) {
10060 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
10061 sv_catpvn(sv, p, l);
10067 #endif /* !USE_LONG_DOUBLE */
10069 if (!args && svix < svmax && DO_UTF8(*svargs))
10072 patend = (char*)pat + patlen;
10073 for (p = (char*)pat; p < patend; p = q) {
10076 bool vectorize = FALSE;
10077 bool vectorarg = FALSE;
10078 bool vec_utf8 = FALSE;
10084 bool has_precis = FALSE;
10086 const I32 osvix = svix;
10087 bool is_utf8 = FALSE; /* is this item utf8? */
10088 #ifdef HAS_LDBL_SPRINTF_BUG
10089 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10090 with sfio - Allen <allens@cpan.org> */
10091 bool fix_ldbl_sprintf_bug = FALSE;
10095 U8 utf8buf[UTF8_MAXBYTES+1];
10096 STRLEN esignlen = 0;
10098 const char *eptr = NULL;
10099 const char *fmtstart;
10102 const U8 *vecstr = NULL;
10109 /* we need a long double target in case HAS_LONG_DOUBLE but
10110 not USE_LONG_DOUBLE
10112 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
10120 const char *dotstr = ".";
10121 STRLEN dotstrlen = 1;
10122 I32 efix = 0; /* explicit format parameter index */
10123 I32 ewix = 0; /* explicit width index */
10124 I32 epix = 0; /* explicit precision index */
10125 I32 evix = 0; /* explicit vector index */
10126 bool asterisk = FALSE;
10128 /* echo everything up to the next format specification */
10129 for (q = p; q < patend && *q != '%'; ++q) ;
10131 if (has_utf8 && !pat_utf8)
10132 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
10134 sv_catpvn(sv, p, q - p);
10143 We allow format specification elements in this order:
10144 \d+\$ explicit format parameter index
10146 v|\*(\d+\$)?v vector with optional (optionally specified) arg
10147 0 flag (as above): repeated to allow "v02"
10148 \d+|\*(\d+\$)? width using optional (optionally specified) arg
10149 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
10151 [%bcdefginopsuxDFOUX] format (mandatory)
10156 As of perl5.9.3, printf format checking is on by default.
10157 Internally, perl uses %p formats to provide an escape to
10158 some extended formatting. This block deals with those
10159 extensions: if it does not match, (char*)q is reset and
10160 the normal format processing code is used.
10162 Currently defined extensions are:
10163 %p include pointer address (standard)
10164 %-p (SVf) include an SV (previously %_)
10165 %-<num>p include an SV with precision <num>
10166 %<num>p reserved for future extensions
10168 Robin Barker 2005-07-14
10170 %1p (VDf) removed. RMB 2007-10-19
10177 n = expect_number(&q);
10179 if (sv) { /* SVf */
10184 argsv = MUTABLE_SV(va_arg(*args, void*));
10185 eptr = SvPV_const(argsv, elen);
10186 if (DO_UTF8(argsv))
10191 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
10192 "internal %%<num>p might conflict with future printf extensions");
10198 if ( (width = expect_number(&q)) ) {
10213 if (plus == '+' && *q == ' ') /* '+' over ' ' */
10242 if ( (ewix = expect_number(&q)) )
10251 if ((vectorarg = asterisk)) {
10264 width = expect_number(&q);
10267 if (vectorize && vectorarg) {
10268 /* vectorizing, but not with the default "." */
10270 vecsv = va_arg(*args, SV*);
10272 vecsv = (evix > 0 && evix <= svmax)
10273 ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
10275 vecsv = svix < svmax
10276 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10278 dotstr = SvPV_const(vecsv, dotstrlen);
10279 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
10280 bad with tied or overloaded values that return UTF8. */
10281 if (DO_UTF8(vecsv))
10283 else if (has_utf8) {
10284 vecsv = sv_mortalcopy(vecsv);
10285 sv_utf8_upgrade(vecsv);
10286 dotstr = SvPV_const(vecsv, dotstrlen);
10293 i = va_arg(*args, int);
10295 i = (ewix ? ewix <= svmax : svix < svmax) ?
10296 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10298 width = (i < 0) ? -i : i;
10308 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
10310 /* XXX: todo, support specified precision parameter */
10314 i = va_arg(*args, int);
10316 i = (ewix ? ewix <= svmax : svix < svmax)
10317 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10319 has_precis = !(i < 0);
10323 while (isDIGIT(*q))
10324 precis = precis * 10 + (*q++ - '0');
10333 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
10334 vecsv = svargs[efix ? efix-1 : svix++];
10335 vecstr = (U8*)SvPV_const(vecsv,veclen);
10336 vec_utf8 = DO_UTF8(vecsv);
10338 /* if this is a version object, we need to convert
10339 * back into v-string notation and then let the
10340 * vectorize happen normally
10342 if (sv_derived_from(vecsv, "version")) {
10343 char *version = savesvpv(vecsv);
10344 if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
10345 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
10346 "vector argument not supported with alpha versions");
10349 vecsv = sv_newmortal();
10350 scan_vstring(version, version + veclen, vecsv);
10351 vecstr = (U8*)SvPV_const(vecsv, veclen);
10352 vec_utf8 = DO_UTF8(vecsv);
10366 case 'I': /* Ix, I32x, and I64x */
10368 if (q[1] == '6' && q[2] == '4') {
10374 if (q[1] == '3' && q[2] == '2') {
10384 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10396 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10397 if (*q == 'l') { /* lld, llf */
10406 if (*++q == 'h') { /* hhd, hhu */
10435 if (!vectorize && !args) {
10437 const I32 i = efix-1;
10438 argsv = (i >= 0 && i < svmax)
10439 ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
10441 argsv = (svix >= 0 && svix < svmax)
10442 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10446 switch (c = *q++) {
10453 uv = (args) ? va_arg(*args, int) : SvIV(argsv);
10455 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
10457 eptr = (char*)utf8buf;
10458 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
10472 eptr = va_arg(*args, char*);
10474 elen = strlen(eptr);
10476 eptr = (char *)nullstr;
10477 elen = sizeof nullstr - 1;
10481 eptr = SvPV_const(argsv, elen);
10482 if (DO_UTF8(argsv)) {
10483 STRLEN old_precis = precis;
10484 if (has_precis && precis < elen) {
10485 STRLEN ulen = sv_len_utf8(argsv);
10486 I32 p = precis > ulen ? ulen : precis;
10487 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
10490 if (width) { /* fudge width (can't fudge elen) */
10491 if (has_precis && precis < elen)
10492 width += precis - old_precis;
10494 width += elen - sv_len_utf8(argsv);
10501 if (has_precis && precis < elen)
10508 if (alt || vectorize)
10510 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
10531 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10540 esignbuf[esignlen++] = plus;
10544 case 'c': iv = (char)va_arg(*args, int); break;
10545 case 'h': iv = (short)va_arg(*args, int); break;
10546 case 'l': iv = va_arg(*args, long); break;
10547 case 'V': iv = va_arg(*args, IV); break;
10548 case 'z': iv = va_arg(*args, SSize_t); break;
10549 case 't': iv = va_arg(*args, ptrdiff_t); break;
10550 default: iv = va_arg(*args, int); break;
10552 case 'j': iv = va_arg(*args, intmax_t); break;
10556 iv = va_arg(*args, Quad_t); break;
10563 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
10565 case 'c': iv = (char)tiv; break;
10566 case 'h': iv = (short)tiv; break;
10567 case 'l': iv = (long)tiv; break;
10569 default: iv = tiv; break;
10572 iv = (Quad_t)tiv; break;
10578 if ( !vectorize ) /* we already set uv above */
10583 esignbuf[esignlen++] = plus;
10587 esignbuf[esignlen++] = '-';
10631 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10642 case 'c': uv = (unsigned char)va_arg(*args, unsigned); break;
10643 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
10644 case 'l': uv = va_arg(*args, unsigned long); break;
10645 case 'V': uv = va_arg(*args, UV); break;
10646 case 'z': uv = va_arg(*args, Size_t); break;
10647 case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */
10649 case 'j': uv = va_arg(*args, uintmax_t); break;
10651 default: uv = va_arg(*args, unsigned); break;
10654 uv = va_arg(*args, Uquad_t); break;
10661 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
10663 case 'c': uv = (unsigned char)tuv; break;
10664 case 'h': uv = (unsigned short)tuv; break;
10665 case 'l': uv = (unsigned long)tuv; break;
10667 default: uv = tuv; break;
10670 uv = (Uquad_t)tuv; break;
10679 char *ptr = ebuf + sizeof ebuf;
10680 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
10686 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
10690 } while (uv >>= 4);
10692 esignbuf[esignlen++] = '0';
10693 esignbuf[esignlen++] = c; /* 'x' or 'X' */
10699 *--ptr = '0' + dig;
10700 } while (uv >>= 3);
10701 if (alt && *ptr != '0')
10707 *--ptr = '0' + dig;
10708 } while (uv >>= 1);
10710 esignbuf[esignlen++] = '0';
10711 esignbuf[esignlen++] = c;
10714 default: /* it had better be ten or less */
10717 *--ptr = '0' + dig;
10718 } while (uv /= base);
10721 elen = (ebuf + sizeof ebuf) - ptr;
10725 zeros = precis - elen;
10726 else if (precis == 0 && elen == 1 && *eptr == '0'
10727 && !(base == 8 && alt)) /* "%#.0o" prints "0" */
10730 /* a precision nullifies the 0 flag. */
10737 /* FLOATING POINT */
10740 c = 'f'; /* maybe %F isn't supported here */
10742 case 'e': case 'E':
10744 case 'g': case 'G':
10748 /* This is evil, but floating point is even more evil */
10750 /* for SV-style calling, we can only get NV
10751 for C-style calling, we assume %f is double;
10752 for simplicity we allow any of %Lf, %llf, %qf for long double
10756 #if defined(USE_LONG_DOUBLE)
10760 /* [perl #20339] - we should accept and ignore %lf rather than die */
10764 #if defined(USE_LONG_DOUBLE)
10765 intsize = args ? 0 : 'q';
10769 #if defined(HAS_LONG_DOUBLE)
10782 /* now we need (long double) if intsize == 'q', else (double) */
10784 #if LONG_DOUBLESIZE > DOUBLESIZE
10786 va_arg(*args, long double) :
10787 va_arg(*args, double)
10789 va_arg(*args, double)
10794 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
10795 else. frexp() has some unspecified behaviour for those three */
10796 if (c != 'e' && c != 'E' && (nv * 0) == 0) {
10798 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
10799 will cast our (long double) to (double) */
10800 (void)Perl_frexp(nv, &i);
10801 if (i == PERL_INT_MIN)
10802 Perl_die(aTHX_ "panic: frexp");
10804 need = BIT_DIGITS(i);
10806 need += has_precis ? precis : 6; /* known default */
10811 #ifdef HAS_LDBL_SPRINTF_BUG
10812 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10813 with sfio - Allen <allens@cpan.org> */
10816 # define MY_DBL_MAX DBL_MAX
10817 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
10818 # if DOUBLESIZE >= 8
10819 # define MY_DBL_MAX 1.7976931348623157E+308L
10821 # define MY_DBL_MAX 3.40282347E+38L
10825 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10826 # define MY_DBL_MAX_BUG 1L
10828 # define MY_DBL_MAX_BUG MY_DBL_MAX
10832 # define MY_DBL_MIN DBL_MIN
10833 # else /* XXX guessing! -Allen */
10834 # if DOUBLESIZE >= 8
10835 # define MY_DBL_MIN 2.2250738585072014E-308L
10837 # define MY_DBL_MIN 1.17549435E-38L
10841 if ((intsize == 'q') && (c == 'f') &&
10842 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10843 (need < DBL_DIG)) {
10844 /* it's going to be short enough that
10845 * long double precision is not needed */
10847 if ((nv <= 0L) && (nv >= -0L))
10848 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10850 /* would use Perl_fp_class as a double-check but not
10851 * functional on IRIX - see perl.h comments */
10853 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10854 /* It's within the range that a double can represent */
10855 #if defined(DBL_MAX) && !defined(DBL_MIN)
10856 if ((nv >= ((long double)1/DBL_MAX)) ||
10857 (nv <= (-(long double)1/DBL_MAX)))
10859 fix_ldbl_sprintf_bug = TRUE;
10862 if (fix_ldbl_sprintf_bug == TRUE) {
10872 # undef MY_DBL_MAX_BUG
10875 #endif /* HAS_LDBL_SPRINTF_BUG */
10877 need += 20; /* fudge factor */
10878 if (PL_efloatsize < need) {
10879 Safefree(PL_efloatbuf);
10880 PL_efloatsize = need + 20; /* more fudge */
10881 Newx(PL_efloatbuf, PL_efloatsize, char);
10882 PL_efloatbuf[0] = '\0';
10885 if ( !(width || left || plus || alt) && fill != '0'
10886 && has_precis && intsize != 'q' ) { /* Shortcuts */
10887 /* See earlier comment about buggy Gconvert when digits,
10889 if ( c == 'g' && precis) {
10890 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10891 /* May return an empty string for digits==0 */
10892 if (*PL_efloatbuf) {
10893 elen = strlen(PL_efloatbuf);
10894 goto float_converted;
10896 } else if ( c == 'f' && !precis) {
10897 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10902 char *ptr = ebuf + sizeof ebuf;
10905 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10906 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10907 if (intsize == 'q') {
10908 /* Copy the one or more characters in a long double
10909 * format before the 'base' ([efgEFG]) character to
10910 * the format string. */
10911 static char const prifldbl[] = PERL_PRIfldbl;
10912 char const *p = prifldbl + sizeof(prifldbl) - 3;
10913 while (p >= prifldbl) { *--ptr = *p--; }
10918 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10923 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10935 /* No taint. Otherwise we are in the strange situation
10936 * where printf() taints but print($float) doesn't.
10938 #if defined(HAS_LONG_DOUBLE)
10939 elen = ((intsize == 'q')
10940 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
10941 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
10943 elen = my_sprintf(PL_efloatbuf, ptr, nv);
10947 eptr = PL_efloatbuf;
10955 i = SvCUR(sv) - origlen;
10958 case 'c': *(va_arg(*args, char*)) = i; break;
10959 case 'h': *(va_arg(*args, short*)) = i; break;
10960 default: *(va_arg(*args, int*)) = i; break;
10961 case 'l': *(va_arg(*args, long*)) = i; break;
10962 case 'V': *(va_arg(*args, IV*)) = i; break;
10963 case 'z': *(va_arg(*args, SSize_t*)) = i; break;
10964 case 't': *(va_arg(*args, ptrdiff_t*)) = i; break;
10966 case 'j': *(va_arg(*args, intmax_t*)) = i; break;
10970 *(va_arg(*args, Quad_t*)) = i; break;
10977 sv_setuv_mg(argsv, (UV)i);
10978 continue; /* not "break" */
10985 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
10986 && ckWARN(WARN_PRINTF))
10988 SV * const msg = sv_newmortal();
10989 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10990 (PL_op->op_type == OP_PRTF) ? "" : "s");
10991 if (fmtstart < patend) {
10992 const char * const fmtend = q < patend ? q : patend;
10994 sv_catpvs(msg, "\"%");
10995 for (f = fmtstart; f < fmtend; f++) {
10997 sv_catpvn(msg, f, 1);
10999 Perl_sv_catpvf(aTHX_ msg,
11000 "\\%03"UVof, (UV)*f & 0xFF);
11003 sv_catpvs(msg, "\"");
11005 sv_catpvs(msg, "end of string");
11007 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
11010 /* output mangled stuff ... */
11016 /* ... right here, because formatting flags should not apply */
11017 SvGROW(sv, SvCUR(sv) + elen + 1);
11019 Copy(eptr, p, elen, char);
11022 SvCUR_set(sv, p - SvPVX_const(sv));
11024 continue; /* not "break" */
11027 if (is_utf8 != has_utf8) {
11030 sv_utf8_upgrade(sv);
11033 const STRLEN old_elen = elen;
11034 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
11035 sv_utf8_upgrade(nsv);
11036 eptr = SvPVX_const(nsv);
11039 if (width) { /* fudge width (can't fudge elen) */
11040 width += elen - old_elen;
11046 have = esignlen + zeros + elen;
11048 Perl_croak_nocontext("%s", PL_memory_wrap);
11050 need = (have > width ? have : width);
11053 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
11054 Perl_croak_nocontext("%s", PL_memory_wrap);
11055 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
11057 if (esignlen && fill == '0') {
11059 for (i = 0; i < (int)esignlen; i++)
11060 *p++ = esignbuf[i];
11062 if (gap && !left) {
11063 memset(p, fill, gap);
11066 if (esignlen && fill != '0') {
11068 for (i = 0; i < (int)esignlen; i++)
11069 *p++ = esignbuf[i];
11073 for (i = zeros; i; i--)
11077 Copy(eptr, p, elen, char);
11081 memset(p, ' ', gap);
11086 Copy(dotstr, p, dotstrlen, char);
11090 vectorize = FALSE; /* done iterating over vecstr */
11097 SvCUR_set(sv, p - SvPVX_const(sv));
11106 /* =========================================================================
11108 =head1 Cloning an interpreter
11110 All the macros and functions in this section are for the private use of
11111 the main function, perl_clone().
11113 The foo_dup() functions make an exact copy of an existing foo thingy.
11114 During the course of a cloning, a hash table is used to map old addresses
11115 to new addresses. The table is created and manipulated with the
11116 ptr_table_* functions.
11120 * =========================================================================*/
11123 #if defined(USE_ITHREADS)
11125 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
11126 #ifndef GpREFCNT_inc
11127 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
11131 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
11132 that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
11133 If this changes, please unmerge ss_dup.
11134 Likewise, sv_dup_inc_multiple() relies on this fact. */
11135 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup_inc(s,t))
11136 #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
11137 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
11138 #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
11139 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
11140 #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
11141 #define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t))
11142 #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
11143 #define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t))
11144 #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
11145 #define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t))
11146 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
11147 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
11149 /* clone a parser */
11152 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
11156 PERL_ARGS_ASSERT_PARSER_DUP;
11161 /* look for it in the table first */
11162 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
11166 /* create anew and remember what it is */
11167 Newxz(parser, 1, yy_parser);
11168 ptr_table_store(PL_ptr_table, proto, parser);
11170 /* XXX these not yet duped */
11171 parser->old_parser = NULL;
11172 parser->stack = NULL;
11174 parser->stack_size = 0;
11175 /* XXX parser->stack->state = 0; */
11177 /* XXX eventually, just Copy() most of the parser struct ? */
11179 parser->lex_brackets = proto->lex_brackets;
11180 parser->lex_casemods = proto->lex_casemods;
11181 parser->lex_brackstack = savepvn(proto->lex_brackstack,
11182 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
11183 parser->lex_casestack = savepvn(proto->lex_casestack,
11184 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
11185 parser->lex_defer = proto->lex_defer;
11186 parser->lex_dojoin = proto->lex_dojoin;
11187 parser->lex_expect = proto->lex_expect;
11188 parser->lex_formbrack = proto->lex_formbrack;
11189 parser->lex_inpat = proto->lex_inpat;
11190 parser->lex_inwhat = proto->lex_inwhat;
11191 parser->lex_op = proto->lex_op;
11192 parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
11193 parser->lex_starts = proto->lex_starts;
11194 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
11195 parser->multi_close = proto->multi_close;
11196 parser->multi_open = proto->multi_open;
11197 parser->multi_start = proto->multi_start;
11198 parser->multi_end = proto->multi_end;
11199 parser->pending_ident = proto->pending_ident;
11200 parser->preambled = proto->preambled;
11201 parser->sublex_info = proto->sublex_info; /* XXX not quite right */
11202 parser->linestr = sv_dup_inc(proto->linestr, param);
11203 parser->expect = proto->expect;
11204 parser->copline = proto->copline;
11205 parser->last_lop_op = proto->last_lop_op;
11206 parser->lex_state = proto->lex_state;
11207 parser->rsfp = fp_dup(proto->rsfp, '<', param);
11208 /* rsfp_filters entries have fake IoDIRP() */
11209 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
11210 parser->in_my = proto->in_my;
11211 parser->in_my_stash = hv_dup(proto->in_my_stash, param);
11212 parser->error_count = proto->error_count;
11215 parser->linestr = sv_dup_inc(proto->linestr, param);
11218 char * const ols = SvPVX(proto->linestr);
11219 char * const ls = SvPVX(parser->linestr);
11221 parser->bufptr = ls + (proto->bufptr >= ols ?
11222 proto->bufptr - ols : 0);
11223 parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
11224 proto->oldbufptr - ols : 0);
11225 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
11226 proto->oldoldbufptr - ols : 0);
11227 parser->linestart = ls + (proto->linestart >= ols ?
11228 proto->linestart - ols : 0);
11229 parser->last_uni = ls + (proto->last_uni >= ols ?
11230 proto->last_uni - ols : 0);
11231 parser->last_lop = ls + (proto->last_lop >= ols ?
11232 proto->last_lop - ols : 0);
11234 parser->bufend = ls + SvCUR(parser->linestr);
11237 Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
11241 parser->endwhite = proto->endwhite;
11242 parser->faketokens = proto->faketokens;
11243 parser->lasttoke = proto->lasttoke;
11244 parser->nextwhite = proto->nextwhite;
11245 parser->realtokenstart = proto->realtokenstart;
11246 parser->skipwhite = proto->skipwhite;
11247 parser->thisclose = proto->thisclose;
11248 parser->thismad = proto->thismad;
11249 parser->thisopen = proto->thisopen;
11250 parser->thisstuff = proto->thisstuff;
11251 parser->thistoken = proto->thistoken;
11252 parser->thiswhite = proto->thiswhite;
11254 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
11255 parser->curforce = proto->curforce;
11257 Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
11258 Copy(proto->nexttype, parser->nexttype, 5, I32);
11259 parser->nexttoke = proto->nexttoke;
11262 /* XXX should clone saved_curcop here, but we aren't passed
11263 * proto_perl; so do it in perl_clone_using instead */
11269 /* duplicate a file handle */
11272 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
11276 PERL_ARGS_ASSERT_FP_DUP;
11277 PERL_UNUSED_ARG(type);
11280 return (PerlIO*)NULL;
11282 /* look for it in the table first */
11283 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
11287 /* create anew and remember what it is */
11288 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
11289 ptr_table_store(PL_ptr_table, fp, ret);
11293 /* duplicate a directory handle */
11296 Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
11302 register const Direntry_t *dirent;
11303 char smallbuf[256];
11309 PERL_UNUSED_CONTEXT;
11310 PERL_ARGS_ASSERT_DIRP_DUP;
11315 /* look for it in the table first */
11316 ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
11322 PERL_UNUSED_ARG(param);
11326 /* open the current directory (so we can switch back) */
11327 if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
11329 /* chdir to our dir handle and open the present working directory */
11330 if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
11331 PerlDir_close(pwd);
11332 return (DIR *)NULL;
11334 /* Now we should have two dir handles pointing to the same dir. */
11336 /* Be nice to the calling code and chdir back to where we were. */
11337 fchdir(my_dirfd(pwd)); /* If this fails, then what? */
11339 /* We have no need of the pwd handle any more. */
11340 PerlDir_close(pwd);
11343 # define d_namlen(d) (d)->d_namlen
11345 # define d_namlen(d) strlen((d)->d_name)
11347 /* Iterate once through dp, to get the file name at the current posi-
11348 tion. Then step back. */
11349 pos = PerlDir_tell(dp);
11350 if ((dirent = PerlDir_read(dp))) {
11351 len = d_namlen(dirent);
11352 if (len <= sizeof smallbuf) name = smallbuf;
11353 else Newx(name, len, char);
11354 Move(dirent->d_name, name, len, char);
11356 PerlDir_seek(dp, pos);
11358 /* Iterate through the new dir handle, till we find a file with the
11360 if (!dirent) /* just before the end */
11362 pos = PerlDir_tell(ret);
11363 if (PerlDir_read(ret)) continue; /* not there yet */
11364 PerlDir_seek(ret, pos); /* step back */
11368 const long pos0 = PerlDir_tell(ret);
11370 pos = PerlDir_tell(ret);
11371 if ((dirent = PerlDir_read(ret))) {
11372 if (len == d_namlen(dirent)
11373 && memEQ(name, dirent->d_name, len)) {
11375 PerlDir_seek(ret, pos); /* step back */
11378 /* else we are not there yet; keep iterating */
11380 else { /* This is not meant to happen. The best we can do is
11381 reset the iterator to the beginning. */
11382 PerlDir_seek(ret, pos0);
11389 if (name && name != smallbuf)
11394 ret = win32_dirp_dup(dp, param);
11397 /* pop it in the pointer table */
11399 ptr_table_store(PL_ptr_table, dp, ret);
11404 /* duplicate a typeglob */
11407 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
11411 PERL_ARGS_ASSERT_GP_DUP;
11415 /* look for it in the table first */
11416 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
11420 /* create anew and remember what it is */
11422 ptr_table_store(PL_ptr_table, gp, ret);
11425 /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
11426 on Newxz() to do this for us. */
11427 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
11428 ret->gp_io = io_dup_inc(gp->gp_io, param);
11429 ret->gp_form = cv_dup_inc(gp->gp_form, param);
11430 ret->gp_av = av_dup_inc(gp->gp_av, param);
11431 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
11432 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
11433 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
11434 ret->gp_cvgen = gp->gp_cvgen;
11435 ret->gp_line = gp->gp_line;
11436 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
11440 /* duplicate a chain of magic */
11443 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
11445 MAGIC *mgret = NULL;
11446 MAGIC **mgprev_p = &mgret;
11448 PERL_ARGS_ASSERT_MG_DUP;
11450 for (; mg; mg = mg->mg_moremagic) {
11453 if ((param->flags & CLONEf_JOIN_IN)
11454 && mg->mg_type == PERL_MAGIC_backref)
11455 /* when joining, we let the individual SVs add themselves to
11456 * backref as needed. */
11459 Newx(nmg, 1, MAGIC);
11461 mgprev_p = &(nmg->mg_moremagic);
11463 /* There was a comment "XXX copy dynamic vtable?" but as we don't have
11464 dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
11465 from the original commit adding Perl_mg_dup() - revision 4538.
11466 Similarly there is the annotation "XXX random ptr?" next to the
11467 assignment to nmg->mg_ptr. */
11470 /* FIXME for plugins
11471 if (nmg->mg_type == PERL_MAGIC_qr) {
11472 nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
11476 nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
11477 ? nmg->mg_type == PERL_MAGIC_backref
11478 /* The backref AV has its reference
11479 * count deliberately bumped by 1 */
11480 ? SvREFCNT_inc(av_dup_inc((const AV *)
11481 nmg->mg_obj, param))
11482 : sv_dup_inc(nmg->mg_obj, param)
11483 : sv_dup(nmg->mg_obj, param);
11485 if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
11486 if (nmg->mg_len > 0) {
11487 nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
11488 if (nmg->mg_type == PERL_MAGIC_overload_table &&
11489 AMT_AMAGIC((AMT*)nmg->mg_ptr))
11491 AMT * const namtp = (AMT*)nmg->mg_ptr;
11492 sv_dup_inc_multiple((SV**)(namtp->table),
11493 (SV**)(namtp->table), NofAMmeth, param);
11496 else if (nmg->mg_len == HEf_SVKEY)
11497 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
11499 if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
11500 nmg->mg_virtual->svt_dup(aTHX_ nmg, param);
11506 #endif /* USE_ITHREADS */
11508 struct ptr_tbl_arena {
11509 struct ptr_tbl_arena *next;
11510 struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */
11513 /* create a new pointer-mapping table */
11516 Perl_ptr_table_new(pTHX)
11519 PERL_UNUSED_CONTEXT;
11521 Newx(tbl, 1, PTR_TBL_t);
11522 tbl->tbl_max = 511;
11523 tbl->tbl_items = 0;
11524 tbl->tbl_arena = NULL;
11525 tbl->tbl_arena_next = NULL;
11526 tbl->tbl_arena_end = NULL;
11527 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
11531 #define PTR_TABLE_HASH(ptr) \
11532 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
11534 /* map an existing pointer using a table */
11536 STATIC PTR_TBL_ENT_t *
11537 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
11539 PTR_TBL_ENT_t *tblent;
11540 const UV hash = PTR_TABLE_HASH(sv);
11542 PERL_ARGS_ASSERT_PTR_TABLE_FIND;
11544 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
11545 for (; tblent; tblent = tblent->next) {
11546 if (tblent->oldval == sv)
11553 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
11555 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
11557 PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
11558 PERL_UNUSED_CONTEXT;
11560 return tblent ? tblent->newval : NULL;
11563 /* add a new entry to a pointer-mapping table */
11566 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
11568 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
11570 PERL_ARGS_ASSERT_PTR_TABLE_STORE;
11571 PERL_UNUSED_CONTEXT;
11574 tblent->newval = newsv;
11576 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
11578 if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
11579 struct ptr_tbl_arena *new_arena;
11581 Newx(new_arena, 1, struct ptr_tbl_arena);
11582 new_arena->next = tbl->tbl_arena;
11583 tbl->tbl_arena = new_arena;
11584 tbl->tbl_arena_next = new_arena->array;
11585 tbl->tbl_arena_end = new_arena->array
11586 + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
11589 tblent = tbl->tbl_arena_next++;
11591 tblent->oldval = oldsv;
11592 tblent->newval = newsv;
11593 tblent->next = tbl->tbl_ary[entry];
11594 tbl->tbl_ary[entry] = tblent;
11596 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
11597 ptr_table_split(tbl);
11601 /* double the hash bucket size of an existing ptr table */
11604 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
11606 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
11607 const UV oldsize = tbl->tbl_max + 1;
11608 UV newsize = oldsize * 2;
11611 PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
11612 PERL_UNUSED_CONTEXT;
11614 Renew(ary, newsize, PTR_TBL_ENT_t*);
11615 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
11616 tbl->tbl_max = --newsize;
11617 tbl->tbl_ary = ary;
11618 for (i=0; i < oldsize; i++, ary++) {
11619 PTR_TBL_ENT_t **entp = ary;
11620 PTR_TBL_ENT_t *ent = *ary;
11621 PTR_TBL_ENT_t **curentp;
11624 curentp = ary + oldsize;
11626 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
11628 ent->next = *curentp;
11638 /* remove all the entries from a ptr table */
11639 /* Deprecated - will be removed post 5.14 */
11642 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
11644 if (tbl && tbl->tbl_items) {
11645 struct ptr_tbl_arena *arena = tbl->tbl_arena;
11647 Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
11650 struct ptr_tbl_arena *next = arena->next;
11656 tbl->tbl_items = 0;
11657 tbl->tbl_arena = NULL;
11658 tbl->tbl_arena_next = NULL;
11659 tbl->tbl_arena_end = NULL;
11663 /* clear and free a ptr table */
11666 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
11668 struct ptr_tbl_arena *arena;
11674 arena = tbl->tbl_arena;
11677 struct ptr_tbl_arena *next = arena->next;
11683 Safefree(tbl->tbl_ary);
11687 #if defined(USE_ITHREADS)
11690 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
11692 PERL_ARGS_ASSERT_RVPV_DUP;
11695 if (SvWEAKREF(sstr)) {
11696 SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
11697 if (param->flags & CLONEf_JOIN_IN) {
11698 /* if joining, we add any back references individually rather
11699 * than copying the whole backref array */
11700 Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
11704 SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
11706 else if (SvPVX_const(sstr)) {
11707 /* Has something there */
11709 /* Normal PV - clone whole allocated space */
11710 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
11711 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
11712 /* Not that normal - actually sstr is copy on write.
11713 But we are a true, independent SV, so: */
11714 SvREADONLY_off(dstr);
11719 /* Special case - not normally malloced for some reason */
11720 if (isGV_with_GP(sstr)) {
11721 /* Don't need to do anything here. */
11723 else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
11724 /* A "shared" PV - clone it as "shared" PV */
11726 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
11730 /* Some other special case - random pointer */
11731 SvPV_set(dstr, (char *) SvPVX_const(sstr));
11736 /* Copy the NULL */
11737 SvPV_set(dstr, NULL);
11741 /* duplicate a list of SVs. source and dest may point to the same memory. */
11743 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
11744 SSize_t items, CLONE_PARAMS *const param)
11746 PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
11748 while (items-- > 0) {
11749 *dest++ = sv_dup_inc(*source++, param);
11755 /* duplicate an SV of any type (including AV, HV etc) */
11758 S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11763 PERL_ARGS_ASSERT_SV_DUP_COMMON;
11765 if (SvTYPE(sstr) == SVTYPEMASK) {
11766 #ifdef DEBUG_LEAKING_SCALARS_ABORT
11771 /* look for it in the table first */
11772 dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
11776 if(param->flags & CLONEf_JOIN_IN) {
11777 /** We are joining here so we don't want do clone
11778 something that is bad **/
11779 if (SvTYPE(sstr) == SVt_PVHV) {
11780 const HEK * const hvname = HvNAME_HEK(sstr);
11782 /** don't clone stashes if they already exist **/
11783 dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
11784 ptr_table_store(PL_ptr_table, sstr, dstr);
11790 /* create anew and remember what it is */
11793 #ifdef DEBUG_LEAKING_SCALARS
11794 dstr->sv_debug_optype = sstr->sv_debug_optype;
11795 dstr->sv_debug_line = sstr->sv_debug_line;
11796 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
11797 dstr->sv_debug_parent = (SV*)sstr;
11798 FREE_SV_DEBUG_FILE(dstr);
11799 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
11802 ptr_table_store(PL_ptr_table, sstr, dstr);
11805 SvFLAGS(dstr) = SvFLAGS(sstr);
11806 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
11807 SvREFCNT(dstr) = 0; /* must be before any other dups! */
11810 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
11811 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
11812 (void*)PL_watch_pvx, SvPVX_const(sstr));
11815 /* don't clone objects whose class has asked us not to */
11816 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
11821 switch (SvTYPE(sstr)) {
11823 SvANY(dstr) = NULL;
11826 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
11828 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11830 SvIV_set(dstr, SvIVX(sstr));
11834 SvANY(dstr) = new_XNV();
11835 SvNV_set(dstr, SvNVX(sstr));
11837 /* case SVt_BIND: */
11840 /* These are all the types that need complex bodies allocating. */
11842 const svtype sv_type = SvTYPE(sstr);
11843 const struct body_details *const sv_type_details
11844 = bodies_by_type + sv_type;
11848 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11863 assert(sv_type_details->body_size);
11864 if (sv_type_details->arena) {
11865 new_body_inline(new_body, sv_type);
11867 = (void*)((char*)new_body - sv_type_details->offset);
11869 new_body = new_NOARENA(sv_type_details);
11873 SvANY(dstr) = new_body;
11876 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
11877 ((char*)SvANY(dstr)) + sv_type_details->offset,
11878 sv_type_details->copy, char);
11880 Copy(((char*)SvANY(sstr)),
11881 ((char*)SvANY(dstr)),
11882 sv_type_details->body_size + sv_type_details->offset, char);
11885 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
11886 && !isGV_with_GP(dstr)
11887 && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
11888 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11890 /* The Copy above means that all the source (unduplicated) pointers
11891 are now in the destination. We can check the flags and the
11892 pointers in either, but it's possible that there's less cache
11893 missing by always going for the destination.
11894 FIXME - instrument and check that assumption */
11895 if (sv_type >= SVt_PVMG) {
11896 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
11897 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
11898 } else if (SvMAGIC(dstr))
11899 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
11901 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
11904 /* The cast silences a GCC warning about unhandled types. */
11905 switch ((int)sv_type) {
11915 /* FIXME for plugins */
11916 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
11919 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
11920 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
11921 LvTARG(dstr) = dstr;
11922 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
11923 LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
11925 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
11927 /* non-GP case already handled above */
11928 if(isGV_with_GP(sstr)) {
11929 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
11930 /* Don't call sv_add_backref here as it's going to be
11931 created as part of the magic cloning of the symbol
11932 table--unless this is during a join and the stash
11933 is not actually being cloned. */
11934 /* Danger Will Robinson - GvGP(dstr) isn't initialised
11935 at the point of this comment. */
11936 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
11937 if (param->flags & CLONEf_JOIN_IN)
11938 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
11939 GvGP_set(dstr, gp_dup(GvGP(sstr), param));
11940 (void)GpREFCNT_inc(GvGP(dstr));
11944 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
11945 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
11946 /* I have no idea why fake dirp (rsfps)
11947 should be treated differently but otherwise
11948 we end up with leaks -- sky*/
11949 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
11950 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
11951 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
11953 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
11954 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
11955 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
11956 if (IoDIRP(dstr)) {
11957 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr), param);
11960 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
11962 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param);
11964 if (IoOFP(dstr) == IoIFP(sstr))
11965 IoOFP(dstr) = IoIFP(dstr);
11967 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
11968 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
11969 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
11970 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
11973 /* avoid cloning an empty array */
11974 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
11975 SV **dst_ary, **src_ary;
11976 SSize_t items = AvFILLp((const AV *)sstr) + 1;
11978 src_ary = AvARRAY((const AV *)sstr);
11979 Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
11980 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
11981 AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
11982 AvALLOC((const AV *)dstr) = dst_ary;
11983 if (AvREAL((const AV *)sstr)) {
11984 dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
11988 while (items-- > 0)
11989 *dst_ary++ = sv_dup(*src_ary++, param);
11991 items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
11992 while (items-- > 0) {
11993 *dst_ary++ = &PL_sv_undef;
11997 AvARRAY(MUTABLE_AV(dstr)) = NULL;
11998 AvALLOC((const AV *)dstr) = (SV**)NULL;
11999 AvMAX( (const AV *)dstr) = -1;
12000 AvFILLp((const AV *)dstr) = -1;
12004 if (HvARRAY((const HV *)sstr)) {
12006 const bool sharekeys = !!HvSHAREKEYS(sstr);
12007 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
12008 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
12010 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
12011 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
12013 HvARRAY(dstr) = (HE**)darray;
12014 while (i <= sxhv->xhv_max) {
12015 const HE * const source = HvARRAY(sstr)[i];
12016 HvARRAY(dstr)[i] = source
12017 ? he_dup(source, sharekeys, param) : 0;
12021 const struct xpvhv_aux * const saux = HvAUX(sstr);
12022 struct xpvhv_aux * const daux = HvAUX(dstr);
12023 /* This flag isn't copied. */
12024 /* SvOOK_on(hv) attacks the IV flags. */
12025 SvFLAGS(dstr) |= SVf_OOK;
12027 if (saux->xhv_name_count) {
12028 HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
12030 = saux->xhv_name_count < 0
12031 ? -saux->xhv_name_count
12032 : saux->xhv_name_count;
12033 HEK **shekp = sname + count;
12035 Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *);
12036 dhekp = daux->xhv_name_u.xhvnameu_names + count;
12037 while (shekp-- > sname) {
12039 *dhekp = hek_dup(*shekp, param);
12043 daux->xhv_name_u.xhvnameu_name
12044 = hek_dup(saux->xhv_name_u.xhvnameu_name,
12047 daux->xhv_name_count = saux->xhv_name_count;
12049 daux->xhv_riter = saux->xhv_riter;
12050 daux->xhv_eiter = saux->xhv_eiter
12051 ? he_dup(saux->xhv_eiter,
12052 cBOOL(HvSHAREKEYS(sstr)), param) : 0;
12053 /* backref array needs refcnt=2; see sv_add_backref */
12054 daux->xhv_backreferences =
12055 (param->flags & CLONEf_JOIN_IN)
12056 /* when joining, we let the individual GVs and
12057 * CVs add themselves to backref as
12058 * needed. This avoids pulling in stuff
12059 * that isn't required, and simplifies the
12060 * case where stashes aren't cloned back
12061 * if they already exist in the parent
12064 : saux->xhv_backreferences
12065 ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
12066 ? MUTABLE_AV(SvREFCNT_inc(
12067 sv_dup_inc((const SV *)
12068 saux->xhv_backreferences, param)))
12069 : MUTABLE_AV(sv_dup((const SV *)
12070 saux->xhv_backreferences, param))
12073 daux->xhv_mro_meta = saux->xhv_mro_meta
12074 ? mro_meta_dup(saux->xhv_mro_meta, param)
12077 /* Record stashes for possible cloning in Perl_clone(). */
12079 av_push(param->stashes, dstr);
12083 HvARRAY(MUTABLE_HV(dstr)) = NULL;
12086 if (!(param->flags & CLONEf_COPY_STACKS)) {
12091 /* NOTE: not refcounted */
12092 SvANY(MUTABLE_CV(dstr))->xcv_stash =
12093 hv_dup(CvSTASH(dstr), param);
12094 if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
12095 Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
12096 if (!CvISXSUB(dstr)) {
12098 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
12100 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
12101 } else if (CvCONST(dstr)) {
12102 CvXSUBANY(dstr).any_ptr =
12103 sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
12105 /* don't dup if copying back - CvGV isn't refcounted, so the
12106 * duped GV may never be freed. A bit of a hack! DAPM */
12107 SvANY(MUTABLE_CV(dstr))->xcv_gv =
12109 ? gv_dup_inc(CvGV(sstr), param)
12110 : (param->flags & CLONEf_JOIN_IN)
12112 : gv_dup(CvGV(sstr), param);
12114 CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
12116 CvWEAKOUTSIDE(sstr)
12117 ? cv_dup( CvOUTSIDE(dstr), param)
12118 : cv_dup_inc(CvOUTSIDE(dstr), param);
12124 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
12131 Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12133 PERL_ARGS_ASSERT_SV_DUP_INC;
12134 return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
12138 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12140 SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
12141 PERL_ARGS_ASSERT_SV_DUP;
12143 /* Track every SV that (at least initially) had a reference count of 0.
12144 We need to do this by holding an actual reference to it in this array.
12145 If we attempt to cheat, turn AvREAL_off(), and store only pointers
12146 (akin to the stashes hash, and the perl stack), we come unstuck if
12147 a weak reference (or other SV legitimately SvREFCNT() == 0 for this
12148 thread) is manipulated in a CLONE method, because CLONE runs before the
12149 unreferenced array is walked to find SVs still with SvREFCNT() == 0
12150 (and fix things up by giving each a reference via the temps stack).
12151 Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
12152 then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
12153 before the walk of unreferenced happens and a reference to that is SV
12154 added to the temps stack. At which point we have the same SV considered
12155 to be in use, and free to be re-used. Not good.
12157 if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
12158 assert(param->unreferenced);
12159 av_push(param->unreferenced, SvREFCNT_inc(dstr));
12165 /* duplicate a context */
12168 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
12170 PERL_CONTEXT *ncxs;
12172 PERL_ARGS_ASSERT_CX_DUP;
12175 return (PERL_CONTEXT*)NULL;
12177 /* look for it in the table first */
12178 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
12182 /* create anew and remember what it is */
12183 Newx(ncxs, max + 1, PERL_CONTEXT);
12184 ptr_table_store(PL_ptr_table, cxs, ncxs);
12185 Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
12188 PERL_CONTEXT * const ncx = &ncxs[ix];
12189 if (CxTYPE(ncx) == CXt_SUBST) {
12190 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
12193 switch (CxTYPE(ncx)) {
12195 ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
12196 ? cv_dup_inc(ncx->blk_sub.cv, param)
12197 : cv_dup(ncx->blk_sub.cv,param));
12198 ncx->blk_sub.argarray = (CxHASARGS(ncx)
12199 ? av_dup_inc(ncx->blk_sub.argarray,
12202 ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
12204 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
12205 ncx->blk_sub.oldcomppad);
12208 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
12210 ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
12212 case CXt_LOOP_LAZYSV:
12213 ncx->blk_loop.state_u.lazysv.end
12214 = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
12215 /* We are taking advantage of av_dup_inc and sv_dup_inc
12216 actually being the same function, and order equivalence of
12218 We can assert the later [but only at run time :-(] */
12219 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
12220 (void *) &ncx->blk_loop.state_u.lazysv.cur);
12222 ncx->blk_loop.state_u.ary.ary
12223 = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
12224 case CXt_LOOP_LAZYIV:
12225 case CXt_LOOP_PLAIN:
12226 if (CxPADLOOP(ncx)) {
12227 ncx->blk_loop.itervar_u.oldcomppad
12228 = (PAD*)ptr_table_fetch(PL_ptr_table,
12229 ncx->blk_loop.itervar_u.oldcomppad);
12231 ncx->blk_loop.itervar_u.gv
12232 = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
12237 ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
12238 ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
12239 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
12252 /* duplicate a stack info structure */
12255 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
12259 PERL_ARGS_ASSERT_SI_DUP;
12262 return (PERL_SI*)NULL;
12264 /* look for it in the table first */
12265 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
12269 /* create anew and remember what it is */
12270 Newxz(nsi, 1, PERL_SI);
12271 ptr_table_store(PL_ptr_table, si, nsi);
12273 nsi->si_stack = av_dup_inc(si->si_stack, param);
12274 nsi->si_cxix = si->si_cxix;
12275 nsi->si_cxmax = si->si_cxmax;
12276 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
12277 nsi->si_type = si->si_type;
12278 nsi->si_prev = si_dup(si->si_prev, param);
12279 nsi->si_next = si_dup(si->si_next, param);
12280 nsi->si_markoff = si->si_markoff;
12285 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
12286 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
12287 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
12288 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
12289 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
12290 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
12291 #define POPUV(ss,ix) ((ss)[--(ix)].any_uv)
12292 #define TOPUV(ss,ix) ((ss)[ix].any_uv)
12293 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
12294 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
12295 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
12296 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
12297 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
12298 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
12299 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
12300 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
12303 #define pv_dup_inc(p) SAVEPV(p)
12304 #define pv_dup(p) SAVEPV(p)
12305 #define svp_dup_inc(p,pp) any_dup(p,pp)
12307 /* map any object to the new equivent - either something in the
12308 * ptr table, or something in the interpreter structure
12312 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
12316 PERL_ARGS_ASSERT_ANY_DUP;
12319 return (void*)NULL;
12321 /* look for it in the table first */
12322 ret = ptr_table_fetch(PL_ptr_table, v);
12326 /* see if it is part of the interpreter structure */
12327 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
12328 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
12336 /* duplicate the save stack */
12339 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
12342 ANY * const ss = proto_perl->Isavestack;
12343 const I32 max = proto_perl->Isavestack_max;
12344 I32 ix = proto_perl->Isavestack_ix;
12357 void (*dptr) (void*);
12358 void (*dxptr) (pTHX_ void*);
12360 PERL_ARGS_ASSERT_SS_DUP;
12362 Newxz(nss, max, ANY);
12365 const UV uv = POPUV(ss,ix);
12366 const U8 type = (U8)uv & SAVE_MASK;
12368 TOPUV(nss,ix) = uv;
12370 case SAVEt_CLEARSV:
12372 case SAVEt_HELEM: /* hash element */
12373 sv = (const SV *)POPPTR(ss,ix);
12374 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12376 case SAVEt_ITEM: /* normal string */
12377 case SAVEt_GVSV: /* scalar slot in GV */
12378 case SAVEt_SV: /* scalar reference */
12379 sv = (const SV *)POPPTR(ss,ix);
12380 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12383 case SAVEt_MORTALIZESV:
12384 sv = (const SV *)POPPTR(ss,ix);
12385 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12387 case SAVEt_SHARED_PVREF: /* char* in shared space */
12388 c = (char*)POPPTR(ss,ix);
12389 TOPPTR(nss,ix) = savesharedpv(c);
12390 ptr = POPPTR(ss,ix);
12391 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12393 case SAVEt_GENERIC_SVREF: /* generic sv */
12394 case SAVEt_SVREF: /* scalar reference */
12395 sv = (const SV *)POPPTR(ss,ix);
12396 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12397 ptr = POPPTR(ss,ix);
12398 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
12400 case SAVEt_HV: /* hash reference */
12401 case SAVEt_AV: /* array reference */
12402 sv = (const SV *) POPPTR(ss,ix);
12403 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12405 case SAVEt_COMPPAD:
12407 sv = (const SV *) POPPTR(ss,ix);
12408 TOPPTR(nss,ix) = sv_dup(sv, param);
12410 case SAVEt_INT: /* int reference */
12411 ptr = POPPTR(ss,ix);
12412 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12413 intval = (int)POPINT(ss,ix);
12414 TOPINT(nss,ix) = intval;
12416 case SAVEt_LONG: /* long reference */
12417 ptr = POPPTR(ss,ix);
12418 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12419 longval = (long)POPLONG(ss,ix);
12420 TOPLONG(nss,ix) = longval;
12422 case SAVEt_I32: /* I32 reference */
12423 case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
12424 ptr = POPPTR(ss,ix);
12425 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12427 TOPINT(nss,ix) = i;
12429 case SAVEt_IV: /* IV reference */
12430 ptr = POPPTR(ss,ix);
12431 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12433 TOPIV(nss,ix) = iv;
12435 case SAVEt_HPTR: /* HV* reference */
12436 case SAVEt_APTR: /* AV* reference */
12437 case SAVEt_SPTR: /* SV* reference */
12438 ptr = POPPTR(ss,ix);
12439 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12440 sv = (const SV *)POPPTR(ss,ix);
12441 TOPPTR(nss,ix) = sv_dup(sv, param);
12443 case SAVEt_VPTR: /* random* reference */
12444 ptr = POPPTR(ss,ix);
12445 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12447 case SAVEt_INT_SMALL:
12448 case SAVEt_I32_SMALL:
12449 case SAVEt_I16: /* I16 reference */
12450 case SAVEt_I8: /* I8 reference */
12452 ptr = POPPTR(ss,ix);
12453 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12455 case SAVEt_GENERIC_PVREF: /* generic char* */
12456 case SAVEt_PPTR: /* char* reference */
12457 ptr = POPPTR(ss,ix);
12458 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12459 c = (char*)POPPTR(ss,ix);
12460 TOPPTR(nss,ix) = pv_dup(c);
12462 case SAVEt_GP: /* scalar reference */
12463 gp = (GP*)POPPTR(ss,ix);
12464 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
12465 (void)GpREFCNT_inc(gp);
12466 gv = (const GV *)POPPTR(ss,ix);
12467 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
12470 ptr = POPPTR(ss,ix);
12471 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
12472 /* these are assumed to be refcounted properly */
12474 switch (((OP*)ptr)->op_type) {
12476 case OP_LEAVESUBLV:
12480 case OP_LEAVEWRITE:
12481 TOPPTR(nss,ix) = ptr;
12484 (void) OpREFCNT_inc(o);
12488 TOPPTR(nss,ix) = NULL;
12493 TOPPTR(nss,ix) = NULL;
12495 case SAVEt_FREECOPHH:
12496 ptr = POPPTR(ss,ix);
12497 TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr);
12500 hv = (const HV *)POPPTR(ss,ix);
12501 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12503 TOPINT(nss,ix) = i;
12506 c = (char*)POPPTR(ss,ix);
12507 TOPPTR(nss,ix) = pv_dup_inc(c);
12509 case SAVEt_STACK_POS: /* Position on Perl stack */
12511 TOPINT(nss,ix) = i;
12513 case SAVEt_DESTRUCTOR:
12514 ptr = POPPTR(ss,ix);
12515 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
12516 dptr = POPDPTR(ss,ix);
12517 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
12518 any_dup(FPTR2DPTR(void *, dptr),
12521 case SAVEt_DESTRUCTOR_X:
12522 ptr = POPPTR(ss,ix);
12523 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
12524 dxptr = POPDXPTR(ss,ix);
12525 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
12526 any_dup(FPTR2DPTR(void *, dxptr),
12529 case SAVEt_REGCONTEXT:
12531 ix -= uv >> SAVE_TIGHT_SHIFT;
12533 case SAVEt_AELEM: /* array element */
12534 sv = (const SV *)POPPTR(ss,ix);
12535 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12537 TOPINT(nss,ix) = i;
12538 av = (const AV *)POPPTR(ss,ix);
12539 TOPPTR(nss,ix) = av_dup_inc(av, param);
12542 ptr = POPPTR(ss,ix);
12543 TOPPTR(nss,ix) = ptr;
12546 ptr = POPPTR(ss,ix);
12547 ptr = cophh_copy((COPHH*)ptr);
12548 TOPPTR(nss,ix) = ptr;
12550 TOPINT(nss,ix) = i;
12551 if (i & HINT_LOCALIZE_HH) {
12552 hv = (const HV *)POPPTR(ss,ix);
12553 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12556 case SAVEt_PADSV_AND_MORTALIZE:
12557 longval = (long)POPLONG(ss,ix);
12558 TOPLONG(nss,ix) = longval;
12559 ptr = POPPTR(ss,ix);
12560 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12561 sv = (const SV *)POPPTR(ss,ix);
12562 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12564 case SAVEt_SET_SVFLAGS:
12566 TOPINT(nss,ix) = i;
12568 TOPINT(nss,ix) = i;
12569 sv = (const SV *)POPPTR(ss,ix);
12570 TOPPTR(nss,ix) = sv_dup(sv, param);
12572 case SAVEt_RE_STATE:
12574 const struct re_save_state *const old_state
12575 = (struct re_save_state *)
12576 (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12577 struct re_save_state *const new_state
12578 = (struct re_save_state *)
12579 (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12581 Copy(old_state, new_state, 1, struct re_save_state);
12582 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
12584 new_state->re_state_bostr
12585 = pv_dup(old_state->re_state_bostr);
12586 new_state->re_state_reginput
12587 = pv_dup(old_state->re_state_reginput);
12588 new_state->re_state_regeol
12589 = pv_dup(old_state->re_state_regeol);
12590 new_state->re_state_regoffs
12591 = (regexp_paren_pair*)
12592 any_dup(old_state->re_state_regoffs, proto_perl);
12593 new_state->re_state_reglastparen
12594 = (U32*) any_dup(old_state->re_state_reglastparen,
12596 new_state->re_state_reglastcloseparen
12597 = (U32*)any_dup(old_state->re_state_reglastcloseparen,
12599 /* XXX This just has to be broken. The old save_re_context
12600 code did SAVEGENERICPV(PL_reg_start_tmp);
12601 PL_reg_start_tmp is char **.
12602 Look above to what the dup code does for
12603 SAVEt_GENERIC_PVREF
12604 It can never have worked.
12605 So this is merely a faithful copy of the exiting bug: */
12606 new_state->re_state_reg_start_tmp
12607 = (char **) pv_dup((char *)
12608 old_state->re_state_reg_start_tmp);
12609 /* I assume that it only ever "worked" because no-one called
12610 (pseudo)fork while the regexp engine had re-entered itself.
12612 #ifdef PERL_OLD_COPY_ON_WRITE
12613 new_state->re_state_nrs
12614 = sv_dup(old_state->re_state_nrs, param);
12616 new_state->re_state_reg_magic
12617 = (MAGIC*) any_dup(old_state->re_state_reg_magic,
12619 new_state->re_state_reg_oldcurpm
12620 = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
12622 new_state->re_state_reg_curpm
12623 = (PMOP*) any_dup(old_state->re_state_reg_curpm,
12625 new_state->re_state_reg_oldsaved
12626 = pv_dup(old_state->re_state_reg_oldsaved);
12627 new_state->re_state_reg_poscache
12628 = pv_dup(old_state->re_state_reg_poscache);
12629 new_state->re_state_reg_starttry
12630 = pv_dup(old_state->re_state_reg_starttry);
12633 case SAVEt_COMPILE_WARNINGS:
12634 ptr = POPPTR(ss,ix);
12635 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
12638 ptr = POPPTR(ss,ix);
12639 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
12643 "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
12651 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
12652 * flag to the result. This is done for each stash before cloning starts,
12653 * so we know which stashes want their objects cloned */
12656 do_mark_cloneable_stash(pTHX_ SV *const sv)
12658 const HEK * const hvname = HvNAME_HEK((const HV *)sv);
12660 GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
12661 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
12662 if (cloner && GvCV(cloner)) {
12669 mXPUSHs(newSVhek(hvname));
12671 call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
12678 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
12686 =for apidoc perl_clone
12688 Create and return a new interpreter by cloning the current one.
12690 perl_clone takes these flags as parameters:
12692 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
12693 without it we only clone the data and zero the stacks,
12694 with it we copy the stacks and the new perl interpreter is
12695 ready to run at the exact same point as the previous one.
12696 The pseudo-fork code uses COPY_STACKS while the
12697 threads->create doesn't.
12699 CLONEf_KEEP_PTR_TABLE
12700 perl_clone keeps a ptr_table with the pointer of the old
12701 variable as a key and the new variable as a value,
12702 this allows it to check if something has been cloned and not
12703 clone it again but rather just use the value and increase the
12704 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
12705 the ptr_table using the function
12706 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
12707 reason to keep it around is if you want to dup some of your own
12708 variable who are outside the graph perl scans, example of this
12709 code is in threads.xs create
12712 This is a win32 thing, it is ignored on unix, it tells perls
12713 win32host code (which is c++) to clone itself, this is needed on
12714 win32 if you want to run two threads at the same time,
12715 if you just want to do some stuff in a separate perl interpreter
12716 and then throw it away and return to the original one,
12717 you don't need to do anything.
12722 /* XXX the above needs expanding by someone who actually understands it ! */
12723 EXTERN_C PerlInterpreter *
12724 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
12727 perl_clone(PerlInterpreter *proto_perl, UV flags)
12730 #ifdef PERL_IMPLICIT_SYS
12732 PERL_ARGS_ASSERT_PERL_CLONE;
12734 /* perlhost.h so we need to call into it
12735 to clone the host, CPerlHost should have a c interface, sky */
12737 if (flags & CLONEf_CLONE_HOST) {
12738 return perl_clone_host(proto_perl,flags);
12740 return perl_clone_using(proto_perl, flags,
12742 proto_perl->IMemShared,
12743 proto_perl->IMemParse,
12745 proto_perl->IStdIO,
12749 proto_perl->IProc);
12753 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
12754 struct IPerlMem* ipM, struct IPerlMem* ipMS,
12755 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
12756 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
12757 struct IPerlDir* ipD, struct IPerlSock* ipS,
12758 struct IPerlProc* ipP)
12760 /* XXX many of the string copies here can be optimized if they're
12761 * constants; they need to be allocated as common memory and just
12762 * their pointers copied. */
12765 CLONE_PARAMS clone_params;
12766 CLONE_PARAMS* const param = &clone_params;
12768 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
12770 PERL_ARGS_ASSERT_PERL_CLONE_USING;
12771 #else /* !PERL_IMPLICIT_SYS */
12773 CLONE_PARAMS clone_params;
12774 CLONE_PARAMS* param = &clone_params;
12775 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
12777 PERL_ARGS_ASSERT_PERL_CLONE;
12778 #endif /* PERL_IMPLICIT_SYS */
12780 /* for each stash, determine whether its objects should be cloned */
12781 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
12782 PERL_SET_THX(my_perl);
12785 PoisonNew(my_perl, 1, PerlInterpreter);
12790 PL_scopestack_name = 0;
12792 PL_savestack_ix = 0;
12793 PL_savestack_max = -1;
12794 PL_sig_pending = 0;
12796 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
12797 # ifdef DEBUG_LEAKING_SCALARS
12798 PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
12800 #else /* !DEBUGGING */
12801 Zero(my_perl, 1, PerlInterpreter);
12802 #endif /* DEBUGGING */
12804 #ifdef PERL_IMPLICIT_SYS
12805 /* host pointers */
12807 PL_MemShared = ipMS;
12808 PL_MemParse = ipMP;
12815 #endif /* PERL_IMPLICIT_SYS */
12817 param->flags = flags;
12818 /* Nothing in the core code uses this, but we make it available to
12819 extensions (using mg_dup). */
12820 param->proto_perl = proto_perl;
12821 /* Likely nothing will use this, but it is initialised to be consistent
12822 with Perl_clone_params_new(). */
12823 param->new_perl = my_perl;
12824 param->unreferenced = NULL;
12826 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
12828 PL_body_arenas = NULL;
12829 Zero(&PL_body_roots, 1, PL_body_roots);
12832 PL_sv_objcount = 0;
12834 PL_sv_arenaroot = NULL;
12836 PL_debug = proto_perl->Idebug;
12838 PL_hash_seed = proto_perl->Ihash_seed;
12839 PL_rehash_seed = proto_perl->Irehash_seed;
12841 #ifdef USE_REENTRANT_API
12842 /* XXX: things like -Dm will segfault here in perlio, but doing
12843 * PERL_SET_CONTEXT(proto_perl);
12844 * breaks too many other things
12846 Perl_reentrant_init(aTHX);
12849 /* create SV map for pointer relocation */
12850 PL_ptr_table = ptr_table_new();
12852 /* initialize these special pointers as early as possible */
12853 SvANY(&PL_sv_undef) = NULL;
12854 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
12855 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
12856 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
12858 SvANY(&PL_sv_no) = new_XPVNV();
12859 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
12860 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12861 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12862 SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
12863 SvCUR_set(&PL_sv_no, 0);
12864 SvLEN_set(&PL_sv_no, 1);
12865 SvIV_set(&PL_sv_no, 0);
12866 SvNV_set(&PL_sv_no, 0);
12867 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
12869 SvANY(&PL_sv_yes) = new_XPVNV();
12870 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
12871 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12872 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12873 SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
12874 SvCUR_set(&PL_sv_yes, 1);
12875 SvLEN_set(&PL_sv_yes, 2);
12876 SvIV_set(&PL_sv_yes, 1);
12877 SvNV_set(&PL_sv_yes, 1);
12878 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
12880 /* dbargs array probably holds garbage */
12883 /* create (a non-shared!) shared string table */
12884 PL_strtab = newHV();
12885 HvSHAREKEYS_off(PL_strtab);
12886 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
12887 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
12889 PL_compiling = proto_perl->Icompiling;
12891 /* These two PVs will be free'd special way so must set them same way op.c does */
12892 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
12893 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
12895 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
12896 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
12898 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
12899 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
12900 CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));
12901 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
12902 #ifdef PERL_DEBUG_READONLY_OPS
12907 /* pseudo environmental stuff */
12908 PL_origargc = proto_perl->Iorigargc;
12909 PL_origargv = proto_perl->Iorigargv;
12911 param->stashes = newAV(); /* Setup array of objects to call clone on */
12912 /* This makes no difference to the implementation, as it always pushes
12913 and shifts pointers to other SVs without changing their reference
12914 count, with the array becoming empty before it is freed. However, it
12915 makes it conceptually clear what is going on, and will avoid some
12916 work inside av.c, filling slots between AvFILL() and AvMAX() with
12917 &PL_sv_undef, and SvREFCNT_dec()ing those. */
12918 AvREAL_off(param->stashes);
12920 if (!(flags & CLONEf_COPY_STACKS)) {
12921 param->unreferenced = newAV();
12924 /* Set tainting stuff before PerlIO_debug can possibly get called */
12925 PL_tainting = proto_perl->Itainting;
12926 PL_taint_warn = proto_perl->Itaint_warn;
12928 #ifdef PERLIO_LAYERS
12929 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
12930 PerlIO_clone(aTHX_ proto_perl, param);
12933 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
12934 PL_incgv = gv_dup(proto_perl->Iincgv, param);
12935 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
12936 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
12937 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
12938 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
12941 PL_minus_c = proto_perl->Iminus_c;
12942 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
12943 PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
12944 PL_localpatches = proto_perl->Ilocalpatches;
12945 PL_splitstr = proto_perl->Isplitstr;
12946 PL_minus_n = proto_perl->Iminus_n;
12947 PL_minus_p = proto_perl->Iminus_p;
12948 PL_minus_l = proto_perl->Iminus_l;
12949 PL_minus_a = proto_perl->Iminus_a;
12950 PL_minus_E = proto_perl->Iminus_E;
12951 PL_minus_F = proto_perl->Iminus_F;
12952 PL_doswitches = proto_perl->Idoswitches;
12953 PL_dowarn = proto_perl->Idowarn;
12954 PL_sawampersand = proto_perl->Isawampersand;
12955 PL_unsafe = proto_perl->Iunsafe;
12956 PL_inplace = SAVEPV(proto_perl->Iinplace);
12957 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
12958 PL_perldb = proto_perl->Iperldb;
12959 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
12960 PL_exit_flags = proto_perl->Iexit_flags;
12962 /* magical thingies */
12963 /* XXX time(&PL_basetime) when asked for? */
12964 PL_basetime = proto_perl->Ibasetime;
12965 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
12967 PL_maxsysfd = proto_perl->Imaxsysfd;
12968 PL_statusvalue = proto_perl->Istatusvalue;
12970 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
12972 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
12974 PL_encoding = sv_dup(proto_perl->Iencoding, param);
12976 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
12977 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
12978 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
12981 /* RE engine related */
12982 Zero(&PL_reg_state, 1, struct re_save_state);
12983 PL_reginterp_cnt = 0;
12984 PL_regmatch_slab = NULL;
12986 /* Clone the regex array */
12987 /* ORANGE FIXME for plugins, probably in the SV dup code.
12988 newSViv(PTR2IV(CALLREGDUPE(
12989 INT2PTR(REGEXP *, SvIVX(regex)), param))))
12991 PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
12992 PL_regex_pad = AvARRAY(PL_regex_padav);
12994 /* shortcuts to various I/O objects */
12995 PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param);
12996 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
12997 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
12998 PL_defgv = gv_dup(proto_perl->Idefgv, param);
12999 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
13000 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
13001 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
13003 /* shortcuts to regexp stuff */
13004 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
13006 /* shortcuts to misc objects */
13007 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
13009 /* shortcuts to debugging objects */
13010 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
13011 PL_DBline = gv_dup(proto_perl->IDBline, param);
13012 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
13013 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
13014 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
13015 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
13017 /* symbol tables */
13018 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
13019 PL_curstash = hv_dup(proto_perl->Icurstash, param);
13020 PL_debstash = hv_dup(proto_perl->Idebstash, param);
13021 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
13022 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
13024 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
13025 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
13026 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
13027 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
13028 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
13029 PL_endav = av_dup_inc(proto_perl->Iendav, param);
13030 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
13031 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
13033 PL_sub_generation = proto_perl->Isub_generation;
13034 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
13036 /* funky return mechanisms */
13037 PL_forkprocess = proto_perl->Iforkprocess;
13039 /* subprocess state */
13040 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
13042 /* internal state */
13043 PL_maxo = proto_perl->Imaxo;
13044 if (proto_perl->Iop_mask)
13045 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
13048 /* PL_asserting = proto_perl->Iasserting; */
13050 /* current interpreter roots */
13051 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
13053 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
13055 PL_main_start = proto_perl->Imain_start;
13056 PL_eval_root = proto_perl->Ieval_root;
13057 PL_eval_start = proto_perl->Ieval_start;
13059 /* runtime control stuff */
13060 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
13062 PL_filemode = proto_perl->Ifilemode;
13063 PL_lastfd = proto_perl->Ilastfd;
13064 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
13067 PL_gensym = proto_perl->Igensym;
13068 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
13069 PL_laststatval = proto_perl->Ilaststatval;
13070 PL_laststype = proto_perl->Ilaststype;
13073 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
13075 /* interpreter atexit processing */
13076 PL_exitlistlen = proto_perl->Iexitlistlen;
13077 if (PL_exitlistlen) {
13078 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
13079 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
13082 PL_exitlist = (PerlExitListEntry*)NULL;
13084 PL_my_cxt_size = proto_perl->Imy_cxt_size;
13085 if (PL_my_cxt_size) {
13086 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
13087 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
13088 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13089 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
13090 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
13094 PL_my_cxt_list = (void**)NULL;
13095 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13096 PL_my_cxt_keys = (const char**)NULL;
13099 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
13100 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
13101 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
13102 PL_custom_ops = hv_dup_inc(proto_perl->Icustom_ops, param);
13104 PL_profiledata = NULL;
13106 PL_compcv = cv_dup(proto_perl->Icompcv, param);
13108 PAD_CLONE_VARS(proto_perl, param);
13110 #ifdef HAVE_INTERP_INTERN
13111 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
13114 /* more statics moved here */
13115 PL_generation = proto_perl->Igeneration;
13116 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
13118 PL_in_clean_objs = proto_perl->Iin_clean_objs;
13119 PL_in_clean_all = proto_perl->Iin_clean_all;
13121 PL_uid = proto_perl->Iuid;
13122 PL_euid = proto_perl->Ieuid;
13123 PL_gid = proto_perl->Igid;
13124 PL_egid = proto_perl->Iegid;
13125 PL_nomemok = proto_perl->Inomemok;
13126 PL_an = proto_perl->Ian;
13127 PL_evalseq = proto_perl->Ievalseq;
13128 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
13129 PL_origalen = proto_perl->Iorigalen;
13130 #ifdef PERL_USES_PL_PIDSTATUS
13131 PL_pidstatus = newHV(); /* XXX flag for cloning? */
13133 PL_osname = SAVEPV(proto_perl->Iosname);
13134 PL_sighandlerp = proto_perl->Isighandlerp;
13136 PL_runops = proto_perl->Irunops;
13138 PL_parser = parser_dup(proto_perl->Iparser, param);
13140 /* XXX this only works if the saved cop has already been cloned */
13141 if (proto_perl->Iparser) {
13142 PL_parser->saved_curcop = (COP*)any_dup(
13143 proto_perl->Iparser->saved_curcop,
13147 PL_subline = proto_perl->Isubline;
13148 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
13151 PL_cryptseen = proto_perl->Icryptseen;
13154 PL_hints = proto_perl->Ihints;
13156 PL_amagic_generation = proto_perl->Iamagic_generation;
13158 #ifdef USE_LOCALE_COLLATE
13159 PL_collation_ix = proto_perl->Icollation_ix;
13160 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
13161 PL_collation_standard = proto_perl->Icollation_standard;
13162 PL_collxfrm_base = proto_perl->Icollxfrm_base;
13163 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
13164 #endif /* USE_LOCALE_COLLATE */
13166 #ifdef USE_LOCALE_NUMERIC
13167 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
13168 PL_numeric_standard = proto_perl->Inumeric_standard;
13169 PL_numeric_local = proto_perl->Inumeric_local;
13170 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
13171 #endif /* !USE_LOCALE_NUMERIC */
13173 /* utf8 character classes */
13174 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
13175 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
13176 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
13177 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
13178 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
13179 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
13180 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
13181 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
13182 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
13183 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
13184 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
13185 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
13186 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
13187 PL_utf8_X_begin = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
13188 PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
13189 PL_utf8_X_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
13190 PL_utf8_X_non_hangul = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
13191 PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
13192 PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
13193 PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
13194 PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
13195 PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
13196 PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
13197 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
13198 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
13199 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
13200 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
13201 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
13202 PL_utf8_xidstart = sv_dup_inc(proto_perl->Iutf8_xidstart, param);
13203 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
13204 PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
13205 PL_utf8_foldable = hv_dup_inc(proto_perl->Iutf8_foldable, param);
13207 /* Did the locale setup indicate UTF-8? */
13208 PL_utf8locale = proto_perl->Iutf8locale;
13209 /* Unicode features (see perlrun/-C) */
13210 PL_unicode = proto_perl->Iunicode;
13212 /* Pre-5.8 signals control */
13213 PL_signals = proto_perl->Isignals;
13215 /* times() ticks per second */
13216 PL_clocktick = proto_perl->Iclocktick;
13218 /* Recursion stopper for PerlIO_find_layer */
13219 PL_in_load_module = proto_perl->Iin_load_module;
13221 /* sort() routine */
13222 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
13224 /* Not really needed/useful since the reenrant_retint is "volatile",
13225 * but do it for consistency's sake. */
13226 PL_reentrant_retint = proto_perl->Ireentrant_retint;
13228 /* Hooks to shared SVs and locks. */
13229 PL_sharehook = proto_perl->Isharehook;
13230 PL_lockhook = proto_perl->Ilockhook;
13231 PL_unlockhook = proto_perl->Iunlockhook;
13232 PL_threadhook = proto_perl->Ithreadhook;
13233 PL_destroyhook = proto_perl->Idestroyhook;
13234 PL_signalhook = proto_perl->Isignalhook;
13236 #ifdef THREADS_HAVE_PIDS
13237 PL_ppid = proto_perl->Ippid;
13241 PL_last_swash_hv = NULL; /* reinits on demand */
13242 PL_last_swash_klen = 0;
13243 PL_last_swash_key[0]= '\0';
13244 PL_last_swash_tmps = (U8*)NULL;
13245 PL_last_swash_slen = 0;
13247 PL_glob_index = proto_perl->Iglob_index;
13248 PL_srand_called = proto_perl->Isrand_called;
13250 if (proto_perl->Ipsig_pend) {
13251 Newxz(PL_psig_pend, SIG_SIZE, int);
13254 PL_psig_pend = (int*)NULL;
13257 if (proto_perl->Ipsig_name) {
13258 Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
13259 sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
13261 PL_psig_ptr = PL_psig_name + SIG_SIZE;
13264 PL_psig_ptr = (SV**)NULL;
13265 PL_psig_name = (SV**)NULL;
13268 /* intrpvar.h stuff */
13270 if (flags & CLONEf_COPY_STACKS) {
13271 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
13272 PL_tmps_ix = proto_perl->Itmps_ix;
13273 PL_tmps_max = proto_perl->Itmps_max;
13274 PL_tmps_floor = proto_perl->Itmps_floor;
13275 Newx(PL_tmps_stack, PL_tmps_max, SV*);
13276 sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
13277 PL_tmps_ix+1, param);
13279 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
13280 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
13281 Newxz(PL_markstack, i, I32);
13282 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
13283 - proto_perl->Imarkstack);
13284 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
13285 - proto_perl->Imarkstack);
13286 Copy(proto_perl->Imarkstack, PL_markstack,
13287 PL_markstack_ptr - PL_markstack + 1, I32);
13289 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13290 * NOTE: unlike the others! */
13291 PL_scopestack_ix = proto_perl->Iscopestack_ix;
13292 PL_scopestack_max = proto_perl->Iscopestack_max;
13293 Newxz(PL_scopestack, PL_scopestack_max, I32);
13294 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
13297 Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
13298 Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
13300 /* NOTE: si_dup() looks at PL_markstack */
13301 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
13303 /* PL_curstack = PL_curstackinfo->si_stack; */
13304 PL_curstack = av_dup(proto_perl->Icurstack, param);
13305 PL_mainstack = av_dup(proto_perl->Imainstack, param);
13307 /* next PUSHs() etc. set *(PL_stack_sp+1) */
13308 PL_stack_base = AvARRAY(PL_curstack);
13309 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
13310 - proto_perl->Istack_base);
13311 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
13313 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
13314 * NOTE: unlike the others! */
13315 PL_savestack_ix = proto_perl->Isavestack_ix;
13316 PL_savestack_max = proto_perl->Isavestack_max;
13317 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
13318 PL_savestack = ss_dup(proto_perl, param);
13322 ENTER; /* perl_destruct() wants to LEAVE; */
13325 PL_start_env = proto_perl->Istart_env; /* XXXXXX */
13326 PL_top_env = &PL_start_env;
13328 PL_op = proto_perl->Iop;
13331 PL_Xpv = (XPV*)NULL;
13332 my_perl->Ina = proto_perl->Ina;
13334 PL_statbuf = proto_perl->Istatbuf;
13335 PL_statcache = proto_perl->Istatcache;
13336 PL_statgv = gv_dup(proto_perl->Istatgv, param);
13337 PL_statname = sv_dup_inc(proto_perl->Istatname, param);
13339 PL_timesbuf = proto_perl->Itimesbuf;
13342 PL_tainted = proto_perl->Itainted;
13343 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
13344 PL_rs = sv_dup_inc(proto_perl->Irs, param);
13345 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
13346 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
13347 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
13348 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
13349 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
13350 PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
13352 PL_restartjmpenv = proto_perl->Irestartjmpenv;
13353 PL_restartop = proto_perl->Irestartop;
13354 PL_in_eval = proto_perl->Iin_eval;
13355 PL_delaymagic = proto_perl->Idelaymagic;
13356 PL_phase = proto_perl->Iphase;
13357 PL_localizing = proto_perl->Ilocalizing;
13359 PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
13360 PL_hv_fetch_ent_mh = NULL;
13361 PL_modcount = proto_perl->Imodcount;
13362 PL_lastgotoprobe = NULL;
13363 PL_dumpindent = proto_perl->Idumpindent;
13365 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
13366 PL_sortstash = hv_dup(proto_perl->Isortstash, param);
13367 PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
13368 PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
13369 PL_efloatbuf = NULL; /* reinits on demand */
13370 PL_efloatsize = 0; /* reinits on demand */
13374 PL_screamfirst = NULL;
13375 PL_screamnext = NULL;
13376 PL_maxscream = -1; /* reinits on demand */
13377 PL_lastscream = NULL;
13380 PL_regdummy = proto_perl->Iregdummy;
13381 PL_colorset = 0; /* reinits PL_colors[] */
13382 /*PL_colors[6] = {0,0,0,0,0,0};*/
13386 /* Pluggable optimizer */
13387 PL_peepp = proto_perl->Ipeepp;
13388 PL_rpeepp = proto_perl->Irpeepp;
13389 /* op_free() hook */
13390 PL_opfreehook = proto_perl->Iopfreehook;
13392 PL_stashcache = newHV();
13394 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
13395 proto_perl->Iwatchaddr);
13396 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
13397 if (PL_debug && PL_watchaddr) {
13398 PerlIO_printf(Perl_debug_log,
13399 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
13400 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
13401 PTR2UV(PL_watchok));
13404 PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
13405 PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param);
13406 PL_utf8_foldclosures = hv_dup_inc(proto_perl->Iutf8_foldclosures, param);
13408 /* Call the ->CLONE method, if it exists, for each of the stashes
13409 identified by sv_dup() above.
13411 while(av_len(param->stashes) != -1) {
13412 HV* const stash = MUTABLE_HV(av_shift(param->stashes));
13413 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
13414 if (cloner && GvCV(cloner)) {
13419 mXPUSHs(newSVhek(HvNAME_HEK(stash)));
13421 call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
13427 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
13428 ptr_table_free(PL_ptr_table);
13429 PL_ptr_table = NULL;
13432 if (!(flags & CLONEf_COPY_STACKS)) {
13433 unreferenced_to_tmp_stack(param->unreferenced);
13436 SvREFCNT_dec(param->stashes);
13438 /* orphaned? eg threads->new inside BEGIN or use */
13439 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
13440 SvREFCNT_inc_simple_void(PL_compcv);
13441 SAVEFREESV(PL_compcv);
13448 S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
13450 PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
13452 if (AvFILLp(unreferenced) > -1) {
13453 SV **svp = AvARRAY(unreferenced);
13454 SV **const last = svp + AvFILLp(unreferenced);
13458 if (SvREFCNT(*svp) == 1)
13460 } while (++svp <= last);
13462 EXTEND_MORTAL(count);
13463 svp = AvARRAY(unreferenced);
13466 if (SvREFCNT(*svp) == 1) {
13467 /* Our reference is the only one to this SV. This means that
13468 in this thread, the scalar effectively has a 0 reference.
13469 That doesn't work (cleanup never happens), so donate our
13470 reference to it onto the save stack. */
13471 PL_tmps_stack[++PL_tmps_ix] = *svp;
13473 /* As an optimisation, because we are already walking the
13474 entire array, instead of above doing either
13475 SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
13476 release our reference to the scalar, so that at the end of
13477 the array owns zero references to the scalars it happens to
13478 point to. We are effectively converting the array from
13479 AvREAL() on to AvREAL() off. This saves the av_clear()
13480 (triggered by the SvREFCNT_dec(unreferenced) below) from
13481 walking the array a second time. */
13482 SvREFCNT_dec(*svp);
13485 } while (++svp <= last);
13486 AvREAL_off(unreferenced);
13488 SvREFCNT_dec(unreferenced);
13492 Perl_clone_params_del(CLONE_PARAMS *param)
13494 /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
13496 PerlInterpreter *const to = param->new_perl;
13498 PerlInterpreter *const was = PERL_GET_THX;
13500 PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
13506 SvREFCNT_dec(param->stashes);
13507 if (param->unreferenced)
13508 unreferenced_to_tmp_stack(param->unreferenced);
13518 Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
13521 /* Need to play this game, as newAV() can call safesysmalloc(), and that
13522 does a dTHX; to get the context from thread local storage.
13523 FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
13524 a version that passes in my_perl. */
13525 PerlInterpreter *const was = PERL_GET_THX;
13526 CLONE_PARAMS *param;
13528 PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
13534 /* Given that we've set the context, we can do this unshared. */
13535 Newx(param, 1, CLONE_PARAMS);
13538 param->proto_perl = from;
13539 param->new_perl = to;
13540 param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
13541 AvREAL_off(param->stashes);
13542 param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
13550 #endif /* USE_ITHREADS */
13553 =head1 Unicode Support
13555 =for apidoc sv_recode_to_utf8
13557 The encoding is assumed to be an Encode object, on entry the PV
13558 of the sv is assumed to be octets in that encoding, and the sv
13559 will be converted into Unicode (and UTF-8).
13561 If the sv already is UTF-8 (or if it is not POK), or if the encoding
13562 is not a reference, nothing is done to the sv. If the encoding is not
13563 an C<Encode::XS> Encoding object, bad things will happen.
13564 (See F<lib/encoding.pm> and L<Encode>).
13566 The PV of the sv is returned.
13571 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
13575 PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
13577 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
13591 Passing sv_yes is wrong - it needs to be or'ed set of constants
13592 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
13593 remove converted chars from source.
13595 Both will default the value - let them.
13597 XPUSHs(&PL_sv_yes);
13600 call_method("decode", G_SCALAR);
13604 s = SvPV_const(uni, len);
13605 if (s != SvPVX_const(sv)) {
13606 SvGROW(sv, len + 1);
13607 Move(s, SvPVX(sv), len + 1, char);
13608 SvCUR_set(sv, len);
13612 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
13613 /* clear pos and any utf8 cache */
13614 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
13617 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
13618 magic_setutf8(sv,mg); /* clear UTF8 cache */
13623 return SvPOKp(sv) ? SvPVX(sv) : NULL;
13627 =for apidoc sv_cat_decode
13629 The encoding is assumed to be an Encode object, the PV of the ssv is
13630 assumed to be octets in that encoding and decoding the input starts
13631 from the position which (PV + *offset) pointed to. The dsv will be
13632 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
13633 when the string tstr appears in decoding output or the input ends on
13634 the PV of the ssv. The value which the offset points will be modified
13635 to the last input position on the ssv.
13637 Returns TRUE if the terminator was found, else returns FALSE.
13642 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
13643 SV *ssv, int *offset, char *tstr, int tlen)
13648 PERL_ARGS_ASSERT_SV_CAT_DECODE;
13650 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
13661 offsv = newSViv(*offset);
13663 mXPUSHp(tstr, tlen);
13665 call_method("cat_decode", G_SCALAR);
13667 ret = SvTRUE(TOPs);
13668 *offset = SvIV(offsv);
13674 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
13679 /* ---------------------------------------------------------------------
13681 * support functions for report_uninit()
13684 /* the maxiumum size of array or hash where we will scan looking
13685 * for the undefined element that triggered the warning */
13687 #define FUV_MAX_SEARCH_SIZE 1000
13689 /* Look for an entry in the hash whose value has the same SV as val;
13690 * If so, return a mortal copy of the key. */
13693 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
13696 register HE **array;
13699 PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
13701 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
13702 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
13705 array = HvARRAY(hv);
13707 for (i=HvMAX(hv); i>0; i--) {
13708 register HE *entry;
13709 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
13710 if (HeVAL(entry) != val)
13712 if ( HeVAL(entry) == &PL_sv_undef ||
13713 HeVAL(entry) == &PL_sv_placeholder)
13717 if (HeKLEN(entry) == HEf_SVKEY)
13718 return sv_mortalcopy(HeKEY_sv(entry));
13719 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
13725 /* Look for an entry in the array whose value has the same SV as val;
13726 * If so, return the index, otherwise return -1. */
13729 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
13733 PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
13735 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
13736 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
13739 if (val != &PL_sv_undef) {
13740 SV ** const svp = AvARRAY(av);
13743 for (i=AvFILLp(av); i>=0; i--)
13750 /* S_varname(): return the name of a variable, optionally with a subscript.
13751 * If gv is non-zero, use the name of that global, along with gvtype (one
13752 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
13753 * targ. Depending on the value of the subscript_type flag, return:
13756 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
13757 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
13758 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
13759 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
13762 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
13763 const SV *const keyname, I32 aindex, int subscript_type)
13766 SV * const name = sv_newmortal();
13769 buffer[0] = gvtype;
13772 /* as gv_fullname4(), but add literal '^' for $^FOO names */
13774 gv_fullname4(name, gv, buffer, 0);
13776 if ((unsigned int)SvPVX(name)[1] <= 26) {
13778 buffer[1] = SvPVX(name)[1] + 'A' - 1;
13780 /* Swap the 1 unprintable control character for the 2 byte pretty
13781 version - ie substr($name, 1, 1) = $buffer; */
13782 sv_insert(name, 1, 1, buffer, 2);
13786 CV * const cv = find_runcv(NULL);
13790 if (!cv || !CvPADLIST(cv))
13792 av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
13793 sv = *av_fetch(av, targ, FALSE);
13794 sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
13797 if (subscript_type == FUV_SUBSCRIPT_HASH) {
13798 SV * const sv = newSV(0);
13799 *SvPVX(name) = '$';
13800 Perl_sv_catpvf(aTHX_ name, "{%s}",
13801 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
13804 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
13805 *SvPVX(name) = '$';
13806 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
13808 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
13809 /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
13810 Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
13818 =for apidoc find_uninit_var
13820 Find the name of the undefined variable (if any) that caused the operator o
13821 to issue a "Use of uninitialized value" warning.
13822 If match is true, only return a name if it's value matches uninit_sv.
13823 So roughly speaking, if a unary operator (such as OP_COS) generates a
13824 warning, then following the direct child of the op may yield an
13825 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
13826 other hand, with OP_ADD there are two branches to follow, so we only print
13827 the variable name if we get an exact match.
13829 The name is returned as a mortal SV.
13831 Assumes that PL_op is the op that originally triggered the error, and that
13832 PL_comppad/PL_curpad points to the currently executing pad.
13838 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
13844 const OP *o, *o2, *kid;
13846 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
13847 uninit_sv == &PL_sv_placeholder)))
13850 switch (obase->op_type) {
13857 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
13858 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
13861 int subscript_type = FUV_SUBSCRIPT_WITHIN;
13863 if (pad) { /* @lex, %lex */
13864 sv = PAD_SVl(obase->op_targ);
13868 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
13869 /* @global, %global */
13870 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
13873 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
13875 else /* @{expr}, %{expr} */
13876 return find_uninit_var(cUNOPx(obase)->op_first,
13880 /* attempt to find a match within the aggregate */
13882 keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13884 subscript_type = FUV_SUBSCRIPT_HASH;
13887 index = find_array_subscript((const AV *)sv, uninit_sv);
13889 subscript_type = FUV_SUBSCRIPT_ARRAY;
13892 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
13895 return varname(gv, hash ? '%' : '@', obase->op_targ,
13896 keysv, index, subscript_type);
13900 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
13902 return varname(NULL, '$', obase->op_targ,
13903 NULL, 0, FUV_SUBSCRIPT_NONE);
13906 gv = cGVOPx_gv(obase);
13907 if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))
13909 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
13912 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
13915 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
13916 if (!av || SvRMAGICAL(av))
13918 svp = av_fetch(av, (I32)obase->op_private, FALSE);
13919 if (!svp || *svp != uninit_sv)
13922 return varname(NULL, '$', obase->op_targ,
13923 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
13926 gv = cGVOPx_gv(obase);
13931 AV *const av = GvAV(gv);
13932 if (!av || SvRMAGICAL(av))
13934 svp = av_fetch(av, (I32)obase->op_private, FALSE);
13935 if (!svp || *svp != uninit_sv)
13938 return varname(gv, '$', 0,
13939 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
13944 o = cUNOPx(obase)->op_first;
13945 if (!o || o->op_type != OP_NULL ||
13946 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
13948 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
13952 if (PL_op == obase)
13953 /* $a[uninit_expr] or $h{uninit_expr} */
13954 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
13957 o = cBINOPx(obase)->op_first;
13958 kid = cBINOPx(obase)->op_last;
13960 /* get the av or hv, and optionally the gv */
13962 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
13963 sv = PAD_SV(o->op_targ);
13965 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
13966 && cUNOPo->op_first->op_type == OP_GV)
13968 gv = cGVOPx_gv(cUNOPo->op_first);
13972 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
13977 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
13978 /* index is constant */
13982 if (obase->op_type == OP_HELEM) {
13983 HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
13984 if (!he || HeVAL(he) != uninit_sv)
13988 SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
13989 if (!svp || *svp != uninit_sv)
13993 if (obase->op_type == OP_HELEM)
13994 return varname(gv, '%', o->op_targ,
13995 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
13997 return varname(gv, '@', o->op_targ, NULL,
13998 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
14001 /* index is an expression;
14002 * attempt to find a match within the aggregate */
14003 if (obase->op_type == OP_HELEM) {
14004 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
14006 return varname(gv, '%', o->op_targ,
14007 keysv, 0, FUV_SUBSCRIPT_HASH);
14011 = find_array_subscript((const AV *)sv, uninit_sv);
14013 return varname(gv, '@', o->op_targ,
14014 NULL, index, FUV_SUBSCRIPT_ARRAY);
14019 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
14021 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
14026 /* only examine RHS */
14027 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
14030 o = cUNOPx(obase)->op_first;
14031 if (o->op_type == OP_PUSHMARK)
14034 if (!o->op_sibling) {
14035 /* one-arg version of open is highly magical */
14037 if (o->op_type == OP_GV) { /* open FOO; */
14039 if (match && GvSV(gv) != uninit_sv)
14041 return varname(gv, '$', 0,
14042 NULL, 0, FUV_SUBSCRIPT_NONE);
14044 /* other possibilities not handled are:
14045 * open $x; or open my $x; should return '${*$x}'
14046 * open expr; should return '$'.expr ideally
14052 /* ops where $_ may be an implicit arg */
14056 if ( !(obase->op_flags & OPf_STACKED)) {
14057 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
14058 ? PAD_SVl(obase->op_targ)
14061 sv = sv_newmortal();
14062 sv_setpvs(sv, "$_");
14071 match = 1; /* print etc can return undef on defined args */
14072 /* skip filehandle as it can't produce 'undef' warning */
14073 o = cUNOPx(obase)->op_first;
14074 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
14075 o = o->op_sibling->op_sibling;
14079 case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
14081 case OP_CUSTOM: /* XS or custom code could trigger random warnings */
14083 /* the following ops are capable of returning PL_sv_undef even for
14084 * defined arg(s) */
14103 case OP_GETPEERNAME:
14151 case OP_SMARTMATCH:
14160 /* XXX tmp hack: these two may call an XS sub, and currently
14161 XS subs don't have a SUB entry on the context stack, so CV and
14162 pad determination goes wrong, and BAD things happen. So, just
14163 don't try to determine the value under those circumstances.
14164 Need a better fix at dome point. DAPM 11/2007 */
14170 GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
14171 if (gv && GvSV(gv) == uninit_sv)
14172 return newSVpvs_flags("$.", SVs_TEMP);
14177 /* def-ness of rval pos() is independent of the def-ness of its arg */
14178 if ( !(obase->op_flags & OPf_MOD))
14183 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
14184 return newSVpvs_flags("${$/}", SVs_TEMP);
14189 if (!(obase->op_flags & OPf_KIDS))
14191 o = cUNOPx(obase)->op_first;
14197 /* if all except one arg are constant, or have no side-effects,
14198 * or are optimized away, then it's unambiguous */
14200 for (kid=o; kid; kid = kid->op_sibling) {
14202 const OPCODE type = kid->op_type;
14203 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
14204 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
14205 || (type == OP_PUSHMARK)
14207 /* @$a and %$a, but not @a or %a */
14208 (type == OP_RV2AV || type == OP_RV2HV)
14209 && cUNOPx(kid)->op_first
14210 && cUNOPx(kid)->op_first->op_type != OP_GV
14215 if (o2) { /* more than one found */
14222 return find_uninit_var(o2, uninit_sv, match);
14224 /* scan all args */
14226 sv = find_uninit_var(o, uninit_sv, 1);
14238 =for apidoc report_uninit
14240 Print appropriate "Use of uninitialized variable" warning
14246 Perl_report_uninit(pTHX_ const SV *uninit_sv)
14250 SV* varname = NULL;
14252 varname = find_uninit_var(PL_op, uninit_sv,0);
14254 sv_insert(varname, 0, 0, " ", 1);
14256 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
14257 varname ? SvPV_nolen_const(varname) : "",
14258 " in ", OP_DESC(PL_op));
14261 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
14267 * c-indentation-style: bsd
14268 * c-basic-offset: 4
14269 * indent-tabs-mode: t
14272 * ex: set ts=8 sts=4 sw=4 noet: