3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'I wonder what the Entish is for "yes" and "no",' he thought.
16 * [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
22 * This file contains the code that creates, manipulates and destroys
23 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
24 * structure of an SV, so their creation and destruction is handled
25 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
26 * level functions (eg. substr, split, join) for each of the types are
38 /* Missing proto on LynxOS */
39 char *gconvert(double, int, int, char *);
42 #ifdef PERL_UTF8_CACHE_ASSERT
43 /* if adding more checks watch out for the following tests:
44 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
45 * lib/utf8.t lib/Unicode/Collate/t/index.t
48 # define ASSERT_UTF8_CACHE(cache) \
49 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
50 assert((cache)[2] <= (cache)[3]); \
51 assert((cache)[3] <= (cache)[1]);} \
54 # define ASSERT_UTF8_CACHE(cache) NOOP
57 #ifdef PERL_OLD_COPY_ON_WRITE
58 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
59 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
60 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
64 /* ============================================================================
66 =head1 Allocation and deallocation of SVs.
68 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
69 sv, av, hv...) contains type and reference count information, and for
70 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
71 contains fields specific to each type. Some types store all they need
72 in the head, so don't have a body.
74 In all but the most memory-paranoid configuations (ex: PURIFY), heads
75 and bodies are allocated out of arenas, which by default are
76 approximately 4K chunks of memory parcelled up into N heads or bodies.
77 Sv-bodies are allocated by their sv-type, guaranteeing size
78 consistency needed to allocate safely from arrays.
80 For SV-heads, the first slot in each arena is reserved, and holds a
81 link to the next arena, some flags, and a note of the number of slots.
82 Snaked through each arena chain is a linked list of free items; when
83 this becomes empty, an extra arena is allocated and divided up into N
84 items which are threaded into the free list.
86 SV-bodies are similar, but they use arena-sets by default, which
87 separate the link and info from the arena itself, and reclaim the 1st
88 slot in the arena. SV-bodies are further described later.
90 The following global variables are associated with arenas:
92 PL_sv_arenaroot pointer to list of SV arenas
93 PL_sv_root pointer to list of free SV structures
95 PL_body_arenas head of linked-list of body arenas
96 PL_body_roots[] array of pointers to list of free bodies of svtype
97 arrays are indexed by the svtype needed
99 A few special SV heads are not allocated from an arena, but are
100 instead directly created in the interpreter structure, eg PL_sv_undef.
101 The size of arenas can be changed from the default by setting
102 PERL_ARENA_SIZE appropriately at compile time.
104 The SV arena serves the secondary purpose of allowing still-live SVs
105 to be located and destroyed during final cleanup.
107 At the lowest level, the macros new_SV() and del_SV() grab and free
108 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
109 to return the SV to the free list with error checking.) new_SV() calls
110 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
111 SVs in the free list have their SvTYPE field set to all ones.
113 At the time of very final cleanup, sv_free_arenas() is called from
114 perl_destruct() to physically free all the arenas allocated since the
115 start of the interpreter.
117 The function visit() scans the SV arenas list, and calls a specified
118 function for each SV it finds which is still live - ie which has an SvTYPE
119 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
120 following functions (specified as [function that calls visit()] / [function
121 called by visit() for each SV]):
123 sv_report_used() / do_report_used()
124 dump all remaining SVs (debugging aid)
126 sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
127 do_clean_named_io_objs()
128 Attempt to free all objects pointed to by RVs,
129 and try to do the same for all objects indirectly
130 referenced by typeglobs too. Called once from
131 perl_destruct(), prior to calling sv_clean_all()
134 sv_clean_all() / do_clean_all()
135 SvREFCNT_dec(sv) each remaining SV, possibly
136 triggering an sv_free(). It also sets the
137 SVf_BREAK flag on the SV to indicate that the
138 refcnt has been artificially lowered, and thus
139 stopping sv_free() from giving spurious warnings
140 about SVs which unexpectedly have a refcnt
141 of zero. called repeatedly from perl_destruct()
142 until there are no SVs left.
144 =head2 Arena allocator API Summary
146 Private API to rest of sv.c
150 new_XPVNV(), del_XPVGV(),
155 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
159 * ========================================================================= */
162 * "A time to plant, and a time to uproot what was planted..."
166 # define MEM_LOG_NEW_SV(sv, file, line, func) \
167 Perl_mem_log_new_sv(sv, file, line, func)
168 # define MEM_LOG_DEL_SV(sv, file, line, func) \
169 Perl_mem_log_del_sv(sv, file, line, func)
171 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
172 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
175 #ifdef DEBUG_LEAKING_SCALARS
176 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
177 # define DEBUG_SV_SERIAL(sv) \
178 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
179 PTR2UV(sv), (long)(sv)->sv_debug_serial))
181 # define FREE_SV_DEBUG_FILE(sv)
182 # define DEBUG_SV_SERIAL(sv) NOOP
186 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
187 # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
188 /* Whilst I'd love to do this, it seems that things like to check on
190 # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
192 # define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
193 PoisonNew(&SvREFCNT(sv), 1, U32)
195 # define SvARENA_CHAIN(sv) SvANY(sv)
196 # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
197 # define POSION_SV_HEAD(sv)
200 /* Mark an SV head as unused, and add to free list.
202 * If SVf_BREAK is set, skip adding it to the free list, as this SV had
203 * its refcount artificially decremented during global destruction, so
204 * there may be dangling pointers to it. The last thing we want in that
205 * case is for it to be reused. */
207 #define plant_SV(p) \
209 const U32 old_flags = SvFLAGS(p); \
210 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
211 DEBUG_SV_SERIAL(p); \
212 FREE_SV_DEBUG_FILE(p); \
214 SvFLAGS(p) = SVTYPEMASK; \
215 if (!(old_flags & SVf_BREAK)) { \
216 SvARENA_CHAIN_SET(p, PL_sv_root); \
222 #define uproot_SV(p) \
225 PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
230 /* make some more SVs by adding another arena */
237 char *chunk; /* must use New here to match call to */
238 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
239 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
244 /* new_SV(): return a new, empty SV head */
246 #ifdef DEBUG_LEAKING_SCALARS
247 /* provide a real function for a debugger to play with */
249 S_new_SV(pTHX_ const char *file, int line, const char *func)
256 sv = S_more_sv(aTHX);
260 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
261 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
267 sv->sv_debug_inpad = 0;
268 sv->sv_debug_parent = NULL;
269 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
271 sv->sv_debug_serial = PL_sv_serial++;
273 MEM_LOG_NEW_SV(sv, file, line, func);
274 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
275 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
279 # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
287 (p) = S_more_sv(aTHX); \
291 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
296 /* del_SV(): return an empty SV head to the free list */
309 S_del_sv(pTHX_ SV *p)
313 PERL_ARGS_ASSERT_DEL_SV;
318 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
319 const SV * const sv = sva + 1;
320 const SV * const svend = &sva[SvREFCNT(sva)];
321 if (p >= sv && p < svend) {
327 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
328 "Attempt to free non-arena SV: 0x%"UVxf
329 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
336 #else /* ! DEBUGGING */
338 #define del_SV(p) plant_SV(p)
340 #endif /* DEBUGGING */
344 =head1 SV Manipulation Functions
346 =for apidoc sv_add_arena
348 Given a chunk of memory, link it to the head of the list of arenas,
349 and split it into a list of free SVs.
355 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
358 SV *const sva = MUTABLE_SV(ptr);
362 PERL_ARGS_ASSERT_SV_ADD_ARENA;
364 /* The first SV in an arena isn't an SV. */
365 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
366 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
367 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
369 PL_sv_arenaroot = sva;
370 PL_sv_root = sva + 1;
372 svend = &sva[SvREFCNT(sva) - 1];
375 SvARENA_CHAIN_SET(sv, (sv + 1));
379 /* Must always set typemask because it's always checked in on cleanup
380 when the arenas are walked looking for objects. */
381 SvFLAGS(sv) = SVTYPEMASK;
384 SvARENA_CHAIN_SET(sv, 0);
388 SvFLAGS(sv) = SVTYPEMASK;
391 /* visit(): call the named function for each non-free SV in the arenas
392 * whose flags field matches the flags/mask args. */
395 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
401 PERL_ARGS_ASSERT_VISIT;
403 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
404 register const SV * const svend = &sva[SvREFCNT(sva)];
406 for (sv = sva + 1; sv < svend; ++sv) {
407 if (SvTYPE(sv) != SVTYPEMASK
408 && (sv->sv_flags & mask) == flags
421 /* called by sv_report_used() for each live SV */
424 do_report_used(pTHX_ SV *const sv)
426 if (SvTYPE(sv) != SVTYPEMASK) {
427 PerlIO_printf(Perl_debug_log, "****\n");
434 =for apidoc sv_report_used
436 Dump the contents of all SVs not yet freed. (Debugging aid).
442 Perl_sv_report_used(pTHX)
445 visit(do_report_used, 0, 0);
451 /* called by sv_clean_objs() for each live SV */
454 do_clean_objs(pTHX_ SV *const ref)
459 SV * const target = SvRV(ref);
460 if (SvOBJECT(target)) {
461 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
462 if (SvWEAKREF(ref)) {
463 sv_del_backref(target, ref);
469 SvREFCNT_dec(target);
474 /* XXX Might want to check arrays, etc. */
478 /* clear any slots in a GV which hold objects - except IO;
479 * called by sv_clean_objs() for each live GV */
482 do_clean_named_objs(pTHX_ SV *const sv)
486 assert(SvTYPE(sv) == SVt_PVGV);
487 assert(isGV_with_GP(sv));
491 /* freeing GP entries may indirectly free the current GV;
492 * hold onto it while we mess with the GP slots */
495 if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
496 DEBUG_D((PerlIO_printf(Perl_debug_log,
497 "Cleaning named glob SV object:\n "), sv_dump(obj)));
501 if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
502 DEBUG_D((PerlIO_printf(Perl_debug_log,
503 "Cleaning named glob AV object:\n "), sv_dump(obj)));
507 if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
508 DEBUG_D((PerlIO_printf(Perl_debug_log,
509 "Cleaning named glob HV object:\n "), sv_dump(obj)));
513 if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
514 DEBUG_D((PerlIO_printf(Perl_debug_log,
515 "Cleaning named glob CV object:\n "), sv_dump(obj)));
519 SvREFCNT_dec(sv); /* undo the inc above */
522 /* clear any IO slots in a GV which hold objects (except stderr, defout);
523 * called by sv_clean_objs() for each live GV */
526 do_clean_named_io_objs(pTHX_ SV *const sv)
530 assert(SvTYPE(sv) == SVt_PVGV);
531 assert(isGV_with_GP(sv));
532 if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
536 if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
537 DEBUG_D((PerlIO_printf(Perl_debug_log,
538 "Cleaning named glob IO object:\n "), sv_dump(obj)));
542 SvREFCNT_dec(sv); /* undo the inc above */
546 =for apidoc sv_clean_objs
548 Attempt to destroy all objects not yet freed
554 Perl_sv_clean_objs(pTHX)
558 PL_in_clean_objs = TRUE;
559 visit(do_clean_objs, SVf_ROK, SVf_ROK);
560 /* Some barnacles may yet remain, clinging to typeglobs.
561 * Run the non-IO destructors first: they may want to output
562 * error messages, close files etc */
563 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
564 visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
565 olddef = PL_defoutgv;
566 PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
567 if (olddef && isGV_with_GP(olddef))
568 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
569 olderr = PL_stderrgv;
570 PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
571 if (olderr && isGV_with_GP(olderr))
572 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
573 SvREFCNT_dec(olddef);
574 PL_in_clean_objs = FALSE;
577 /* called by sv_clean_all() for each live SV */
580 do_clean_all(pTHX_ SV *const sv)
583 if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
584 /* don't clean pid table and strtab */
587 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
588 SvFLAGS(sv) |= SVf_BREAK;
593 =for apidoc sv_clean_all
595 Decrement the refcnt of each remaining SV, possibly triggering a
596 cleanup. This function may have to be called multiple times to free
597 SVs which are in complex self-referential hierarchies.
603 Perl_sv_clean_all(pTHX)
607 PL_in_clean_all = TRUE;
608 cleaned = visit(do_clean_all, 0,0);
613 ARENASETS: a meta-arena implementation which separates arena-info
614 into struct arena_set, which contains an array of struct
615 arena_descs, each holding info for a single arena. By separating
616 the meta-info from the arena, we recover the 1st slot, formerly
617 borrowed for list management. The arena_set is about the size of an
618 arena, avoiding the needless malloc overhead of a naive linked-list.
620 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
621 memory in the last arena-set (1/2 on average). In trade, we get
622 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
623 smaller types). The recovery of the wasted space allows use of
624 small arenas for large, rare body types, by changing array* fields
625 in body_details_by_type[] below.
628 char *arena; /* the raw storage, allocated aligned */
629 size_t size; /* its size ~4k typ */
630 svtype utype; /* bodytype stored in arena */
635 /* Get the maximum number of elements in set[] such that struct arena_set
636 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
637 therefore likely to be 1 aligned memory page. */
639 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
640 - 2 * sizeof(int)) / sizeof (struct arena_desc))
643 struct arena_set* next;
644 unsigned int set_size; /* ie ARENAS_PER_SET */
645 unsigned int curr; /* index of next available arena-desc */
646 struct arena_desc set[ARENAS_PER_SET];
650 =for apidoc sv_free_arenas
652 Deallocate the memory used by all arenas. Note that all the individual SV
653 heads and bodies within the arenas must already have been freed.
658 Perl_sv_free_arenas(pTHX)
665 /* Free arenas here, but be careful about fake ones. (We assume
666 contiguity of the fake ones with the corresponding real ones.) */
668 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
669 svanext = MUTABLE_SV(SvANY(sva));
670 while (svanext && SvFAKE(svanext))
671 svanext = MUTABLE_SV(SvANY(svanext));
678 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
681 struct arena_set *current = aroot;
684 assert(aroot->set[i].arena);
685 Safefree(aroot->set[i].arena);
693 i = PERL_ARENA_ROOTS_SIZE;
695 PL_body_roots[i] = 0;
702 Here are mid-level routines that manage the allocation of bodies out
703 of the various arenas. There are 5 kinds of arenas:
705 1. SV-head arenas, which are discussed and handled above
706 2. regular body arenas
707 3. arenas for reduced-size bodies
710 Arena types 2 & 3 are chained by body-type off an array of
711 arena-root pointers, which is indexed by svtype. Some of the
712 larger/less used body types are malloced singly, since a large
713 unused block of them is wasteful. Also, several svtypes dont have
714 bodies; the data fits into the sv-head itself. The arena-root
715 pointer thus has a few unused root-pointers (which may be hijacked
716 later for arena types 4,5)
718 3 differs from 2 as an optimization; some body types have several
719 unused fields in the front of the structure (which are kept in-place
720 for consistency). These bodies can be allocated in smaller chunks,
721 because the leading fields arent accessed. Pointers to such bodies
722 are decremented to point at the unused 'ghost' memory, knowing that
723 the pointers are used with offsets to the real memory.
726 =head1 SV-Body Allocation
728 Allocation of SV-bodies is similar to SV-heads, differing as follows;
729 the allocation mechanism is used for many body types, so is somewhat
730 more complicated, it uses arena-sets, and has no need for still-live
733 At the outermost level, (new|del)_X*V macros return bodies of the
734 appropriate type. These macros call either (new|del)_body_type or
735 (new|del)_body_allocated macro pairs, depending on specifics of the
736 type. Most body types use the former pair, the latter pair is used to
737 allocate body types with "ghost fields".
739 "ghost fields" are fields that are unused in certain types, and
740 consequently don't need to actually exist. They are declared because
741 they're part of a "base type", which allows use of functions as
742 methods. The simplest examples are AVs and HVs, 2 aggregate types
743 which don't use the fields which support SCALAR semantics.
745 For these types, the arenas are carved up into appropriately sized
746 chunks, we thus avoid wasted memory for those unaccessed members.
747 When bodies are allocated, we adjust the pointer back in memory by the
748 size of the part not allocated, so it's as if we allocated the full
749 structure. (But things will all go boom if you write to the part that
750 is "not there", because you'll be overwriting the last members of the
751 preceding structure in memory.)
753 We calculate the correction using the STRUCT_OFFSET macro on the first
754 member present. If the allocated structure is smaller (no initial NV
755 actually allocated) then the net effect is to subtract the size of the NV
756 from the pointer, to return a new pointer as if an initial NV were actually
757 allocated. (We were using structures named *_allocated for this, but
758 this turned out to be a subtle bug, because a structure without an NV
759 could have a lower alignment constraint, but the compiler is allowed to
760 optimised accesses based on the alignment constraint of the actual pointer
761 to the full structure, for example, using a single 64 bit load instruction
762 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
764 This is the same trick as was used for NV and IV bodies. Ironically it
765 doesn't need to be used for NV bodies any more, because NV is now at
766 the start of the structure. IV bodies don't need it either, because
767 they are no longer allocated.
769 In turn, the new_body_* allocators call S_new_body(), which invokes
770 new_body_inline macro, which takes a lock, and takes a body off the
771 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
772 necessary to refresh an empty list. Then the lock is released, and
773 the body is returned.
775 Perl_more_bodies allocates a new arena, and carves it up into an array of N
776 bodies, which it strings into a linked list. It looks up arena-size
777 and body-size from the body_details table described below, thus
778 supporting the multiple body-types.
780 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
781 the (new|del)_X*V macros are mapped directly to malloc/free.
783 For each sv-type, struct body_details bodies_by_type[] carries
784 parameters which control these aspects of SV handling:
786 Arena_size determines whether arenas are used for this body type, and if
787 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
788 zero, forcing individual mallocs and frees.
790 Body_size determines how big a body is, and therefore how many fit into
791 each arena. Offset carries the body-pointer adjustment needed for
792 "ghost fields", and is used in *_allocated macros.
794 But its main purpose is to parameterize info needed in
795 Perl_sv_upgrade(). The info here dramatically simplifies the function
796 vs the implementation in 5.8.8, making it table-driven. All fields
797 are used for this, except for arena_size.
799 For the sv-types that have no bodies, arenas are not used, so those
800 PL_body_roots[sv_type] are unused, and can be overloaded. In
801 something of a special case, SVt_NULL is borrowed for HE arenas;
802 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
803 bodies_by_type[SVt_NULL] slot is not used, as the table is not
808 struct body_details {
809 U8 body_size; /* Size to allocate */
810 U8 copy; /* Size of structure to copy (may be shorter) */
812 unsigned int type : 4; /* We have space for a sanity check. */
813 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
814 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
815 unsigned int arena : 1; /* Allocated from an arena */
816 size_t arena_size; /* Size of arena to allocate */
824 /* With -DPURFIY we allocate everything directly, and don't use arenas.
825 This seems a rather elegant way to simplify some of the code below. */
826 #define HASARENA FALSE
828 #define HASARENA TRUE
830 #define NOARENA FALSE
832 /* Size the arenas to exactly fit a given number of bodies. A count
833 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
834 simplifying the default. If count > 0, the arena is sized to fit
835 only that many bodies, allowing arenas to be used for large, rare
836 bodies (XPVFM, XPVIO) without undue waste. The arena size is
837 limited by PERL_ARENA_SIZE, so we can safely oversize the
840 #define FIT_ARENA0(body_size) \
841 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
842 #define FIT_ARENAn(count,body_size) \
843 ( count * body_size <= PERL_ARENA_SIZE) \
844 ? count * body_size \
845 : FIT_ARENA0 (body_size)
846 #define FIT_ARENA(count,body_size) \
848 ? FIT_ARENAn (count, body_size) \
849 : FIT_ARENA0 (body_size)
851 /* Calculate the length to copy. Specifically work out the length less any
852 final padding the compiler needed to add. See the comment in sv_upgrade
853 for why copying the padding proved to be a bug. */
855 #define copy_length(type, last_member) \
856 STRUCT_OFFSET(type, last_member) \
857 + sizeof (((type*)SvANY((const SV *)0))->last_member)
859 static const struct body_details bodies_by_type[] = {
860 /* HEs use this offset for their arena. */
861 { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
863 /* The bind placeholder pretends to be an RV for now.
864 Also it's marked as "can't upgrade" to stop anyone using it before it's
866 { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
868 /* IVs are in the head, so the allocation size is 0. */
870 sizeof(IV), /* This is used to copy out the IV body. */
871 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
872 NOARENA /* IVS don't need an arena */, 0
875 /* 8 bytes on most ILP32 with IEEE doubles */
876 { sizeof(NV), sizeof(NV),
877 STRUCT_OFFSET(XPVNV, xnv_u),
878 SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
880 /* 8 bytes on most ILP32 with IEEE doubles */
881 { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
882 copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
883 + STRUCT_OFFSET(XPV, xpv_cur),
884 SVt_PV, FALSE, NONV, HASARENA,
885 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
888 { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
889 copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
890 + STRUCT_OFFSET(XPV, xpv_cur),
891 SVt_PVIV, FALSE, NONV, HASARENA,
892 FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
895 { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
896 copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
897 + STRUCT_OFFSET(XPV, xpv_cur),
898 SVt_PVNV, FALSE, HADNV, HASARENA,
899 FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
902 { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
903 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
909 SVt_REGEXP, FALSE, NONV, HASARENA,
910 FIT_ARENA(0, sizeof(regexp))
914 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
915 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
918 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
919 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
922 copy_length(XPVAV, xav_alloc),
924 SVt_PVAV, TRUE, NONV, HASARENA,
925 FIT_ARENA(0, sizeof(XPVAV)) },
928 copy_length(XPVHV, xhv_max),
930 SVt_PVHV, TRUE, NONV, HASARENA,
931 FIT_ARENA(0, sizeof(XPVHV)) },
937 SVt_PVCV, TRUE, NONV, HASARENA,
938 FIT_ARENA(0, sizeof(XPVCV)) },
943 SVt_PVFM, TRUE, NONV, NOARENA,
944 FIT_ARENA(20, sizeof(XPVFM)) },
946 /* XPVIO is 84 bytes, fits 48x */
950 SVt_PVIO, TRUE, NONV, HASARENA,
951 FIT_ARENA(24, sizeof(XPVIO)) },
954 #define new_body_allocated(sv_type) \
955 (void *)((char *)S_new_body(aTHX_ sv_type) \
956 - bodies_by_type[sv_type].offset)
958 /* return a thing to the free list */
960 #define del_body(thing, root) \
962 void ** const thing_copy = (void **)thing; \
963 *thing_copy = *root; \
964 *root = (void*)thing_copy; \
969 #define new_XNV() safemalloc(sizeof(XPVNV))
970 #define new_XPVNV() safemalloc(sizeof(XPVNV))
971 #define new_XPVMG() safemalloc(sizeof(XPVMG))
973 #define del_XPVGV(p) safefree(p)
977 #define new_XNV() new_body_allocated(SVt_NV)
978 #define new_XPVNV() new_body_allocated(SVt_PVNV)
979 #define new_XPVMG() new_body_allocated(SVt_PVMG)
981 #define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \
982 &PL_body_roots[SVt_PVGV])
986 /* no arena for you! */
988 #define new_NOARENA(details) \
989 safemalloc((details)->body_size + (details)->offset)
990 #define new_NOARENAZ(details) \
991 safecalloc((details)->body_size + (details)->offset, 1)
994 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
995 const size_t arena_size)
998 void ** const root = &PL_body_roots[sv_type];
999 struct arena_desc *adesc;
1000 struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1004 const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1005 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1006 static bool done_sanity_check;
1008 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1009 * variables like done_sanity_check. */
1010 if (!done_sanity_check) {
1011 unsigned int i = SVt_LAST;
1013 done_sanity_check = TRUE;
1016 assert (bodies_by_type[i].type == i);
1022 /* may need new arena-set to hold new arena */
1023 if (!aroot || aroot->curr >= aroot->set_size) {
1024 struct arena_set *newroot;
1025 Newxz(newroot, 1, struct arena_set);
1026 newroot->set_size = ARENAS_PER_SET;
1027 newroot->next = aroot;
1029 PL_body_arenas = (void *) newroot;
1030 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1033 /* ok, now have arena-set with at least 1 empty/available arena-desc */
1034 curr = aroot->curr++;
1035 adesc = &(aroot->set[curr]);
1036 assert(!adesc->arena);
1038 Newx(adesc->arena, good_arena_size, char);
1039 adesc->size = good_arena_size;
1040 adesc->utype = sv_type;
1041 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
1042 curr, (void*)adesc->arena, (UV)good_arena_size));
1044 start = (char *) adesc->arena;
1046 /* Get the address of the byte after the end of the last body we can fit.
1047 Remember, this is integer division: */
1048 end = start + good_arena_size / body_size * body_size;
1050 /* computed count doesnt reflect the 1st slot reservation */
1051 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1052 DEBUG_m(PerlIO_printf(Perl_debug_log,
1053 "arena %p end %p arena-size %d (from %d) type %d "
1055 (void*)start, (void*)end, (int)good_arena_size,
1056 (int)arena_size, sv_type, (int)body_size,
1057 (int)good_arena_size / (int)body_size));
1059 DEBUG_m(PerlIO_printf(Perl_debug_log,
1060 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1061 (void*)start, (void*)end,
1062 (int)arena_size, sv_type, (int)body_size,
1063 (int)good_arena_size / (int)body_size));
1065 *root = (void *)start;
1068 /* Where the next body would start: */
1069 char * const next = start + body_size;
1072 /* This is the last body: */
1073 assert(next == end);
1075 *(void **)start = 0;
1079 *(void**) start = (void *)next;
1084 /* grab a new thing from the free list, allocating more if necessary.
1085 The inline version is used for speed in hot routines, and the
1086 function using it serves the rest (unless PURIFY).
1088 #define new_body_inline(xpv, sv_type) \
1090 void ** const r3wt = &PL_body_roots[sv_type]; \
1091 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1092 ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1093 bodies_by_type[sv_type].body_size,\
1094 bodies_by_type[sv_type].arena_size)); \
1095 *(r3wt) = *(void**)(xpv); \
1101 S_new_body(pTHX_ const svtype sv_type)
1105 new_body_inline(xpv, sv_type);
1111 static const struct body_details fake_rv =
1112 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1115 =for apidoc sv_upgrade
1117 Upgrade an SV to a more complex form. Generally adds a new body type to the
1118 SV, then copies across as much information as possible from the old body.
1119 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1125 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1130 const svtype old_type = SvTYPE(sv);
1131 const struct body_details *new_type_details;
1132 const struct body_details *old_type_details
1133 = bodies_by_type + old_type;
1134 SV *referant = NULL;
1136 PERL_ARGS_ASSERT_SV_UPGRADE;
1138 if (old_type == new_type)
1141 /* This clause was purposefully added ahead of the early return above to
1142 the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1143 inference by Nick I-S that it would fix other troublesome cases. See
1144 changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1146 Given that shared hash key scalars are no longer PVIV, but PV, there is
1147 no longer need to unshare so as to free up the IVX slot for its proper
1148 purpose. So it's safe to move the early return earlier. */
1150 if (new_type != SVt_PV && SvIsCOW(sv)) {
1151 sv_force_normal_flags(sv, 0);
1154 old_body = SvANY(sv);
1156 /* Copying structures onto other structures that have been neatly zeroed
1157 has a subtle gotcha. Consider XPVMG
1159 +------+------+------+------+------+-------+-------+
1160 | NV | CUR | LEN | IV | MAGIC | STASH |
1161 +------+------+------+------+------+-------+-------+
1162 0 4 8 12 16 20 24 28
1164 where NVs are aligned to 8 bytes, so that sizeof that structure is
1165 actually 32 bytes long, with 4 bytes of padding at the end:
1167 +------+------+------+------+------+-------+-------+------+
1168 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1169 +------+------+------+------+------+-------+-------+------+
1170 0 4 8 12 16 20 24 28 32
1172 so what happens if you allocate memory for this structure:
1174 +------+------+------+------+------+-------+-------+------+------+...
1175 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1176 +------+------+------+------+------+-------+-------+------+------+...
1177 0 4 8 12 16 20 24 28 32 36
1179 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1180 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1181 started out as zero once, but it's quite possible that it isn't. So now,
1182 rather than a nicely zeroed GP, you have it pointing somewhere random.
1185 (In fact, GP ends up pointing at a previous GP structure, because the
1186 principle cause of the padding in XPVMG getting garbage is a copy of
1187 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1188 this happens to be moot because XPVGV has been re-ordered, with GP
1189 no longer after STASH)
1191 So we are careful and work out the size of used parts of all the
1199 referant = SvRV(sv);
1200 old_type_details = &fake_rv;
1201 if (new_type == SVt_NV)
1202 new_type = SVt_PVNV;
1204 if (new_type < SVt_PVIV) {
1205 new_type = (new_type == SVt_NV)
1206 ? SVt_PVNV : SVt_PVIV;
1211 if (new_type < SVt_PVNV) {
1212 new_type = SVt_PVNV;
1216 assert(new_type > SVt_PV);
1217 assert(SVt_IV < SVt_PV);
1218 assert(SVt_NV < SVt_PV);
1225 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1226 there's no way that it can be safely upgraded, because perl.c
1227 expects to Safefree(SvANY(PL_mess_sv)) */
1228 assert(sv != PL_mess_sv);
1229 /* This flag bit is used to mean other things in other scalar types.
1230 Given that it only has meaning inside the pad, it shouldn't be set
1231 on anything that can get upgraded. */
1232 assert(!SvPAD_TYPED(sv));
1235 if (old_type_details->cant_upgrade)
1236 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1237 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1240 if (old_type > new_type)
1241 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1242 (int)old_type, (int)new_type);
1244 new_type_details = bodies_by_type + new_type;
1246 SvFLAGS(sv) &= ~SVTYPEMASK;
1247 SvFLAGS(sv) |= new_type;
1249 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1250 the return statements above will have triggered. */
1251 assert (new_type != SVt_NULL);
1254 assert(old_type == SVt_NULL);
1255 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1259 assert(old_type == SVt_NULL);
1260 SvANY(sv) = new_XNV();
1265 assert(new_type_details->body_size);
1268 assert(new_type_details->arena);
1269 assert(new_type_details->arena_size);
1270 /* This points to the start of the allocated area. */
1271 new_body_inline(new_body, new_type);
1272 Zero(new_body, new_type_details->body_size, char);
1273 new_body = ((char *)new_body) - new_type_details->offset;
1275 /* We always allocated the full length item with PURIFY. To do this
1276 we fake things so that arena is false for all 16 types.. */
1277 new_body = new_NOARENAZ(new_type_details);
1279 SvANY(sv) = new_body;
1280 if (new_type == SVt_PVAV) {
1284 if (old_type_details->body_size) {
1287 /* It will have been zeroed when the new body was allocated.
1288 Lets not write to it, in case it confuses a write-back
1294 #ifndef NODEFAULT_SHAREKEYS
1295 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1297 HvMAX(sv) = 7; /* (start with 8 buckets) */
1300 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1301 The target created by newSVrv also is, and it can have magic.
1302 However, it never has SvPVX set.
1304 if (old_type == SVt_IV) {
1306 } else if (old_type >= SVt_PV) {
1307 assert(SvPVX_const(sv) == 0);
1310 if (old_type >= SVt_PVMG) {
1311 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1312 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1314 sv->sv_u.svu_array = NULL; /* or svu_hash */
1320 /* This ensures that SvTHINKFIRST(sv) is true, and hence that
1321 sv_force_normal_flags(sv) is called. */
1324 /* XXX Is this still needed? Was it ever needed? Surely as there is
1325 no route from NV to PVIV, NOK can never be true */
1326 assert(!SvNOKp(sv));
1337 assert(new_type_details->body_size);
1338 /* We always allocated the full length item with PURIFY. To do this
1339 we fake things so that arena is false for all 16 types.. */
1340 if(new_type_details->arena) {
1341 /* This points to the start of the allocated area. */
1342 new_body_inline(new_body, new_type);
1343 Zero(new_body, new_type_details->body_size, char);
1344 new_body = ((char *)new_body) - new_type_details->offset;
1346 new_body = new_NOARENAZ(new_type_details);
1348 SvANY(sv) = new_body;
1350 if (old_type_details->copy) {
1351 /* There is now the potential for an upgrade from something without
1352 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1353 int offset = old_type_details->offset;
1354 int length = old_type_details->copy;
1356 if (new_type_details->offset > old_type_details->offset) {
1357 const int difference
1358 = new_type_details->offset - old_type_details->offset;
1359 offset += difference;
1360 length -= difference;
1362 assert (length >= 0);
1364 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1368 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1369 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1370 * correct 0.0 for us. Otherwise, if the old body didn't have an
1371 * NV slot, but the new one does, then we need to initialise the
1372 * freshly created NV slot with whatever the correct bit pattern is
1374 if (old_type_details->zero_nv && !new_type_details->zero_nv
1375 && !isGV_with_GP(sv))
1379 if (new_type == SVt_PVIO) {
1380 IO * const io = MUTABLE_IO(sv);
1381 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1384 /* Clear the stashcache because a new IO could overrule a package
1386 hv_clear(PL_stashcache);
1388 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1389 IoPAGE_LEN(sv) = 60;
1391 if (old_type < SVt_PV) {
1392 /* referant will be NULL unless the old type was SVt_IV emulating
1394 sv->sv_u.svu_rv = referant;
1398 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1399 (unsigned long)new_type);
1402 if (old_type > SVt_IV) {
1406 /* Note that there is an assumption that all bodies of types that
1407 can be upgraded came from arenas. Only the more complex non-
1408 upgradable types are allowed to be directly malloc()ed. */
1409 assert(old_type_details->arena);
1410 del_body((void*)((char*)old_body + old_type_details->offset),
1411 &PL_body_roots[old_type]);
1417 =for apidoc sv_backoff
1419 Remove any string offset. You should normally use the C<SvOOK_off> macro
1426 Perl_sv_backoff(pTHX_ register SV *const sv)
1429 const char * const s = SvPVX_const(sv);
1431 PERL_ARGS_ASSERT_SV_BACKOFF;
1432 PERL_UNUSED_CONTEXT;
1435 assert(SvTYPE(sv) != SVt_PVHV);
1436 assert(SvTYPE(sv) != SVt_PVAV);
1438 SvOOK_offset(sv, delta);
1440 SvLEN_set(sv, SvLEN(sv) + delta);
1441 SvPV_set(sv, SvPVX(sv) - delta);
1442 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1443 SvFLAGS(sv) &= ~SVf_OOK;
1450 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1451 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1452 Use the C<SvGROW> wrapper instead.
1458 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1462 PERL_ARGS_ASSERT_SV_GROW;
1464 if (PL_madskills && newlen >= 0x100000) {
1465 PerlIO_printf(Perl_debug_log,
1466 "Allocation too large: %"UVxf"\n", (UV)newlen);
1468 #ifdef HAS_64K_LIMIT
1469 if (newlen >= 0x10000) {
1470 PerlIO_printf(Perl_debug_log,
1471 "Allocation too large: %"UVxf"\n", (UV)newlen);
1474 #endif /* HAS_64K_LIMIT */
1477 if (SvTYPE(sv) < SVt_PV) {
1478 sv_upgrade(sv, SVt_PV);
1479 s = SvPVX_mutable(sv);
1481 else if (SvOOK(sv)) { /* pv is offset? */
1483 s = SvPVX_mutable(sv);
1484 if (newlen > SvLEN(sv))
1485 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1486 #ifdef HAS_64K_LIMIT
1487 if (newlen >= 0x10000)
1492 s = SvPVX_mutable(sv);
1494 if (newlen > SvLEN(sv)) { /* need more room? */
1495 STRLEN minlen = SvCUR(sv);
1496 minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1497 if (newlen < minlen)
1499 #ifndef Perl_safesysmalloc_size
1500 newlen = PERL_STRLEN_ROUNDUP(newlen);
1502 if (SvLEN(sv) && s) {
1503 s = (char*)saferealloc(s, newlen);
1506 s = (char*)safemalloc(newlen);
1507 if (SvPVX_const(sv) && SvCUR(sv)) {
1508 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1512 #ifdef Perl_safesysmalloc_size
1513 /* Do this here, do it once, do it right, and then we will never get
1514 called back into sv_grow() unless there really is some growing
1516 SvLEN_set(sv, Perl_safesysmalloc_size(s));
1518 SvLEN_set(sv, newlen);
1525 =for apidoc sv_setiv
1527 Copies an integer into the given SV, upgrading first if necessary.
1528 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1534 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1538 PERL_ARGS_ASSERT_SV_SETIV;
1540 SV_CHECK_THINKFIRST_COW_DROP(sv);
1541 switch (SvTYPE(sv)) {
1544 sv_upgrade(sv, SVt_IV);
1547 sv_upgrade(sv, SVt_PVIV);
1551 if (!isGV_with_GP(sv))
1558 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1562 (void)SvIOK_only(sv); /* validate number */
1568 =for apidoc sv_setiv_mg
1570 Like C<sv_setiv>, but also handles 'set' magic.
1576 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1578 PERL_ARGS_ASSERT_SV_SETIV_MG;
1585 =for apidoc sv_setuv
1587 Copies an unsigned integer into the given SV, upgrading first if necessary.
1588 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1594 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1596 PERL_ARGS_ASSERT_SV_SETUV;
1598 /* With these two if statements:
1599 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1602 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1604 If you wish to remove them, please benchmark to see what the effect is
1606 if (u <= (UV)IV_MAX) {
1607 sv_setiv(sv, (IV)u);
1616 =for apidoc sv_setuv_mg
1618 Like C<sv_setuv>, but also handles 'set' magic.
1624 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1626 PERL_ARGS_ASSERT_SV_SETUV_MG;
1633 =for apidoc sv_setnv
1635 Copies a double into the given SV, upgrading first if necessary.
1636 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1642 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1646 PERL_ARGS_ASSERT_SV_SETNV;
1648 SV_CHECK_THINKFIRST_COW_DROP(sv);
1649 switch (SvTYPE(sv)) {
1652 sv_upgrade(sv, SVt_NV);
1656 sv_upgrade(sv, SVt_PVNV);
1660 if (!isGV_with_GP(sv))
1667 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1672 (void)SvNOK_only(sv); /* validate number */
1677 =for apidoc sv_setnv_mg
1679 Like C<sv_setnv>, but also handles 'set' magic.
1685 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1687 PERL_ARGS_ASSERT_SV_SETNV_MG;
1693 /* Print an "isn't numeric" warning, using a cleaned-up,
1694 * printable version of the offending string
1698 S_not_a_number(pTHX_ SV *const sv)
1705 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1708 dsv = newSVpvs_flags("", SVs_TEMP);
1709 pv = sv_uni_display(dsv, sv, 10, 0);
1712 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1713 /* each *s can expand to 4 chars + "...\0",
1714 i.e. need room for 8 chars */
1716 const char *s = SvPVX_const(sv);
1717 const char * const end = s + SvCUR(sv);
1718 for ( ; s < end && d < limit; s++ ) {
1720 if (ch & 128 && !isPRINT_LC(ch)) {
1729 else if (ch == '\r') {
1733 else if (ch == '\f') {
1737 else if (ch == '\\') {
1741 else if (ch == '\0') {
1745 else if (isPRINT_LC(ch))
1762 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1763 "Argument \"%s\" isn't numeric in %s", pv,
1766 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1767 "Argument \"%s\" isn't numeric", pv);
1771 =for apidoc looks_like_number
1773 Test if the content of an SV looks like a number (or is a number).
1774 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1775 non-numeric warning), even if your atof() doesn't grok them.
1781 Perl_looks_like_number(pTHX_ SV *const sv)
1783 register const char *sbegin;
1786 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1789 sbegin = SvPVX_const(sv);
1792 else if (SvPOKp(sv))
1793 sbegin = SvPV_const(sv, len);
1795 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1796 return grok_number(sbegin, len, NULL);
1800 S_glob_2number(pTHX_ GV * const gv)
1802 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1803 SV *const buffer = sv_newmortal();
1805 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1807 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1810 gv_efullname3(buffer, gv, "*");
1811 SvFLAGS(gv) |= wasfake;
1813 /* We know that all GVs stringify to something that is not-a-number,
1814 so no need to test that. */
1815 if (ckWARN(WARN_NUMERIC))
1816 not_a_number(buffer);
1817 /* We just want something true to return, so that S_sv_2iuv_common
1818 can tail call us and return true. */
1822 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1823 until proven guilty, assume that things are not that bad... */
1828 As 64 bit platforms often have an NV that doesn't preserve all bits of
1829 an IV (an assumption perl has been based on to date) it becomes necessary
1830 to remove the assumption that the NV always carries enough precision to
1831 recreate the IV whenever needed, and that the NV is the canonical form.
1832 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1833 precision as a side effect of conversion (which would lead to insanity
1834 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1835 1) to distinguish between IV/UV/NV slots that have cached a valid
1836 conversion where precision was lost and IV/UV/NV slots that have a
1837 valid conversion which has lost no precision
1838 2) to ensure that if a numeric conversion to one form is requested that
1839 would lose precision, the precise conversion (or differently
1840 imprecise conversion) is also performed and cached, to prevent
1841 requests for different numeric formats on the same SV causing
1842 lossy conversion chains. (lossless conversion chains are perfectly
1847 SvIOKp is true if the IV slot contains a valid value
1848 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1849 SvNOKp is true if the NV slot contains a valid value
1850 SvNOK is true only if the NV value is accurate
1853 while converting from PV to NV, check to see if converting that NV to an
1854 IV(or UV) would lose accuracy over a direct conversion from PV to
1855 IV(or UV). If it would, cache both conversions, return NV, but mark
1856 SV as IOK NOKp (ie not NOK).
1858 While converting from PV to IV, check to see if converting that IV to an
1859 NV would lose accuracy over a direct conversion from PV to NV. If it
1860 would, cache both conversions, flag similarly.
1862 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1863 correctly because if IV & NV were set NV *always* overruled.
1864 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1865 changes - now IV and NV together means that the two are interchangeable:
1866 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1868 The benefit of this is that operations such as pp_add know that if
1869 SvIOK is true for both left and right operands, then integer addition
1870 can be used instead of floating point (for cases where the result won't
1871 overflow). Before, floating point was always used, which could lead to
1872 loss of precision compared with integer addition.
1874 * making IV and NV equal status should make maths accurate on 64 bit
1876 * may speed up maths somewhat if pp_add and friends start to use
1877 integers when possible instead of fp. (Hopefully the overhead in
1878 looking for SvIOK and checking for overflow will not outweigh the
1879 fp to integer speedup)
1880 * will slow down integer operations (callers of SvIV) on "inaccurate"
1881 values, as the change from SvIOK to SvIOKp will cause a call into
1882 sv_2iv each time rather than a macro access direct to the IV slot
1883 * should speed up number->string conversion on integers as IV is
1884 favoured when IV and NV are equally accurate
1886 ####################################################################
1887 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1888 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1889 On the other hand, SvUOK is true iff UV.
1890 ####################################################################
1892 Your mileage will vary depending your CPU's relative fp to integer
1896 #ifndef NV_PRESERVES_UV
1897 # define IS_NUMBER_UNDERFLOW_IV 1
1898 # define IS_NUMBER_UNDERFLOW_UV 2
1899 # define IS_NUMBER_IV_AND_UV 2
1900 # define IS_NUMBER_OVERFLOW_IV 4
1901 # define IS_NUMBER_OVERFLOW_UV 5
1903 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1905 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1907 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1915 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1917 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));
1918 if (SvNVX(sv) < (NV)IV_MIN) {
1919 (void)SvIOKp_on(sv);
1921 SvIV_set(sv, IV_MIN);
1922 return IS_NUMBER_UNDERFLOW_IV;
1924 if (SvNVX(sv) > (NV)UV_MAX) {
1925 (void)SvIOKp_on(sv);
1928 SvUV_set(sv, UV_MAX);
1929 return IS_NUMBER_OVERFLOW_UV;
1931 (void)SvIOKp_on(sv);
1933 /* Can't use strtol etc to convert this string. (See truth table in
1935 if (SvNVX(sv) <= (UV)IV_MAX) {
1936 SvIV_set(sv, I_V(SvNVX(sv)));
1937 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1938 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1940 /* Integer is imprecise. NOK, IOKp */
1942 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1945 SvUV_set(sv, U_V(SvNVX(sv)));
1946 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1947 if (SvUVX(sv) == UV_MAX) {
1948 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1949 possibly be preserved by NV. Hence, it must be overflow.
1951 return IS_NUMBER_OVERFLOW_UV;
1953 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1955 /* Integer is imprecise. NOK, IOKp */
1957 return IS_NUMBER_OVERFLOW_IV;
1959 #endif /* !NV_PRESERVES_UV*/
1962 S_sv_2iuv_common(pTHX_ SV *const sv)
1966 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
1969 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1970 * without also getting a cached IV/UV from it at the same time
1971 * (ie PV->NV conversion should detect loss of accuracy and cache
1972 * IV or UV at same time to avoid this. */
1973 /* IV-over-UV optimisation - choose to cache IV if possible */
1975 if (SvTYPE(sv) == SVt_NV)
1976 sv_upgrade(sv, SVt_PVNV);
1978 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1979 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1980 certainly cast into the IV range at IV_MAX, whereas the correct
1981 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1983 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1984 if (Perl_isnan(SvNVX(sv))) {
1990 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1991 SvIV_set(sv, I_V(SvNVX(sv)));
1992 if (SvNVX(sv) == (NV) SvIVX(sv)
1993 #ifndef NV_PRESERVES_UV
1994 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1995 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1996 /* Don't flag it as "accurately an integer" if the number
1997 came from a (by definition imprecise) NV operation, and
1998 we're outside the range of NV integer precision */
2002 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2004 /* scalar has trailing garbage, eg "42a" */
2006 DEBUG_c(PerlIO_printf(Perl_debug_log,
2007 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2013 /* IV not precise. No need to convert from PV, as NV
2014 conversion would already have cached IV if it detected
2015 that PV->IV would be better than PV->NV->IV
2016 flags already correct - don't set public IOK. */
2017 DEBUG_c(PerlIO_printf(Perl_debug_log,
2018 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2023 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2024 but the cast (NV)IV_MIN rounds to a the value less (more
2025 negative) than IV_MIN which happens to be equal to SvNVX ??
2026 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2027 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2028 (NV)UVX == NVX are both true, but the values differ. :-(
2029 Hopefully for 2s complement IV_MIN is something like
2030 0x8000000000000000 which will be exact. NWC */
2033 SvUV_set(sv, U_V(SvNVX(sv)));
2035 (SvNVX(sv) == (NV) SvUVX(sv))
2036 #ifndef NV_PRESERVES_UV
2037 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2038 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2039 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2040 /* Don't flag it as "accurately an integer" if the number
2041 came from a (by definition imprecise) NV operation, and
2042 we're outside the range of NV integer precision */
2048 DEBUG_c(PerlIO_printf(Perl_debug_log,
2049 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2055 else if (SvPOKp(sv) && SvLEN(sv)) {
2057 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2058 /* We want to avoid a possible problem when we cache an IV/ a UV which
2059 may be later translated to an NV, and the resulting NV is not
2060 the same as the direct translation of the initial string
2061 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2062 be careful to ensure that the value with the .456 is around if the
2063 NV value is requested in the future).
2065 This means that if we cache such an IV/a UV, we need to cache the
2066 NV as well. Moreover, we trade speed for space, and do not
2067 cache the NV if we are sure it's not needed.
2070 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2071 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2072 == IS_NUMBER_IN_UV) {
2073 /* It's definitely an integer, only upgrade to PVIV */
2074 if (SvTYPE(sv) < SVt_PVIV)
2075 sv_upgrade(sv, SVt_PVIV);
2077 } else if (SvTYPE(sv) < SVt_PVNV)
2078 sv_upgrade(sv, SVt_PVNV);
2080 /* If NVs preserve UVs then we only use the UV value if we know that
2081 we aren't going to call atof() below. If NVs don't preserve UVs
2082 then the value returned may have more precision than atof() will
2083 return, even though value isn't perfectly accurate. */
2084 if ((numtype & (IS_NUMBER_IN_UV
2085 #ifdef NV_PRESERVES_UV
2088 )) == IS_NUMBER_IN_UV) {
2089 /* This won't turn off the public IOK flag if it was set above */
2090 (void)SvIOKp_on(sv);
2092 if (!(numtype & IS_NUMBER_NEG)) {
2094 if (value <= (UV)IV_MAX) {
2095 SvIV_set(sv, (IV)value);
2097 /* it didn't overflow, and it was positive. */
2098 SvUV_set(sv, value);
2102 /* 2s complement assumption */
2103 if (value <= (UV)IV_MIN) {
2104 SvIV_set(sv, -(IV)value);
2106 /* Too negative for an IV. This is a double upgrade, but
2107 I'm assuming it will be rare. */
2108 if (SvTYPE(sv) < SVt_PVNV)
2109 sv_upgrade(sv, SVt_PVNV);
2113 SvNV_set(sv, -(NV)value);
2114 SvIV_set(sv, IV_MIN);
2118 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2119 will be in the previous block to set the IV slot, and the next
2120 block to set the NV slot. So no else here. */
2122 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2123 != IS_NUMBER_IN_UV) {
2124 /* It wasn't an (integer that doesn't overflow the UV). */
2125 SvNV_set(sv, Atof(SvPVX_const(sv)));
2127 if (! numtype && ckWARN(WARN_NUMERIC))
2130 #if defined(USE_LONG_DOUBLE)
2131 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2132 PTR2UV(sv), SvNVX(sv)));
2134 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2135 PTR2UV(sv), SvNVX(sv)));
2138 #ifdef NV_PRESERVES_UV
2139 (void)SvIOKp_on(sv);
2141 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2142 SvIV_set(sv, I_V(SvNVX(sv)));
2143 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2146 NOOP; /* Integer is imprecise. NOK, IOKp */
2148 /* UV will not work better than IV */
2150 if (SvNVX(sv) > (NV)UV_MAX) {
2152 /* Integer is inaccurate. NOK, IOKp, is UV */
2153 SvUV_set(sv, UV_MAX);
2155 SvUV_set(sv, U_V(SvNVX(sv)));
2156 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2157 NV preservse UV so can do correct comparison. */
2158 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2161 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
2166 #else /* NV_PRESERVES_UV */
2167 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2168 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2169 /* The IV/UV slot will have been set from value returned by
2170 grok_number above. The NV slot has just been set using
2173 assert (SvIOKp(sv));
2175 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2176 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2177 /* Small enough to preserve all bits. */
2178 (void)SvIOKp_on(sv);
2180 SvIV_set(sv, I_V(SvNVX(sv)));
2181 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2183 /* Assumption: first non-preserved integer is < IV_MAX,
2184 this NV is in the preserved range, therefore: */
2185 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2187 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);
2191 0 0 already failed to read UV.
2192 0 1 already failed to read UV.
2193 1 0 you won't get here in this case. IV/UV
2194 slot set, public IOK, Atof() unneeded.
2195 1 1 already read UV.
2196 so there's no point in sv_2iuv_non_preserve() attempting
2197 to use atol, strtol, strtoul etc. */
2199 sv_2iuv_non_preserve (sv, numtype);
2201 sv_2iuv_non_preserve (sv);
2205 #endif /* NV_PRESERVES_UV */
2206 /* It might be more code efficient to go through the entire logic above
2207 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2208 gets complex and potentially buggy, so more programmer efficient
2209 to do it this way, by turning off the public flags: */
2211 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2215 if (isGV_with_GP(sv))
2216 return glob_2number(MUTABLE_GV(sv));
2218 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2219 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2222 if (SvTYPE(sv) < SVt_IV)
2223 /* Typically the caller expects that sv_any is not NULL now. */
2224 sv_upgrade(sv, SVt_IV);
2225 /* Return 0 from the caller. */
2232 =for apidoc sv_2iv_flags
2234 Return the integer value of an SV, doing any necessary string
2235 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2236 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2242 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2247 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2248 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2249 cache IVs just in case. In practice it seems that they never
2250 actually anywhere accessible by user Perl code, let alone get used
2251 in anything other than a string context. */
2252 if (flags & SV_GMAGIC)
2257 return I_V(SvNVX(sv));
2259 if (SvPOKp(sv) && SvLEN(sv)) {
2262 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2264 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2265 == IS_NUMBER_IN_UV) {
2266 /* It's definitely an integer */
2267 if (numtype & IS_NUMBER_NEG) {
2268 if (value < (UV)IV_MIN)
2271 if (value < (UV)IV_MAX)
2276 if (ckWARN(WARN_NUMERIC))
2279 return I_V(Atof(SvPVX_const(sv)));
2284 assert(SvTYPE(sv) >= SVt_PVMG);
2285 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2286 } else if (SvTHINKFIRST(sv)) {
2291 if (flags & SV_SKIP_OVERLOAD)
2293 tmpstr=AMG_CALLun(sv,numer);
2294 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2295 return SvIV(tmpstr);
2298 return PTR2IV(SvRV(sv));
2301 sv_force_normal_flags(sv, 0);
2303 if (SvREADONLY(sv) && !SvOK(sv)) {
2304 if (ckWARN(WARN_UNINITIALIZED))
2310 if (S_sv_2iuv_common(aTHX_ sv))
2313 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2314 PTR2UV(sv),SvIVX(sv)));
2315 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2319 =for apidoc sv_2uv_flags
2321 Return the unsigned integer value of an SV, doing any necessary string
2322 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2323 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2329 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2334 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2335 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2336 cache IVs just in case. */
2337 if (flags & SV_GMAGIC)
2342 return U_V(SvNVX(sv));
2343 if (SvPOKp(sv) && SvLEN(sv)) {
2346 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2348 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2349 == IS_NUMBER_IN_UV) {
2350 /* It's definitely an integer */
2351 if (!(numtype & IS_NUMBER_NEG))
2355 if (ckWARN(WARN_NUMERIC))
2358 return U_V(Atof(SvPVX_const(sv)));
2363 assert(SvTYPE(sv) >= SVt_PVMG);
2364 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2365 } else if (SvTHINKFIRST(sv)) {
2370 if (flags & SV_SKIP_OVERLOAD)
2372 tmpstr = AMG_CALLun(sv,numer);
2373 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2374 return SvUV(tmpstr);
2377 return PTR2UV(SvRV(sv));
2380 sv_force_normal_flags(sv, 0);
2382 if (SvREADONLY(sv) && !SvOK(sv)) {
2383 if (ckWARN(WARN_UNINITIALIZED))
2389 if (S_sv_2iuv_common(aTHX_ sv))
2393 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2394 PTR2UV(sv),SvUVX(sv)));
2395 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2399 =for apidoc sv_2nv_flags
2401 Return the num value of an SV, doing any necessary string or integer
2402 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2403 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2409 Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
2414 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2415 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2416 cache IVs just in case. */
2417 if (flags & SV_GMAGIC)
2421 if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2422 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2423 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2425 return Atof(SvPVX_const(sv));
2429 return (NV)SvUVX(sv);
2431 return (NV)SvIVX(sv);
2436 assert(SvTYPE(sv) >= SVt_PVMG);
2437 /* This falls through to the report_uninit near the end of the
2439 } else if (SvTHINKFIRST(sv)) {
2444 if (flags & SV_SKIP_OVERLOAD)
2446 tmpstr = AMG_CALLun(sv,numer);
2447 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2448 return SvNV(tmpstr);
2451 return PTR2NV(SvRV(sv));
2454 sv_force_normal_flags(sv, 0);
2456 if (SvREADONLY(sv) && !SvOK(sv)) {
2457 if (ckWARN(WARN_UNINITIALIZED))
2462 if (SvTYPE(sv) < SVt_NV) {
2463 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2464 sv_upgrade(sv, SVt_NV);
2465 #ifdef USE_LONG_DOUBLE
2467 STORE_NUMERIC_LOCAL_SET_STANDARD();
2468 PerlIO_printf(Perl_debug_log,
2469 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2470 PTR2UV(sv), SvNVX(sv));
2471 RESTORE_NUMERIC_LOCAL();
2475 STORE_NUMERIC_LOCAL_SET_STANDARD();
2476 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2477 PTR2UV(sv), SvNVX(sv));
2478 RESTORE_NUMERIC_LOCAL();
2482 else if (SvTYPE(sv) < SVt_PVNV)
2483 sv_upgrade(sv, SVt_PVNV);
2488 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2489 #ifdef NV_PRESERVES_UV
2495 /* Only set the public NV OK flag if this NV preserves the IV */
2496 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2498 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2499 : (SvIVX(sv) == I_V(SvNVX(sv))))
2505 else if (SvPOKp(sv) && SvLEN(sv)) {
2507 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2508 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2510 #ifdef NV_PRESERVES_UV
2511 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2512 == IS_NUMBER_IN_UV) {
2513 /* It's definitely an integer */
2514 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2516 SvNV_set(sv, Atof(SvPVX_const(sv)));
2522 SvNV_set(sv, Atof(SvPVX_const(sv)));
2523 /* Only set the public NV OK flag if this NV preserves the value in
2524 the PV at least as well as an IV/UV would.
2525 Not sure how to do this 100% reliably. */
2526 /* if that shift count is out of range then Configure's test is
2527 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2529 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2530 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2531 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2532 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2533 /* Can't use strtol etc to convert this string, so don't try.
2534 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2537 /* value has been set. It may not be precise. */
2538 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2539 /* 2s complement assumption for (UV)IV_MIN */
2540 SvNOK_on(sv); /* Integer is too negative. */
2545 if (numtype & IS_NUMBER_NEG) {
2546 SvIV_set(sv, -(IV)value);
2547 } else if (value <= (UV)IV_MAX) {
2548 SvIV_set(sv, (IV)value);
2550 SvUV_set(sv, value);
2554 if (numtype & IS_NUMBER_NOT_INT) {
2555 /* I believe that even if the original PV had decimals,
2556 they are lost beyond the limit of the FP precision.
2557 However, neither is canonical, so both only get p
2558 flags. NWC, 2000/11/25 */
2559 /* Both already have p flags, so do nothing */
2561 const NV nv = SvNVX(sv);
2562 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2563 if (SvIVX(sv) == I_V(nv)) {
2566 /* It had no "." so it must be integer. */
2570 /* between IV_MAX and NV(UV_MAX).
2571 Could be slightly > UV_MAX */
2573 if (numtype & IS_NUMBER_NOT_INT) {
2574 /* UV and NV both imprecise. */
2576 const UV nv_as_uv = U_V(nv);
2578 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2587 /* It might be more code efficient to go through the entire logic above
2588 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2589 gets complex and potentially buggy, so more programmer efficient
2590 to do it this way, by turning off the public flags: */
2592 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2593 #endif /* NV_PRESERVES_UV */
2596 if (isGV_with_GP(sv)) {
2597 glob_2number(MUTABLE_GV(sv));
2601 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2603 assert (SvTYPE(sv) >= SVt_NV);
2604 /* Typically the caller expects that sv_any is not NULL now. */
2605 /* XXX Ilya implies that this is a bug in callers that assume this
2606 and ideally should be fixed. */
2609 #if defined(USE_LONG_DOUBLE)
2611 STORE_NUMERIC_LOCAL_SET_STANDARD();
2612 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2613 PTR2UV(sv), SvNVX(sv));
2614 RESTORE_NUMERIC_LOCAL();
2618 STORE_NUMERIC_LOCAL_SET_STANDARD();
2619 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2620 PTR2UV(sv), SvNVX(sv));
2621 RESTORE_NUMERIC_LOCAL();
2630 Return an SV with the numeric value of the source SV, doing any necessary
2631 reference or overload conversion. You must use the C<SvNUM(sv)> macro to
2632 access this function.
2638 Perl_sv_2num(pTHX_ register SV *const sv)
2640 PERL_ARGS_ASSERT_SV_2NUM;
2645 SV * const tmpsv = AMG_CALLun(sv,numer);
2646 TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2647 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2648 return sv_2num(tmpsv);
2650 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2653 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2654 * UV as a string towards the end of buf, and return pointers to start and
2657 * We assume that buf is at least TYPE_CHARS(UV) long.
2661 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2663 char *ptr = buf + TYPE_CHARS(UV);
2664 char * const ebuf = ptr;
2667 PERL_ARGS_ASSERT_UIV_2BUF;
2679 *--ptr = '0' + (char)(uv % 10);
2688 =for apidoc sv_2pv_flags
2690 Returns a pointer to the string value of an SV, and sets *lp to its length.
2691 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2693 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2694 usually end up here too.
2700 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2710 if (SvGMAGICAL(sv)) {
2711 if (flags & SV_GMAGIC)
2716 if (flags & SV_MUTABLE_RETURN)
2717 return SvPVX_mutable(sv);
2718 if (flags & SV_CONST_RETURN)
2719 return (char *)SvPVX_const(sv);
2722 if (SvIOKp(sv) || SvNOKp(sv)) {
2723 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2728 ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2729 : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2730 } else if(SvNVX(sv) == 0.0) {
2735 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2742 SvUPGRADE(sv, SVt_PV);
2745 s = SvGROW_mutable(sv, len + 1);
2748 return (char*)memcpy(s, tbuf, len + 1);
2754 assert(SvTYPE(sv) >= SVt_PVMG);
2755 /* This falls through to the report_uninit near the end of the
2757 } else if (SvTHINKFIRST(sv)) {
2762 if (flags & SV_SKIP_OVERLOAD)
2764 tmpstr = AMG_CALLun(sv,string);
2765 TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2766 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2768 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2772 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2773 if (flags & SV_CONST_RETURN) {
2774 pv = (char *) SvPVX_const(tmpstr);
2776 pv = (flags & SV_MUTABLE_RETURN)
2777 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2780 *lp = SvCUR(tmpstr);
2782 pv = sv_2pv_flags(tmpstr, lp, flags);
2795 SV *const referent = SvRV(sv);
2799 retval = buffer = savepvn("NULLREF", len);
2800 } else if (SvTYPE(referent) == SVt_REGEXP) {
2801 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2806 /* If the regex is UTF-8 we want the containing scalar to
2807 have an UTF-8 flag too */
2813 if ((seen_evals = RX_SEEN_EVALS(re)))
2814 PL_reginterp_cnt += seen_evals;
2817 *lp = RX_WRAPLEN(re);
2819 return RX_WRAPPED(re);
2821 const char *const typestr = sv_reftype(referent, 0);
2822 const STRLEN typelen = strlen(typestr);
2823 UV addr = PTR2UV(referent);
2824 const char *stashname = NULL;
2825 STRLEN stashnamelen = 0; /* hush, gcc */
2826 const char *buffer_end;
2828 if (SvOBJECT(referent)) {
2829 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2832 stashname = HEK_KEY(name);
2833 stashnamelen = HEK_LEN(name);
2835 if (HEK_UTF8(name)) {
2841 stashname = "__ANON__";
2844 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2845 + 2 * sizeof(UV) + 2 /* )\0 */;
2847 len = typelen + 3 /* (0x */
2848 + 2 * sizeof(UV) + 2 /* )\0 */;
2851 Newx(buffer, len, char);
2852 buffer_end = retval = buffer + len;
2854 /* Working backwards */
2858 *--retval = PL_hexdigit[addr & 15];
2859 } while (addr >>= 4);
2865 memcpy(retval, typestr, typelen);
2869 retval -= stashnamelen;
2870 memcpy(retval, stashname, stashnamelen);
2872 /* retval may not neccesarily have reached the start of the
2874 assert (retval >= buffer);
2876 len = buffer_end - retval - 1; /* -1 for that \0 */
2884 if (SvREADONLY(sv) && !SvOK(sv)) {
2887 if (flags & SV_UNDEF_RETURNS_NULL)
2889 if (ckWARN(WARN_UNINITIALIZED))
2894 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2895 /* I'm assuming that if both IV and NV are equally valid then
2896 converting the IV is going to be more efficient */
2897 const U32 isUIOK = SvIsUV(sv);
2898 char buf[TYPE_CHARS(UV)];
2902 if (SvTYPE(sv) < SVt_PVIV)
2903 sv_upgrade(sv, SVt_PVIV);
2904 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2906 /* inlined from sv_setpvn */
2907 s = SvGROW_mutable(sv, len + 1);
2908 Move(ptr, s, len, char);
2912 else if (SvNOKp(sv)) {
2913 if (SvTYPE(sv) < SVt_PVNV)
2914 sv_upgrade(sv, SVt_PVNV);
2915 if (SvNVX(sv) == 0.0) {
2916 s = SvGROW_mutable(sv, 2);
2921 /* The +20 is pure guesswork. Configure test needed. --jhi */
2922 s = SvGROW_mutable(sv, NV_DIG + 20);
2923 /* some Xenix systems wipe out errno here */
2924 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2934 if (isGV_with_GP(sv)) {
2935 GV *const gv = MUTABLE_GV(sv);
2936 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
2937 SV *const buffer = sv_newmortal();
2939 /* FAKE globs can get coerced, so need to turn this off temporarily
2942 gv_efullname3(buffer, gv, "*");
2943 SvFLAGS(gv) |= wasfake;
2945 if (SvPOK(buffer)) {
2947 *lp = SvCUR(buffer);
2949 return SvPVX(buffer);
2960 if (flags & SV_UNDEF_RETURNS_NULL)
2962 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2964 if (SvTYPE(sv) < SVt_PV)
2965 /* Typically the caller expects that sv_any is not NULL now. */
2966 sv_upgrade(sv, SVt_PV);
2970 const STRLEN len = s - SvPVX_const(sv);
2976 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2977 PTR2UV(sv),SvPVX_const(sv)));
2978 if (flags & SV_CONST_RETURN)
2979 return (char *)SvPVX_const(sv);
2980 if (flags & SV_MUTABLE_RETURN)
2981 return SvPVX_mutable(sv);
2986 =for apidoc sv_copypv
2988 Copies a stringified representation of the source SV into the
2989 destination SV. Automatically performs any necessary mg_get and
2990 coercion of numeric values into strings. Guaranteed to preserve
2991 UTF8 flag even from overloaded objects. Similar in nature to
2992 sv_2pv[_flags] but operates directly on an SV instead of just the
2993 string. Mostly uses sv_2pv_flags to do its work, except when that
2994 would lose the UTF-8'ness of the PV.
3000 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3003 const char * const s = SvPV_const(ssv,len);
3005 PERL_ARGS_ASSERT_SV_COPYPV;
3007 sv_setpvn(dsv,s,len);
3015 =for apidoc sv_2pvbyte
3017 Return a pointer to the byte-encoded representation of the SV, and set *lp
3018 to its length. May cause the SV to be downgraded from UTF-8 as a
3021 Usually accessed via the C<SvPVbyte> macro.
3027 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3029 PERL_ARGS_ASSERT_SV_2PVBYTE;
3032 sv_utf8_downgrade(sv,0);
3033 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3037 =for apidoc sv_2pvutf8
3039 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3040 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3042 Usually accessed via the C<SvPVutf8> macro.
3048 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3050 PERL_ARGS_ASSERT_SV_2PVUTF8;
3052 sv_utf8_upgrade(sv);
3053 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3058 =for apidoc sv_2bool
3060 This macro is only used by sv_true() or its macro equivalent, and only if
3061 the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3062 It calls sv_2bool_flags with the SV_GMAGIC flag.
3064 =for apidoc sv_2bool_flags
3066 This function is only used by sv_true() and friends, and only if
3067 the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
3068 contain SV_GMAGIC, then it does an mg_get() first.
3075 Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags)
3079 PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3081 if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3087 SV * const tmpsv = AMG_CALLun(sv,bool_);
3088 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3089 return cBOOL(SvTRUE(tmpsv));
3091 return SvRV(sv) != 0;
3094 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3096 (*sv->sv_u.svu_pv > '0' ||
3097 Xpvtmp->xpv_cur > 1 ||
3098 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3105 return SvIVX(sv) != 0;
3108 return SvNVX(sv) != 0.0;
3110 if (isGV_with_GP(sv))
3120 =for apidoc sv_utf8_upgrade
3122 Converts the PV of an SV to its UTF-8-encoded form.
3123 Forces the SV to string form if it is not already.
3124 Will C<mg_get> on C<sv> if appropriate.
3125 Always sets the SvUTF8 flag to avoid future validity checks even
3126 if the whole string is the same in UTF-8 as not.
3127 Returns the number of bytes in the converted string
3129 This is not as a general purpose byte encoding to Unicode interface:
3130 use the Encode extension for that.
3132 =for apidoc sv_utf8_upgrade_nomg
3134 Like sv_utf8_upgrade, but doesn't do magic on C<sv>
3136 =for apidoc sv_utf8_upgrade_flags
3138 Converts the PV of an SV to its UTF-8-encoded form.
3139 Forces the SV to string form if it is not already.
3140 Always sets the SvUTF8 flag to avoid future validity checks even
3141 if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
3142 will C<mg_get> on C<sv> if appropriate, else not.
3143 Returns the number of bytes in the converted string
3144 C<sv_utf8_upgrade> and
3145 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3147 This is not as a general purpose byte encoding to Unicode interface:
3148 use the Encode extension for that.
3152 The grow version is currently not externally documented. It adds a parameter,
3153 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3154 have free after it upon return. This allows the caller to reserve extra space
3155 that it intends to fill, to avoid extra grows.
3157 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3158 which can be used to tell this function to not first check to see if there are
3159 any characters that are different in UTF-8 (variant characters) which would
3160 force it to allocate a new string to sv, but to assume there are. Typically
3161 this flag is used by a routine that has already parsed the string to find that
3162 there are such characters, and passes this information on so that the work
3163 doesn't have to be repeated.
3165 (One might think that the calling routine could pass in the position of the
3166 first such variant, so it wouldn't have to be found again. But that is not the
3167 case, because typically when the caller is likely to use this flag, it won't be
3168 calling this routine unless it finds something that won't fit into a byte.
3169 Otherwise it tries to not upgrade and just use bytes. But some things that
3170 do fit into a byte are variants in utf8, and the caller may not have been
3171 keeping track of these.)
3173 If the routine itself changes the string, it adds a trailing NUL. Such a NUL
3174 isn't guaranteed due to having other routines do the work in some input cases,
3175 or if the input is already flagged as being in utf8.
3177 The speed of this could perhaps be improved for many cases if someone wanted to
3178 write a fast function that counts the number of variant characters in a string,
3179 especially if it could return the position of the first one.
3184 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
3188 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3190 if (sv == &PL_sv_undef)
3194 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3195 (void) sv_2pv_flags(sv,&len, flags);
3197 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3201 (void) SvPV_force(sv,len);
3206 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3211 sv_force_normal_flags(sv, 0);
3214 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3215 sv_recode_to_utf8(sv, PL_encoding);
3216 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3220 if (SvCUR(sv) == 0) {
3221 if (extra) SvGROW(sv, extra);
3222 } else { /* Assume Latin-1/EBCDIC */
3223 /* This function could be much more efficient if we
3224 * had a FLAG in SVs to signal if there are any variant
3225 * chars in the PV. Given that there isn't such a flag
3226 * make the loop as fast as possible (although there are certainly ways
3227 * to speed this up, eg. through vectorization) */
3228 U8 * s = (U8 *) SvPVX_const(sv);
3229 U8 * e = (U8 *) SvEND(sv);
3231 STRLEN two_byte_count = 0;
3233 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3235 /* See if really will need to convert to utf8. We mustn't rely on our
3236 * incoming SV being well formed and having a trailing '\0', as certain
3237 * code in pp_formline can send us partially built SVs. */
3241 if (NATIVE_IS_INVARIANT(ch)) continue;
3243 t--; /* t already incremented; re-point to first variant */
3248 /* utf8 conversion not needed because all are invariants. Mark as
3249 * UTF-8 even if no variant - saves scanning loop */
3255 /* Here, the string should be converted to utf8, either because of an
3256 * input flag (two_byte_count = 0), or because a character that
3257 * requires 2 bytes was found (two_byte_count = 1). t points either to
3258 * the beginning of the string (if we didn't examine anything), or to
3259 * the first variant. In either case, everything from s to t - 1 will
3260 * occupy only 1 byte each on output.
3262 * There are two main ways to convert. One is to create a new string
3263 * and go through the input starting from the beginning, appending each
3264 * converted value onto the new string as we go along. It's probably
3265 * best to allocate enough space in the string for the worst possible
3266 * case rather than possibly running out of space and having to
3267 * reallocate and then copy what we've done so far. Since everything
3268 * from s to t - 1 is invariant, the destination can be initialized
3269 * with these using a fast memory copy
3271 * The other way is to figure out exactly how big the string should be
3272 * by parsing the entire input. Then you don't have to make it big
3273 * enough to handle the worst possible case, and more importantly, if
3274 * the string you already have is large enough, you don't have to
3275 * allocate a new string, you can copy the last character in the input
3276 * string to the final position(s) that will be occupied by the
3277 * converted string and go backwards, stopping at t, since everything
3278 * before that is invariant.
3280 * There are advantages and disadvantages to each method.
3282 * In the first method, we can allocate a new string, do the memory
3283 * copy from the s to t - 1, and then proceed through the rest of the
3284 * string byte-by-byte.
3286 * In the second method, we proceed through the rest of the input
3287 * string just calculating how big the converted string will be. Then
3288 * there are two cases:
3289 * 1) if the string has enough extra space to handle the converted
3290 * value. We go backwards through the string, converting until we
3291 * get to the position we are at now, and then stop. If this
3292 * position is far enough along in the string, this method is
3293 * faster than the other method. If the memory copy were the same
3294 * speed as the byte-by-byte loop, that position would be about
3295 * half-way, as at the half-way mark, parsing to the end and back
3296 * is one complete string's parse, the same amount as starting
3297 * over and going all the way through. Actually, it would be
3298 * somewhat less than half-way, as it's faster to just count bytes
3299 * than to also copy, and we don't have the overhead of allocating
3300 * a new string, changing the scalar to use it, and freeing the
3301 * existing one. But if the memory copy is fast, the break-even
3302 * point is somewhere after half way. The counting loop could be
3303 * sped up by vectorization, etc, to move the break-even point
3304 * further towards the beginning.
3305 * 2) if the string doesn't have enough space to handle the converted
3306 * value. A new string will have to be allocated, and one might
3307 * as well, given that, start from the beginning doing the first
3308 * method. We've spent extra time parsing the string and in
3309 * exchange all we've gotten is that we know precisely how big to
3310 * make the new one. Perl is more optimized for time than space,
3311 * so this case is a loser.
3312 * So what I've decided to do is not use the 2nd method unless it is
3313 * guaranteed that a new string won't have to be allocated, assuming
3314 * the worst case. I also decided not to put any more conditions on it
3315 * than this, for now. It seems likely that, since the worst case is
3316 * twice as big as the unknown portion of the string (plus 1), we won't
3317 * be guaranteed enough space, causing us to go to the first method,
3318 * unless the string is short, or the first variant character is near
3319 * the end of it. In either of these cases, it seems best to use the
3320 * 2nd method. The only circumstance I can think of where this would
3321 * be really slower is if the string had once had much more data in it
3322 * than it does now, but there is still a substantial amount in it */
3325 STRLEN invariant_head = t - s;
3326 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3327 if (SvLEN(sv) < size) {
3329 /* Here, have decided to allocate a new string */
3334 Newx(dst, size, U8);
3336 /* If no known invariants at the beginning of the input string,
3337 * set so starts from there. Otherwise, can use memory copy to
3338 * get up to where we are now, and then start from here */
3340 if (invariant_head <= 0) {
3343 Copy(s, dst, invariant_head, char);
3344 d = dst + invariant_head;
3348 const UV uv = NATIVE8_TO_UNI(*t++);
3349 if (UNI_IS_INVARIANT(uv))
3350 *d++ = (U8)UNI_TO_NATIVE(uv);
3352 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3353 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3357 SvPV_free(sv); /* No longer using pre-existing string */
3358 SvPV_set(sv, (char*)dst);
3359 SvCUR_set(sv, d - dst);
3360 SvLEN_set(sv, size);
3363 /* Here, have decided to get the exact size of the string.
3364 * Currently this happens only when we know that there is
3365 * guaranteed enough space to fit the converted string, so
3366 * don't have to worry about growing. If two_byte_count is 0,
3367 * then t points to the first byte of the string which hasn't
3368 * been examined yet. Otherwise two_byte_count is 1, and t
3369 * points to the first byte in the string that will expand to
3370 * two. Depending on this, start examining at t or 1 after t.
3373 U8 *d = t + two_byte_count;
3376 /* Count up the remaining bytes that expand to two */
3379 const U8 chr = *d++;
3380 if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3383 /* The string will expand by just the number of bytes that
3384 * occupy two positions. But we are one afterwards because of
3385 * the increment just above. This is the place to put the
3386 * trailing NUL, and to set the length before we decrement */
3388 d += two_byte_count;
3389 SvCUR_set(sv, d - s);
3393 /* Having decremented d, it points to the position to put the
3394 * very last byte of the expanded string. Go backwards through
3395 * the string, copying and expanding as we go, stopping when we
3396 * get to the part that is invariant the rest of the way down */
3400 const U8 ch = NATIVE8_TO_UNI(*e--);
3401 if (UNI_IS_INVARIANT(ch)) {
3402 *d-- = UNI_TO_NATIVE(ch);
3404 *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3405 *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3412 /* Mark as UTF-8 even if no variant - saves scanning loop */
3418 =for apidoc sv_utf8_downgrade
3420 Attempts to convert the PV of an SV from characters to bytes.
3421 If the PV contains a character that cannot fit
3422 in a byte, this conversion will fail;
3423 in this case, either returns false or, if C<fail_ok> is not
3426 This is not as a general purpose Unicode to byte encoding interface:
3427 use the Encode extension for that.
3433 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3437 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3439 if (SvPOKp(sv) && SvUTF8(sv)) {
3445 sv_force_normal_flags(sv, 0);
3447 s = (U8 *) SvPV(sv, len);
3448 if (!utf8_to_bytes(s, &len)) {
3453 Perl_croak(aTHX_ "Wide character in %s",
3456 Perl_croak(aTHX_ "Wide character");
3467 =for apidoc sv_utf8_encode
3469 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3470 flag off so that it looks like octets again.
3476 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3478 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3481 sv_force_normal_flags(sv, 0);
3483 if (SvREADONLY(sv)) {
3484 Perl_croak_no_modify(aTHX);
3486 (void) sv_utf8_upgrade(sv);
3491 =for apidoc sv_utf8_decode
3493 If the PV of the SV is an octet sequence in UTF-8
3494 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3495 so that it looks like a character. If the PV contains only single-byte
3496 characters, the C<SvUTF8> flag stays being off.
3497 Scans PV for validity and returns false if the PV is invalid UTF-8.
3503 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3505 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3511 /* The octets may have got themselves encoded - get them back as
3514 if (!sv_utf8_downgrade(sv, TRUE))
3517 /* it is actually just a matter of turning the utf8 flag on, but
3518 * we want to make sure everything inside is valid utf8 first.
3520 c = (const U8 *) SvPVX_const(sv);
3521 if (!is_utf8_string(c, SvCUR(sv)+1))
3523 e = (const U8 *) SvEND(sv);
3526 if (!UTF8_IS_INVARIANT(ch)) {
3536 =for apidoc sv_setsv
3538 Copies the contents of the source SV C<ssv> into the destination SV
3539 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3540 function if the source SV needs to be reused. Does not handle 'set' magic.
3541 Loosely speaking, it performs a copy-by-value, obliterating any previous
3542 content of the destination.
3544 You probably want to use one of the assortment of wrappers, such as
3545 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3546 C<SvSetMagicSV_nosteal>.
3548 =for apidoc sv_setsv_flags
3550 Copies the contents of the source SV C<ssv> into the destination SV
3551 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3552 function if the source SV needs to be reused. Does not handle 'set' magic.
3553 Loosely speaking, it performs a copy-by-value, obliterating any previous
3554 content of the destination.
3555 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3556 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3557 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3558 and C<sv_setsv_nomg> are implemented in terms of this function.
3560 You probably want to use one of the assortment of wrappers, such as
3561 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3562 C<SvSetMagicSV_nosteal>.
3564 This is the primary function for copying scalars, and most other
3565 copy-ish functions and macros use this underneath.
3571 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3573 I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3574 HV *old_stash = NULL;
3576 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3578 if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3579 const char * const name = GvNAME(sstr);
3580 const STRLEN len = GvNAMELEN(sstr);
3582 if (dtype >= SVt_PV) {
3588 SvUPGRADE(dstr, SVt_PVGV);
3589 (void)SvOK_off(dstr);
3590 /* FIXME - why are we doing this, then turning it off and on again
3592 isGV_with_GP_on(dstr);
3594 GvSTASH(dstr) = GvSTASH(sstr);
3596 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3597 gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
3598 SvFAKE_on(dstr); /* can coerce to non-glob */
3601 if(GvGP(MUTABLE_GV(sstr))) {
3602 /* If source has method cache entry, clear it */
3604 SvREFCNT_dec(GvCV(sstr));
3608 /* If source has a real method, then a method is
3611 GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3617 /* If dest already had a real method, that's a change as well */
3619 !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3620 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3625 /* We don’t need to check the name of the destination if it was not a
3626 glob to begin with. */
3627 if(dtype == SVt_PVGV) {
3628 const char * const name = GvNAME((const GV *)dstr);
3631 /* The stash may have been detached from the symbol table, so
3633 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3634 && GvAV((const GV *)sstr)
3638 const STRLEN len = GvNAMELEN(dstr);
3639 if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
3642 /* Set aside the old stash, so we can reset isa caches on
3644 if((old_stash = GvHV(dstr)))
3645 /* Make sure we do not lose it early. */
3646 SvREFCNT_inc_simple_void_NN(
3647 sv_2mortal((SV *)old_stash)
3653 gp_free(MUTABLE_GV(dstr));
3654 isGV_with_GP_off(dstr);
3655 (void)SvOK_off(dstr);
3656 isGV_with_GP_on(dstr);
3657 GvINTRO_off(dstr); /* one-shot flag */
3658 GvGP(dstr) = gp_ref(GvGP(sstr));
3659 if (SvTAINTED(sstr))
3661 if (GvIMPORTED(dstr) != GVf_IMPORTED
3662 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3664 GvIMPORTED_on(dstr);
3667 if(mro_changes == 2) {
3669 SV * const sref = (SV *)GvAV((const GV *)dstr);
3670 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3671 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3672 AV * const ary = newAV();
3673 av_push(ary, mg->mg_obj); /* takes the refcount */
3674 mg->mg_obj = (SV *)ary;
3676 av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3678 else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3679 mro_isa_changed_in(GvSTASH(dstr));
3681 else if(mro_changes == 3) {
3682 HV * const stash = GvHV(dstr);
3683 if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3689 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3694 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3696 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3698 const int intro = GvINTRO(dstr);
3701 const U32 stype = SvTYPE(sref);
3703 PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3706 GvINTRO_off(dstr); /* one-shot flag */
3707 GvLINE(dstr) = CopLINE(PL_curcop);
3708 GvEGV(dstr) = MUTABLE_GV(dstr);
3713 location = (SV **) &GvCV(dstr);
3714 import_flag = GVf_IMPORTED_CV;
3717 location = (SV **) &GvHV(dstr);
3718 import_flag = GVf_IMPORTED_HV;
3721 location = (SV **) &GvAV(dstr);
3722 import_flag = GVf_IMPORTED_AV;
3725 location = (SV **) &GvIOp(dstr);
3728 location = (SV **) &GvFORM(dstr);
3731 location = &GvSV(dstr);
3732 import_flag = GVf_IMPORTED_SV;
3735 if (stype == SVt_PVCV) {
3736 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3737 if (GvCVGEN(dstr)) {
3738 SvREFCNT_dec(GvCV(dstr));
3740 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3743 SAVEGENERICSV(*location);
3747 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3748 CV* const cv = MUTABLE_CV(*location);
3750 if (!GvCVGEN((const GV *)dstr) &&
3751 (CvROOT(cv) || CvXSUB(cv)))
3753 /* Redefining a sub - warning is mandatory if
3754 it was a const and its value changed. */
3755 if (CvCONST(cv) && CvCONST((const CV *)sref)
3757 == cv_const_sv((const CV *)sref)) {
3759 /* They are 2 constant subroutines generated from
3760 the same constant. This probably means that
3761 they are really the "same" proxy subroutine
3762 instantiated in 2 places. Most likely this is
3763 when a constant is exported twice. Don't warn.
3766 else if (ckWARN(WARN_REDEFINE)
3768 && (!CvCONST((const CV *)sref)
3769 || sv_cmp(cv_const_sv(cv),
3770 cv_const_sv((const CV *)
3772 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3775 ? "Constant subroutine %s::%s redefined"
3776 : "Subroutine %s::%s redefined"),
3777 HvNAME_get(GvSTASH((const GV *)dstr)),
3778 GvENAME(MUTABLE_GV(dstr)));
3782 cv_ckproto_len(cv, (const GV *)dstr,
3783 SvPOK(sref) ? SvPVX_const(sref) : NULL,
3784 SvPOK(sref) ? SvCUR(sref) : 0);
3786 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3787 GvASSUMECV_on(dstr);
3788 if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3791 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3792 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3793 GvFLAGS(dstr) |= import_flag;
3795 if (stype == SVt_PVHV) {
3796 const char * const name = GvNAME((GV*)dstr);
3797 const STRLEN len = GvNAMELEN(dstr);
3799 len > 1 && name[len-2] == ':' && name[len-1] == ':'
3800 && (!dref || HvENAME_get(dref))
3803 (HV *)sref, (HV *)dref,
3809 stype == SVt_PVAV && sref != dref
3810 && strEQ(GvNAME((GV*)dstr), "ISA")
3811 /* The stash may have been detached from the symbol table, so
3812 check its name before doing anything. */
3813 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3816 MAGIC * const omg = dref && SvSMAGICAL(dref)
3817 ? mg_find(dref, PERL_MAGIC_isa)
3819 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3820 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3821 AV * const ary = newAV();
3822 av_push(ary, mg->mg_obj); /* takes the refcount */
3823 mg->mg_obj = (SV *)ary;
3826 if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
3827 SV **svp = AvARRAY((AV *)omg->mg_obj);
3828 I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
3832 SvREFCNT_inc_simple_NN(*svp++)
3838 SvREFCNT_inc_simple_NN(omg->mg_obj)
3842 av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
3846 sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
3848 /* Since the *ISA assignment could have affected more than
3849 one stash, don’t call mro_isa_changed_in directly, but let
3850 magic_setisa do it for us, as it already has the logic for
3851 dealing with globs vs arrays of globs. */
3857 if (SvTAINTED(sstr))
3863 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3866 register U32 sflags;
3868 register svtype stype;
3870 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3875 if (SvIS_FREED(dstr)) {
3876 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3877 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3879 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3881 sstr = &PL_sv_undef;
3882 if (SvIS_FREED(sstr)) {
3883 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3884 (void*)sstr, (void*)dstr);
3886 stype = SvTYPE(sstr);
3887 dtype = SvTYPE(dstr);
3889 (void)SvAMAGIC_off(dstr);
3892 /* need to nuke the magic */
3896 /* There's a lot of redundancy below but we're going for speed here */
3901 if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
3902 (void)SvOK_off(dstr);
3910 sv_upgrade(dstr, SVt_IV);
3914 sv_upgrade(dstr, SVt_PVIV);
3918 goto end_of_first_switch;
3920 (void)SvIOK_only(dstr);
3921 SvIV_set(dstr, SvIVX(sstr));
3924 /* SvTAINTED can only be true if the SV has taint magic, which in
3925 turn means that the SV type is PVMG (or greater). This is the
3926 case statement for SVt_IV, so this cannot be true (whatever gcov
3928 assert(!SvTAINTED(sstr));
3933 if (dtype < SVt_PV && dtype != SVt_IV)
3934 sv_upgrade(dstr, SVt_IV);
3942 sv_upgrade(dstr, SVt_NV);
3946 sv_upgrade(dstr, SVt_PVNV);
3950 goto end_of_first_switch;
3952 SvNV_set(dstr, SvNVX(sstr));
3953 (void)SvNOK_only(dstr);
3954 /* SvTAINTED can only be true if the SV has taint magic, which in
3955 turn means that the SV type is PVMG (or greater). This is the
3956 case statement for SVt_NV, so this cannot be true (whatever gcov
3958 assert(!SvTAINTED(sstr));
3964 #ifdef PERL_OLD_COPY_ON_WRITE
3965 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3966 if (dtype < SVt_PVIV)
3967 sv_upgrade(dstr, SVt_PVIV);
3974 sv_upgrade(dstr, SVt_PV);
3977 if (dtype < SVt_PVIV)
3978 sv_upgrade(dstr, SVt_PVIV);
3981 if (dtype < SVt_PVNV)
3982 sv_upgrade(dstr, SVt_PVNV);
3986 const char * const type = sv_reftype(sstr,0);
3988 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
3990 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3995 if (dtype < SVt_REGEXP)
3996 sv_upgrade(dstr, SVt_REGEXP);
3999 /* case SVt_BIND: */
4002 /* SvVALID means that this PVGV is playing at being an FBM. */
4005 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4007 if (SvTYPE(sstr) != stype)
4008 stype = SvTYPE(sstr);
4010 if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4011 glob_assign_glob(dstr, sstr, dtype);
4014 if (stype == SVt_PVLV)
4015 SvUPGRADE(dstr, SVt_PVNV);
4017 SvUPGRADE(dstr, (svtype)stype);
4019 end_of_first_switch:
4021 /* dstr may have been upgraded. */
4022 dtype = SvTYPE(dstr);
4023 sflags = SvFLAGS(sstr);
4025 if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
4026 /* Assigning to a subroutine sets the prototype. */
4029 const char *const ptr = SvPV_const(sstr, len);
4031 SvGROW(dstr, len + 1);
4032 Copy(ptr, SvPVX(dstr), len + 1, char);
4033 SvCUR_set(dstr, len);
4035 SvFLAGS(dstr) |= sflags & SVf_UTF8;
4039 } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
4040 const char * const type = sv_reftype(dstr,0);
4042 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4044 Perl_croak(aTHX_ "Cannot copy to %s", type);
4045 } else if (sflags & SVf_ROK) {
4046 if (isGV_with_GP(dstr)
4047 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4050 if (GvIMPORTED(dstr) != GVf_IMPORTED
4051 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4053 GvIMPORTED_on(dstr);
4058 glob_assign_glob(dstr, sstr, dtype);
4062 if (dtype >= SVt_PV) {
4063 if (isGV_with_GP(dstr)) {
4064 glob_assign_ref(dstr, sstr);
4067 if (SvPVX_const(dstr)) {
4073 (void)SvOK_off(dstr);
4074 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4075 SvFLAGS(dstr) |= sflags & SVf_ROK;
4076 assert(!(sflags & SVp_NOK));
4077 assert(!(sflags & SVp_IOK));
4078 assert(!(sflags & SVf_NOK));
4079 assert(!(sflags & SVf_IOK));
4081 else if (isGV_with_GP(dstr)) {
4082 if (!(sflags & SVf_OK)) {
4083 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4084 "Undefined value assigned to typeglob");
4087 GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
4088 if (dstr != (const SV *)gv) {
4089 const char * const name = GvNAME((const GV *)dstr);
4090 const STRLEN len = GvNAMELEN(dstr);
4091 HV *old_stash = NULL;
4092 bool reset_isa = FALSE;
4093 if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
4094 /* Set aside the old stash, so we can reset isa caches
4095 on its subclasses. */
4096 if((old_stash = GvHV(dstr))) {
4097 /* Make sure we do not lose it early. */
4098 SvREFCNT_inc_simple_void_NN(
4099 sv_2mortal((SV *)old_stash)
4106 gp_free(MUTABLE_GV(dstr));
4107 GvGP(dstr) = gp_ref(GvGP(gv));
4110 HV * const stash = GvHV(dstr);
4112 old_stash ? (HV *)HvENAME_get(old_stash) : stash
4122 else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
4123 reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4125 else if (sflags & SVp_POK) {
4129 * Check to see if we can just swipe the string. If so, it's a
4130 * possible small lose on short strings, but a big win on long ones.
4131 * It might even be a win on short strings if SvPVX_const(dstr)
4132 * has to be allocated and SvPVX_const(sstr) has to be freed.
4133 * Likewise if we can set up COW rather than doing an actual copy, we
4134 * drop to the else clause, as the swipe code and the COW setup code
4135 * have much in common.
4138 /* Whichever path we take through the next code, we want this true,
4139 and doing it now facilitates the COW check. */
4140 (void)SvPOK_only(dstr);
4143 /* If we're already COW then this clause is not true, and if COW
4144 is allowed then we drop down to the else and make dest COW
4145 with us. If caller hasn't said that we're allowed to COW
4146 shared hash keys then we don't do the COW setup, even if the
4147 source scalar is a shared hash key scalar. */
4148 (((flags & SV_COW_SHARED_HASH_KEYS)
4149 ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4150 : 1 /* If making a COW copy is forbidden then the behaviour we
4151 desire is as if the source SV isn't actually already
4152 COW, even if it is. So we act as if the source flags
4153 are not COW, rather than actually testing them. */
4155 #ifndef PERL_OLD_COPY_ON_WRITE
4156 /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4157 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4158 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4159 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4160 but in turn, it's somewhat dead code, never expected to go
4161 live, but more kept as a placeholder on how to do it better
4162 in a newer implementation. */
4163 /* If we are COW and dstr is a suitable target then we drop down
4164 into the else and make dest a COW of us. */
4165 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4170 (sflags & SVs_TEMP) && /* slated for free anyway? */
4171 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4172 (!(flags & SV_NOSTEAL)) &&
4173 /* and we're allowed to steal temps */
4174 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4175 SvLEN(sstr)) /* and really is a string */
4176 #ifdef PERL_OLD_COPY_ON_WRITE
4177 && ((flags & SV_COW_SHARED_HASH_KEYS)
4178 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4179 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4180 && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4184 /* Failed the swipe test, and it's not a shared hash key either.
4185 Have to copy the string. */
4186 STRLEN len = SvCUR(sstr);
4187 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4188 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4189 SvCUR_set(dstr, len);
4190 *SvEND(dstr) = '\0';
4192 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4194 /* Either it's a shared hash key, or it's suitable for
4195 copy-on-write or we can swipe the string. */
4197 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4201 #ifdef PERL_OLD_COPY_ON_WRITE
4203 if ((sflags & (SVf_FAKE | SVf_READONLY))
4204 != (SVf_FAKE | SVf_READONLY)) {
4205 SvREADONLY_on(sstr);
4207 /* Make the source SV into a loop of 1.
4208 (about to become 2) */
4209 SV_COW_NEXT_SV_SET(sstr, sstr);
4213 /* Initial code is common. */
4214 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4219 /* making another shared SV. */
4220 STRLEN cur = SvCUR(sstr);
4221 STRLEN len = SvLEN(sstr);
4222 #ifdef PERL_OLD_COPY_ON_WRITE
4224 assert (SvTYPE(dstr) >= SVt_PVIV);
4225 /* SvIsCOW_normal */
4226 /* splice us in between source and next-after-source. */
4227 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4228 SV_COW_NEXT_SV_SET(sstr, dstr);
4229 SvPV_set(dstr, SvPVX_mutable(sstr));
4233 /* SvIsCOW_shared_hash */
4234 DEBUG_C(PerlIO_printf(Perl_debug_log,
4235 "Copy on write: Sharing hash\n"));
4237 assert (SvTYPE(dstr) >= SVt_PV);
4239 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4241 SvLEN_set(dstr, len);
4242 SvCUR_set(dstr, cur);
4243 SvREADONLY_on(dstr);
4247 { /* Passes the swipe test. */
4248 SvPV_set(dstr, SvPVX_mutable(sstr));
4249 SvLEN_set(dstr, SvLEN(sstr));
4250 SvCUR_set(dstr, SvCUR(sstr));
4253 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4254 SvPV_set(sstr, NULL);
4260 if (sflags & SVp_NOK) {
4261 SvNV_set(dstr, SvNVX(sstr));
4263 if (sflags & SVp_IOK) {
4264 SvIV_set(dstr, SvIVX(sstr));
4265 /* Must do this otherwise some other overloaded use of 0x80000000
4266 gets confused. I guess SVpbm_VALID */
4267 if (sflags & SVf_IVisUV)
4270 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4272 const MAGIC * const smg = SvVSTRING_mg(sstr);
4274 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4275 smg->mg_ptr, smg->mg_len);
4276 SvRMAGICAL_on(dstr);
4280 else if (sflags & (SVp_IOK|SVp_NOK)) {
4281 (void)SvOK_off(dstr);
4282 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4283 if (sflags & SVp_IOK) {
4284 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4285 SvIV_set(dstr, SvIVX(sstr));
4287 if (sflags & SVp_NOK) {
4288 SvNV_set(dstr, SvNVX(sstr));
4292 if (isGV_with_GP(sstr)) {
4293 /* This stringification rule for globs is spread in 3 places.
4294 This feels bad. FIXME. */
4295 const U32 wasfake = sflags & SVf_FAKE;
4297 /* FAKE globs can get coerced, so need to turn this off
4298 temporarily if it is on. */
4300 gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4301 SvFLAGS(sstr) |= wasfake;
4304 (void)SvOK_off(dstr);
4306 if (SvTAINTED(sstr))
4311 =for apidoc sv_setsv_mg
4313 Like C<sv_setsv>, but also handles 'set' magic.
4319 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4321 PERL_ARGS_ASSERT_SV_SETSV_MG;
4323 sv_setsv(dstr,sstr);
4327 #ifdef PERL_OLD_COPY_ON_WRITE
4329 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4331 STRLEN cur = SvCUR(sstr);
4332 STRLEN len = SvLEN(sstr);
4333 register char *new_pv;
4335 PERL_ARGS_ASSERT_SV_SETSV_COW;
4338 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4339 (void*)sstr, (void*)dstr);
4346 if (SvTHINKFIRST(dstr))
4347 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4348 else if (SvPVX_const(dstr))
4349 Safefree(SvPVX_const(dstr));
4353 SvUPGRADE(dstr, SVt_PVIV);
4355 assert (SvPOK(sstr));
4356 assert (SvPOKp(sstr));
4357 assert (!SvIOK(sstr));
4358 assert (!SvIOKp(sstr));
4359 assert (!SvNOK(sstr));
4360 assert (!SvNOKp(sstr));
4362 if (SvIsCOW(sstr)) {
4364 if (SvLEN(sstr) == 0) {
4365 /* source is a COW shared hash key. */
4366 DEBUG_C(PerlIO_printf(Perl_debug_log,
4367 "Fast copy on write: Sharing hash\n"));
4368 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4371 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4373 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4374 SvUPGRADE(sstr, SVt_PVIV);
4375 SvREADONLY_on(sstr);
4377 DEBUG_C(PerlIO_printf(Perl_debug_log,
4378 "Fast copy on write: Converting sstr to COW\n"));
4379 SV_COW_NEXT_SV_SET(dstr, sstr);
4381 SV_COW_NEXT_SV_SET(sstr, dstr);
4382 new_pv = SvPVX_mutable(sstr);
4385 SvPV_set(dstr, new_pv);
4386 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4389 SvLEN_set(dstr, len);
4390 SvCUR_set(dstr, cur);
4399 =for apidoc sv_setpvn
4401 Copies a string into an SV. The C<len> parameter indicates the number of
4402 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4403 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4409 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4412 register char *dptr;
4414 PERL_ARGS_ASSERT_SV_SETPVN;
4416 SV_CHECK_THINKFIRST_COW_DROP(sv);
4422 /* len is STRLEN which is unsigned, need to copy to signed */
4425 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4427 SvUPGRADE(sv, SVt_PV);
4429 dptr = SvGROW(sv, len + 1);
4430 Move(ptr,dptr,len,char);
4433 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4438 =for apidoc sv_setpvn_mg
4440 Like C<sv_setpvn>, but also handles 'set' magic.
4446 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4448 PERL_ARGS_ASSERT_SV_SETPVN_MG;
4450 sv_setpvn(sv,ptr,len);
4455 =for apidoc sv_setpv
4457 Copies a string into an SV. The string must be null-terminated. Does not
4458 handle 'set' magic. See C<sv_setpv_mg>.
4464 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4467 register STRLEN len;
4469 PERL_ARGS_ASSERT_SV_SETPV;
4471 SV_CHECK_THINKFIRST_COW_DROP(sv);
4477 SvUPGRADE(sv, SVt_PV);
4479 SvGROW(sv, len + 1);
4480 Move(ptr,SvPVX(sv),len+1,char);
4482 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4487 =for apidoc sv_setpv_mg
4489 Like C<sv_setpv>, but also handles 'set' magic.
4495 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4497 PERL_ARGS_ASSERT_SV_SETPV_MG;
4504 =for apidoc sv_usepvn_flags
4506 Tells an SV to use C<ptr> to find its string value. Normally the
4507 string is stored inside the SV but sv_usepvn allows the SV to use an
4508 outside string. The C<ptr> should point to memory that was allocated
4509 by C<malloc>. The string length, C<len>, must be supplied. By default
4510 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4511 so that pointer should not be freed or used by the programmer after
4512 giving it to sv_usepvn, and neither should any pointers from "behind"
4513 that pointer (e.g. ptr + 1) be used.
4515 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4516 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4517 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4518 C<len>, and already meets the requirements for storing in C<SvPVX>)
4524 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4529 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4531 SV_CHECK_THINKFIRST_COW_DROP(sv);
4532 SvUPGRADE(sv, SVt_PV);
4535 if (flags & SV_SMAGIC)
4539 if (SvPVX_const(sv))
4543 if (flags & SV_HAS_TRAILING_NUL)
4544 assert(ptr[len] == '\0');
4547 allocate = (flags & SV_HAS_TRAILING_NUL)
4549 #ifdef Perl_safesysmalloc_size
4552 PERL_STRLEN_ROUNDUP(len + 1);
4554 if (flags & SV_HAS_TRAILING_NUL) {
4555 /* It's long enough - do nothing.
4556 Specfically Perl_newCONSTSUB is relying on this. */
4559 /* Force a move to shake out bugs in callers. */
4560 char *new_ptr = (char*)safemalloc(allocate);
4561 Copy(ptr, new_ptr, len, char);
4562 PoisonFree(ptr,len,char);
4566 ptr = (char*) saferealloc (ptr, allocate);
4569 #ifdef Perl_safesysmalloc_size
4570 SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4572 SvLEN_set(sv, allocate);
4576 if (!(flags & SV_HAS_TRAILING_NUL)) {
4579 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4581 if (flags & SV_SMAGIC)
4585 #ifdef PERL_OLD_COPY_ON_WRITE
4586 /* Need to do this *after* making the SV normal, as we need the buffer
4587 pointer to remain valid until after we've copied it. If we let go too early,
4588 another thread could invalidate it by unsharing last of the same hash key
4589 (which it can do by means other than releasing copy-on-write Svs)
4590 or by changing the other copy-on-write SVs in the loop. */
4592 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4594 PERL_ARGS_ASSERT_SV_RELEASE_COW;
4596 { /* this SV was SvIsCOW_normal(sv) */
4597 /* we need to find the SV pointing to us. */
4598 SV *current = SV_COW_NEXT_SV(after);
4600 if (current == sv) {
4601 /* The SV we point to points back to us (there were only two of us
4603 Hence other SV is no longer copy on write either. */
4605 SvREADONLY_off(after);
4607 /* We need to follow the pointers around the loop. */
4609 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4612 /* don't loop forever if the structure is bust, and we have
4613 a pointer into a closed loop. */
4614 assert (current != after);
4615 assert (SvPVX_const(current) == pvx);
4617 /* Make the SV before us point to the SV after us. */
4618 SV_COW_NEXT_SV_SET(current, after);
4624 =for apidoc sv_force_normal_flags
4626 Undo various types of fakery on an SV: if the PV is a shared string, make
4627 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4628 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4629 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4630 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4631 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4632 set to some other value.) In addition, the C<flags> parameter gets passed to
4633 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4634 with flags set to 0.
4640 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4644 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4646 #ifdef PERL_OLD_COPY_ON_WRITE
4647 if (SvREADONLY(sv)) {
4649 const char * const pvx = SvPVX_const(sv);
4650 const STRLEN len = SvLEN(sv);
4651 const STRLEN cur = SvCUR(sv);
4652 /* next COW sv in the loop. If len is 0 then this is a shared-hash
4653 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4654 we'll fail an assertion. */
4655 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4658 PerlIO_printf(Perl_debug_log,
4659 "Copy on write: Force normal %ld\n",
4665 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4668 if (flags & SV_COW_DROP_PV) {
4669 /* OK, so we don't need to copy our buffer. */
4672 SvGROW(sv, cur + 1);
4673 Move(pvx,SvPVX(sv),cur,char);
4678 sv_release_COW(sv, pvx, next);
4680 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4686 else if (IN_PERL_RUNTIME)
4687 Perl_croak_no_modify(aTHX);
4690 if (SvREADONLY(sv)) {
4692 const char * const pvx = SvPVX_const(sv);
4693 const STRLEN len = SvCUR(sv);
4698 SvGROW(sv, len + 1);
4699 Move(pvx,SvPVX(sv),len,char);
4701 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4703 else if (IN_PERL_RUNTIME)
4704 Perl_croak_no_modify(aTHX);
4708 sv_unref_flags(sv, flags);
4709 else if (SvFAKE(sv) && isGV_with_GP(sv))
4711 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
4712 /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous
4713 to sv_unglob. We only need it here, so inline it. */
4714 const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
4715 SV *const temp = newSV_type(new_type);
4716 void *const temp_p = SvANY(sv);
4718 if (new_type == SVt_PVMG) {
4719 SvMAGIC_set(temp, SvMAGIC(sv));
4720 SvMAGIC_set(sv, NULL);
4721 SvSTASH_set(temp, SvSTASH(sv));
4722 SvSTASH_set(sv, NULL);
4724 SvCUR_set(temp, SvCUR(sv));
4725 /* Remember that SvPVX is in the head, not the body. */
4727 SvLEN_set(temp, SvLEN(sv));
4728 /* This signals "buffer is owned by someone else" in sv_clear,
4729 which is the least effort way to stop it freeing the buffer.
4731 SvLEN_set(sv, SvLEN(sv)+1);
4733 /* Their buffer is already owned by someone else. */
4734 SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
4735 SvLEN_set(temp, SvCUR(sv)+1);
4738 /* Now swap the rest of the bodies. */
4740 SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
4741 SvFLAGS(sv) |= new_type;
4742 SvANY(sv) = SvANY(temp);
4744 SvFLAGS(temp) &= ~(SVTYPEMASK);
4745 SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
4746 SvANY(temp) = temp_p;
4755 Efficient removal of characters from the beginning of the string buffer.
4756 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4757 the string buffer. The C<ptr> becomes the first character of the adjusted
4758 string. Uses the "OOK hack".
4759 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4760 refer to the same chunk of data.
4766 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4772 const U8 *real_start;
4776 PERL_ARGS_ASSERT_SV_CHOP;
4778 if (!ptr || !SvPOKp(sv))
4780 delta = ptr - SvPVX_const(sv);
4782 /* Nothing to do. */
4785 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4786 nothing uses the value of ptr any more. */
4787 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4788 if (ptr <= SvPVX_const(sv))
4789 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4790 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4791 SV_CHECK_THINKFIRST(sv);
4792 if (delta > max_delta)
4793 Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4794 SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4795 SvPVX_const(sv) + max_delta);
4798 if (!SvLEN(sv)) { /* make copy of shared string */
4799 const char *pvx = SvPVX_const(sv);
4800 const STRLEN len = SvCUR(sv);
4801 SvGROW(sv, len + 1);
4802 Move(pvx,SvPVX(sv),len,char);
4805 SvFLAGS(sv) |= SVf_OOK;
4808 SvOOK_offset(sv, old_delta);
4810 SvLEN_set(sv, SvLEN(sv) - delta);
4811 SvCUR_set(sv, SvCUR(sv) - delta);
4812 SvPV_set(sv, SvPVX(sv) + delta);
4814 p = (U8 *)SvPVX_const(sv);
4819 real_start = p - delta;
4823 if (delta < 0x100) {
4827 p -= sizeof(STRLEN);
4828 Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4832 /* Fill the preceding buffer with sentinals to verify that no-one is
4834 while (p > real_start) {
4842 =for apidoc sv_catpvn
4844 Concatenates the string onto the end of the string which is in the SV. The
4845 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4846 status set, then the bytes appended should be valid UTF-8.
4847 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4849 =for apidoc sv_catpvn_flags
4851 Concatenates the string onto the end of the string which is in the SV. The
4852 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4853 status set, then the bytes appended should be valid UTF-8.
4854 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4855 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4856 in terms of this function.
4862 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4866 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4868 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4870 SvGROW(dsv, dlen + slen + 1);
4872 sstr = SvPVX_const(dsv);
4873 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4874 SvCUR_set(dsv, SvCUR(dsv) + slen);
4876 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4878 if (flags & SV_SMAGIC)
4883 =for apidoc sv_catsv
4885 Concatenates the string from SV C<ssv> onto the end of the string in
4886 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4887 not 'set' magic. See C<sv_catsv_mg>.
4889 =for apidoc sv_catsv_flags
4891 Concatenates the string from SV C<ssv> onto the end of the string in
4892 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4893 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4894 and C<sv_catsv_nomg> are implemented in terms of this function.
4899 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4903 PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4907 const char *spv = SvPV_flags_const(ssv, slen, flags);
4909 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4910 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4911 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4912 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4913 dsv->sv_flags doesn't have that bit set.
4914 Andy Dougherty 12 Oct 2001
4916 const I32 sutf8 = DO_UTF8(ssv);
4919 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4921 dutf8 = DO_UTF8(dsv);
4923 if (dutf8 != sutf8) {
4925 /* Not modifying source SV, so taking a temporary copy. */
4926 SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4928 sv_utf8_upgrade(csv);
4929 spv = SvPV_const(csv, slen);
4932 /* Leave enough space for the cat that's about to happen */
4933 sv_utf8_upgrade_flags_grow(dsv, 0, slen);
4935 sv_catpvn_nomg(dsv, spv, slen);
4938 if (flags & SV_SMAGIC)
4943 =for apidoc sv_catpv
4945 Concatenates the string onto the end of the string which is in the SV.
4946 If the SV has the UTF-8 status set, then the bytes appended should be
4947 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4952 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4955 register STRLEN len;
4959 PERL_ARGS_ASSERT_SV_CATPV;
4963 junk = SvPV_force(sv, tlen);
4965 SvGROW(sv, tlen + len + 1);
4967 ptr = SvPVX_const(sv);
4968 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4969 SvCUR_set(sv, SvCUR(sv) + len);
4970 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4975 =for apidoc sv_catpv_flags
4977 Concatenates the string onto the end of the string which is in the SV.
4978 If the SV has the UTF-8 status set, then the bytes appended should
4979 be valid UTF-8. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get>
4980 on the SVs if appropriate, else not.
4986 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
4988 PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
4989 sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
4993 =for apidoc sv_catpv_mg
4995 Like C<sv_catpv>, but also handles 'set' magic.
5001 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
5003 PERL_ARGS_ASSERT_SV_CATPV_MG;
5012 Creates a new SV. A non-zero C<len> parameter indicates the number of
5013 bytes of preallocated string space the SV should have. An extra byte for a
5014 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
5015 space is allocated.) The reference count for the new SV is set to 1.
5017 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
5018 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5019 This aid has been superseded by a new build option, PERL_MEM_LOG (see
5020 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
5021 modules supporting older perls.
5027 Perl_newSV(pTHX_ const STRLEN len)
5034 sv_upgrade(sv, SVt_PV);
5035 SvGROW(sv, len + 1);
5040 =for apidoc sv_magicext
5042 Adds magic to an SV, upgrading it if necessary. Applies the
5043 supplied vtable and returns a pointer to the magic added.
5045 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5046 In particular, you can add magic to SvREADONLY SVs, and add more than
5047 one instance of the same 'how'.
5049 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5050 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5051 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5052 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5054 (This is now used as a subroutine by C<sv_magic>.)
5059 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
5060 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5065 PERL_ARGS_ASSERT_SV_MAGICEXT;
5067 SvUPGRADE(sv, SVt_PVMG);
5068 Newxz(mg, 1, MAGIC);
5069 mg->mg_moremagic = SvMAGIC(sv);
5070 SvMAGIC_set(sv, mg);
5072 /* Sometimes a magic contains a reference loop, where the sv and
5073 object refer to each other. To prevent a reference loop that
5074 would prevent such objects being freed, we look for such loops
5075 and if we find one we avoid incrementing the object refcount.
5077 Note we cannot do this to avoid self-tie loops as intervening RV must
5078 have its REFCNT incremented to keep it in existence.
5081 if (!obj || obj == sv ||
5082 how == PERL_MAGIC_arylen ||
5083 how == PERL_MAGIC_symtab ||
5084 (SvTYPE(obj) == SVt_PVGV &&
5085 (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5086 || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5087 || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5092 mg->mg_obj = SvREFCNT_inc_simple(obj);
5093 mg->mg_flags |= MGf_REFCOUNTED;
5096 /* Normal self-ties simply pass a null object, and instead of
5097 using mg_obj directly, use the SvTIED_obj macro to produce a
5098 new RV as needed. For glob "self-ties", we are tieing the PVIO
5099 with an RV obj pointing to the glob containing the PVIO. In
5100 this case, to avoid a reference loop, we need to weaken the
5104 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5105 obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5111 mg->mg_len = namlen;
5114 mg->mg_ptr = savepvn(name, namlen);
5115 else if (namlen == HEf_SVKEY) {
5116 /* Yes, this is casting away const. This is only for the case of
5117 HEf_SVKEY. I think we need to document this abberation of the
5118 constness of the API, rather than making name non-const, as
5119 that change propagating outwards a long way. */
5120 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5122 mg->mg_ptr = (char *) name;
5124 mg->mg_virtual = (MGVTBL *) vtable;
5128 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5133 =for apidoc sv_magic
5135 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5136 then adds a new magic item of type C<how> to the head of the magic list.
5138 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5139 handling of the C<name> and C<namlen> arguments.
5141 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5142 to add more than one instance of the same 'how'.
5148 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
5149 const char *const name, const I32 namlen)
5152 const MGVTBL *vtable;
5155 PERL_ARGS_ASSERT_SV_MAGIC;
5157 #ifdef PERL_OLD_COPY_ON_WRITE
5159 sv_force_normal_flags(sv, 0);
5161 if (SvREADONLY(sv)) {
5163 /* its okay to attach magic to shared strings; the subsequent
5164 * upgrade to PVMG will unshare the string */
5165 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
5168 && how != PERL_MAGIC_regex_global
5169 && how != PERL_MAGIC_bm
5170 && how != PERL_MAGIC_fm
5171 && how != PERL_MAGIC_sv
5172 && how != PERL_MAGIC_backref
5175 Perl_croak_no_modify(aTHX);
5178 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5179 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5180 /* sv_magic() refuses to add a magic of the same 'how' as an
5183 if (how == PERL_MAGIC_taint) {
5185 /* Any scalar which already had taint magic on which someone
5186 (erroneously?) did SvIOK_on() or similar will now be
5187 incorrectly sporting public "OK" flags. */
5188 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5196 vtable = &PL_vtbl_sv;
5198 case PERL_MAGIC_overload:
5199 vtable = &PL_vtbl_amagic;
5201 case PERL_MAGIC_overload_elem:
5202 vtable = &PL_vtbl_amagicelem;
5204 case PERL_MAGIC_overload_table:
5205 vtable = &PL_vtbl_ovrld;
5208 vtable = &PL_vtbl_bm;
5210 case PERL_MAGIC_regdata:
5211 vtable = &PL_vtbl_regdata;
5213 case PERL_MAGIC_regdatum:
5214 vtable = &PL_vtbl_regdatum;
5216 case PERL_MAGIC_env:
5217 vtable = &PL_vtbl_env;
5220 vtable = &PL_vtbl_fm;
5222 case PERL_MAGIC_envelem:
5223 vtable = &PL_vtbl_envelem;
5225 case PERL_MAGIC_regex_global:
5226 vtable = &PL_vtbl_mglob;
5228 case PERL_MAGIC_isa:
5229 vtable = &PL_vtbl_isa;
5231 case PERL_MAGIC_isaelem:
5232 vtable = &PL_vtbl_isaelem;
5234 case PERL_MAGIC_nkeys:
5235 vtable = &PL_vtbl_nkeys;
5237 case PERL_MAGIC_dbfile:
5240 case PERL_MAGIC_dbline:
5241 vtable = &PL_vtbl_dbline;
5243 #ifdef USE_LOCALE_COLLATE
5244 case PERL_MAGIC_collxfrm:
5245 vtable = &PL_vtbl_collxfrm;
5247 #endif /* USE_LOCALE_COLLATE */
5248 case PERL_MAGIC_tied:
5249 vtable = &PL_vtbl_pack;
5251 case PERL_MAGIC_tiedelem:
5252 case PERL_MAGIC_tiedscalar:
5253 vtable = &PL_vtbl_packelem;
5256 vtable = &PL_vtbl_regexp;
5258 case PERL_MAGIC_sig:
5259 vtable = &PL_vtbl_sig;
5261 case PERL_MAGIC_sigelem:
5262 vtable = &PL_vtbl_sigelem;
5264 case PERL_MAGIC_taint:
5265 vtable = &PL_vtbl_taint;
5267 case PERL_MAGIC_uvar:
5268 vtable = &PL_vtbl_uvar;
5270 case PERL_MAGIC_vec:
5271 vtable = &PL_vtbl_vec;
5273 case PERL_MAGIC_arylen_p:
5274 case PERL_MAGIC_rhash:
5275 case PERL_MAGIC_symtab:
5276 case PERL_MAGIC_vstring:
5277 case PERL_MAGIC_checkcall:
5280 case PERL_MAGIC_utf8:
5281 vtable = &PL_vtbl_utf8;
5283 case PERL_MAGIC_substr:
5284 vtable = &PL_vtbl_substr;
5286 case PERL_MAGIC_defelem:
5287 vtable = &PL_vtbl_defelem;
5289 case PERL_MAGIC_arylen:
5290 vtable = &PL_vtbl_arylen;
5292 case PERL_MAGIC_pos:
5293 vtable = &PL_vtbl_pos;
5295 case PERL_MAGIC_backref:
5296 vtable = &PL_vtbl_backref;
5298 case PERL_MAGIC_hintselem:
5299 vtable = &PL_vtbl_hintselem;
5301 case PERL_MAGIC_hints:
5302 vtable = &PL_vtbl_hints;
5304 case PERL_MAGIC_ext:
5305 /* Reserved for use by extensions not perl internals. */
5306 /* Useful for attaching extension internal data to perl vars. */
5307 /* Note that multiple extensions may clash if magical scalars */
5308 /* etc holding private data from one are passed to another. */
5312 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5315 /* Rest of work is done else where */
5316 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5319 case PERL_MAGIC_taint:
5322 case PERL_MAGIC_ext:
5323 case PERL_MAGIC_dbfile:
5330 =for apidoc sv_unmagic
5332 Removes all magic of type C<type> from an SV.
5338 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5343 PERL_ARGS_ASSERT_SV_UNMAGIC;
5345 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5347 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5348 for (mg = *mgp; mg; mg = *mgp) {
5349 if (mg->mg_type == type) {
5350 const MGVTBL* const vtbl = mg->mg_virtual;
5351 *mgp = mg->mg_moremagic;
5352 if (vtbl && vtbl->svt_free)
5353 vtbl->svt_free(aTHX_ sv, mg);
5354 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5356 Safefree(mg->mg_ptr);
5357 else if (mg->mg_len == HEf_SVKEY)
5358 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5359 else if (mg->mg_type == PERL_MAGIC_utf8)
5360 Safefree(mg->mg_ptr);
5362 if (mg->mg_flags & MGf_REFCOUNTED)
5363 SvREFCNT_dec(mg->mg_obj);
5367 mgp = &mg->mg_moremagic;
5370 if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
5371 mg_magical(sv); /* else fix the flags now */
5375 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5381 =for apidoc sv_rvweaken
5383 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5384 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5385 push a back-reference to this RV onto the array of backreferences
5386 associated with that magic. If the RV is magical, set magic will be
5387 called after the RV is cleared.
5393 Perl_sv_rvweaken(pTHX_ SV *const sv)
5397 PERL_ARGS_ASSERT_SV_RVWEAKEN;
5399 if (!SvOK(sv)) /* let undefs pass */
5402 Perl_croak(aTHX_ "Can't weaken a nonreference");
5403 else if (SvWEAKREF(sv)) {
5404 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5408 Perl_sv_add_backref(aTHX_ tsv, sv);
5414 /* Give tsv backref magic if it hasn't already got it, then push a
5415 * back-reference to sv onto the array associated with the backref magic.
5417 * As an optimisation, if there's only one backref and it's not an AV,
5418 * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5419 * allocate an AV. (Whether the slot holds an AV tells us whether this is
5422 * If an HV's backref is stored in magic, it is moved back to HvAUX.
5425 /* A discussion about the backreferences array and its refcount:
5427 * The AV holding the backreferences is pointed to either as the mg_obj of
5428 * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
5429 * structure, from the xhv_backreferences field. (A HV without hv_aux will
5430 * have the standard magic instead.) The array is created with a refcount
5431 * of 2. This means that if during global destruction the array gets
5432 * picked on before its parent to have its refcount decremented by the
5433 * random zapper, it won't actually be freed, meaning it's still there for
5434 * when its parent gets freed.
5436 * When the parent SV is freed, the extra ref is killed by
5437 * Perl_sv_kill_backrefs. The other ref is killed, in the case of magic,
5438 * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5440 * When a single backref SV is stored directly, it is not reference
5445 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5452 PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5454 /* find slot to store array or singleton backref */
5456 if (SvTYPE(tsv) == SVt_PVHV) {
5457 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5460 if ((mg = mg_find(tsv, PERL_MAGIC_backref))) {
5461 /* Aha. They've got it stowed in magic instead.
5462 * Move it back to xhv_backreferences */
5464 /* Stop mg_free decreasing the reference count. */
5466 /* Stop mg_free even calling the destructor, given that
5467 there's no AV to free up. */
5469 sv_unmagic(tsv, PERL_MAGIC_backref);
5475 (SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
5477 sv_magic(tsv, NULL, PERL_MAGIC_backref, NULL, 0);
5478 mg = mg_find(tsv, PERL_MAGIC_backref);
5480 svp = &(mg->mg_obj);
5483 /* create or retrieve the array */
5485 if ( (!*svp && SvTYPE(sv) == SVt_PVAV)
5486 || (*svp && SvTYPE(*svp) != SVt_PVAV)
5491 SvREFCNT_inc_simple_void(av);
5492 /* av now has a refcnt of 2; see discussion above */
5494 /* move single existing backref to the array */
5496 AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5500 mg->mg_flags |= MGf_REFCOUNTED;
5503 av = MUTABLE_AV(*svp);
5506 /* optimisation: store single backref directly in HvAUX or mg_obj */
5510 /* push new backref */
5511 assert(SvTYPE(av) == SVt_PVAV);
5512 if (AvFILLp(av) >= AvMAX(av)) {
5513 av_extend(av, AvFILLp(av)+1);
5515 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5518 /* delete a back-reference to ourselves from the backref magic associated
5519 * with the SV we point to.
5523 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5528 PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5530 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5531 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5533 if (!svp || !*svp) {
5535 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5536 svp = mg ? &(mg->mg_obj) : NULL;
5540 Perl_croak(aTHX_ "panic: del_backref");
5542 if (SvTYPE(*svp) == SVt_PVAV) {
5546 AV * const av = (AV*)*svp;
5548 assert(!SvIS_FREED(av));
5552 /* for an SV with N weak references to it, if all those
5553 * weak refs are deleted, then sv_del_backref will be called
5554 * N times and O(N^2) compares will be done within the backref
5555 * array. To ameliorate this potential slowness, we:
5556 * 1) make sure this code is as tight as possible;
5557 * 2) when looking for SV, look for it at both the head and tail of the
5558 * array first before searching the rest, since some create/destroy
5559 * patterns will cause the backrefs to be freed in order.
5566 SV **p = &svp[fill];
5567 SV *const topsv = *p;
5574 /* We weren't the last entry.
5575 An unordered list has this property that you
5576 can take the last element off the end to fill
5577 the hole, and it's still an unordered list :-)
5583 break; /* should only be one */
5590 AvFILLp(av) = fill-1;
5593 /* optimisation: only a single backref, stored directly */
5595 Perl_croak(aTHX_ "panic: del_backref");
5602 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5608 PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5613 is_array = (SvTYPE(av) == SVt_PVAV);
5615 assert(!SvIS_FREED(av));
5618 last = svp + AvFILLp(av);
5621 /* optimisation: only a single backref, stored directly */
5627 while (svp <= last) {
5629 SV *const referrer = *svp;
5630 if (SvWEAKREF(referrer)) {
5631 /* XXX Should we check that it hasn't changed? */
5632 assert(SvROK(referrer));
5633 SvRV_set(referrer, 0);
5635 SvWEAKREF_off(referrer);
5636 SvSETMAGIC(referrer);
5637 } else if (SvTYPE(referrer) == SVt_PVGV ||
5638 SvTYPE(referrer) == SVt_PVLV) {
5639 assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
5640 /* You lookin' at me? */
5641 assert(GvSTASH(referrer));
5642 assert(GvSTASH(referrer) == (const HV *)sv);
5643 GvSTASH(referrer) = 0;
5644 } else if (SvTYPE(referrer) == SVt_PVCV ||
5645 SvTYPE(referrer) == SVt_PVFM) {
5646 if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
5647 /* You lookin' at me? */
5648 assert(CvSTASH(referrer));
5649 assert(CvSTASH(referrer) == (const HV *)sv);
5650 SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
5653 assert(SvTYPE(sv) == SVt_PVGV);
5654 /* You lookin' at me? */
5655 assert(CvGV(referrer));
5656 assert(CvGV(referrer) == (const GV *)sv);
5657 anonymise_cv_maybe(MUTABLE_GV(sv),
5658 MUTABLE_CV(referrer));
5663 "panic: magic_killbackrefs (flags=%"UVxf")",
5664 (UV)SvFLAGS(referrer));
5675 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5681 =for apidoc sv_insert
5683 Inserts a string at the specified offset/length within the SV. Similar to
5684 the Perl substr() function. Handles get magic.
5686 =for apidoc sv_insert_flags
5688 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5694 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5699 register char *midend;
5700 register char *bigend;
5704 PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5707 Perl_croak(aTHX_ "Can't modify non-existent substring");
5708 SvPV_force_flags(bigstr, curlen, flags);
5709 (void)SvPOK_only_UTF8(bigstr);
5710 if (offset + len > curlen) {
5711 SvGROW(bigstr, offset+len+1);
5712 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5713 SvCUR_set(bigstr, offset+len);
5717 i = littlelen - len;
5718 if (i > 0) { /* string might grow */
5719 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5720 mid = big + offset + len;
5721 midend = bigend = big + SvCUR(bigstr);
5724 while (midend > mid) /* shove everything down */
5725 *--bigend = *--midend;
5726 Move(little,big+offset,littlelen,char);
5727 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5732 Move(little,SvPVX(bigstr)+offset,len,char);
5737 big = SvPVX(bigstr);
5740 bigend = big + SvCUR(bigstr);
5742 if (midend > bigend)
5743 Perl_croak(aTHX_ "panic: sv_insert");
5745 if (mid - big > bigend - midend) { /* faster to shorten from end */
5747 Move(little, mid, littlelen,char);
5750 i = bigend - midend;
5752 Move(midend, mid, i,char);
5756 SvCUR_set(bigstr, mid - big);
5758 else if ((i = mid - big)) { /* faster from front */
5759 midend -= littlelen;
5761 Move(big, midend - i, i, char);
5762 sv_chop(bigstr,midend-i);
5764 Move(little, mid, littlelen,char);
5766 else if (littlelen) {
5767 midend -= littlelen;
5768 sv_chop(bigstr,midend);
5769 Move(little,midend,littlelen,char);
5772 sv_chop(bigstr,midend);
5778 =for apidoc sv_replace
5780 Make the first argument a copy of the second, then delete the original.
5781 The target SV physically takes over ownership of the body of the source SV
5782 and inherits its flags; however, the target keeps any magic it owns,
5783 and any magic in the source is discarded.
5784 Note that this is a rather specialist SV copying operation; most of the
5785 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5791 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5794 const U32 refcnt = SvREFCNT(sv);
5796 PERL_ARGS_ASSERT_SV_REPLACE;
5798 SV_CHECK_THINKFIRST_COW_DROP(sv);
5799 if (SvREFCNT(nsv) != 1) {
5800 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
5801 " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
5803 if (SvMAGICAL(sv)) {
5807 sv_upgrade(nsv, SVt_PVMG);
5808 SvMAGIC_set(nsv, SvMAGIC(sv));
5809 SvFLAGS(nsv) |= SvMAGICAL(sv);
5811 SvMAGIC_set(sv, NULL);
5815 assert(!SvREFCNT(sv));
5816 #ifdef DEBUG_LEAKING_SCALARS
5817 sv->sv_flags = nsv->sv_flags;
5818 sv->sv_any = nsv->sv_any;
5819 sv->sv_refcnt = nsv->sv_refcnt;
5820 sv->sv_u = nsv->sv_u;
5822 StructCopy(nsv,sv,SV);
5824 if(SvTYPE(sv) == SVt_IV) {
5826 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5830 #ifdef PERL_OLD_COPY_ON_WRITE
5831 if (SvIsCOW_normal(nsv)) {
5832 /* We need to follow the pointers around the loop to make the
5833 previous SV point to sv, rather than nsv. */
5836 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5839 assert(SvPVX_const(current) == SvPVX_const(nsv));
5841 /* Make the SV before us point to the SV after us. */
5843 PerlIO_printf(Perl_debug_log, "previous is\n");
5845 PerlIO_printf(Perl_debug_log,
5846 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5847 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5849 SV_COW_NEXT_SV_SET(current, sv);
5852 SvREFCNT(sv) = refcnt;
5853 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5858 /* We're about to free a GV which has a CV that refers back to us.
5859 * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
5863 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
5869 PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
5872 assert(SvREFCNT(gv) == 0);
5873 assert(isGV(gv) && isGV_with_GP(gv));
5875 assert(!CvANON(cv));
5876 assert(CvGV(cv) == gv);
5878 /* will the CV shortly be freed by gp_free() ? */
5879 if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
5880 SvANY(cv)->xcv_gv = NULL;
5884 /* if not, anonymise: */
5885 stash = GvSTASH(gv) ? HvNAME(GvSTASH(gv)) : NULL;
5886 gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
5887 stash ? stash : "__ANON__");
5888 anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
5889 SvREFCNT_dec(gvname);
5893 SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
5898 =for apidoc sv_clear
5900 Clear an SV: call any destructors, free up any memory used by the body,
5901 and free the body itself. The SV's head is I<not> freed, although
5902 its type is set to all 1's so that it won't inadvertently be assumed
5903 to be live during global destruction etc.
5904 This function should only be called when REFCNT is zero. Most of the time
5905 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5912 Perl_sv_clear(pTHX_ SV *const orig_sv)
5917 const struct body_details *sv_type_details;
5920 register SV *sv = orig_sv;
5922 PERL_ARGS_ASSERT_SV_CLEAR;
5924 /* within this loop, sv is the SV currently being freed, and
5925 * iter_sv is the most recent AV or whatever that's being iterated
5926 * over to provide more SVs */
5932 assert(SvREFCNT(sv) == 0);
5933 assert(SvTYPE(sv) != SVTYPEMASK);
5935 if (type <= SVt_IV) {
5936 /* See the comment in sv.h about the collusion between this
5937 * early return and the overloading of the NULL slots in the
5941 SvFLAGS(sv) &= SVf_BREAK;
5942 SvFLAGS(sv) |= SVTYPEMASK;
5947 if (PL_defstash && /* Still have a symbol table? */
5954 stash = SvSTASH(sv);
5955 destructor = StashHANDLER(stash,DESTROY);
5957 /* A constant subroutine can have no side effects, so
5958 don't bother calling it. */
5959 && !CvCONST(destructor)
5960 /* Don't bother calling an empty destructor */
5961 && (CvISXSUB(destructor)
5962 || (CvSTART(destructor)
5963 && (CvSTART(destructor)->op_next->op_type
5966 SV* const tmpref = newRV(sv);
5967 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5969 PUSHSTACKi(PERLSI_DESTROY);
5974 call_sv(MUTABLE_SV(destructor),
5975 G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5979 if(SvREFCNT(tmpref) < 2) {
5980 /* tmpref is not kept alive! */
5982 SvRV_set(tmpref, NULL);
5985 SvREFCNT_dec(tmpref);
5987 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5991 if (PL_in_clean_objs)
5993 "DESTROY created new reference to dead object '%s'",
5995 /* DESTROY gave object new lease on life */
6001 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
6002 SvOBJECT_off(sv); /* Curse the object. */
6003 if (type != SVt_PVIO)
6004 --PL_sv_objcount;/* XXX Might want something more general */
6007 if (type >= SVt_PVMG) {
6008 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
6009 SvREFCNT_dec(SvOURSTASH(sv));
6010 } else if (SvMAGIC(sv))
6012 if (type == SVt_PVMG && SvPAD_TYPED(sv))
6013 SvREFCNT_dec(SvSTASH(sv));
6016 /* case SVt_BIND: */
6019 IoIFP(sv) != PerlIO_stdin() &&
6020 IoIFP(sv) != PerlIO_stdout() &&
6021 IoIFP(sv) != PerlIO_stderr() &&
6022 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6024 io_close(MUTABLE_IO(sv), FALSE);
6026 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6027 PerlDir_close(IoDIRP(sv));
6028 IoDIRP(sv) = (DIR*)NULL;
6029 Safefree(IoTOP_NAME(sv));
6030 Safefree(IoFMT_NAME(sv));
6031 Safefree(IoBOTTOM_NAME(sv));
6034 /* FIXME for plugins */
6035 pregfree2((REGEXP*) sv);
6039 cv_undef(MUTABLE_CV(sv));
6040 /* If we're in a stash, we don't own a reference to it.
6041 * However it does have a back reference to us, which needs to
6043 if ((stash = CvSTASH(sv)))
6044 sv_del_backref(MUTABLE_SV(stash), sv);
6047 if (PL_last_swash_hv == (const HV *)sv) {
6048 PL_last_swash_hv = NULL;
6050 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6051 Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6055 AV* av = MUTABLE_AV(sv);
6056 if (PL_comppad == av) {
6060 if (AvREAL(av) && AvFILLp(av) > -1) {
6061 next_sv = AvARRAY(av)[AvFILLp(av)--];
6062 /* save old iter_sv in top-most slot of AV,
6063 * and pray that it doesn't get wiped in the meantime */
6064 AvARRAY(av)[AvMAX(av)] = iter_sv;
6066 goto get_next_sv; /* process this new sv */
6068 Safefree(AvALLOC(av));
6073 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
6074 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
6075 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
6076 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
6078 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
6079 SvREFCNT_dec(LvTARG(sv));
6081 if (isGV_with_GP(sv)) {
6082 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
6083 && HvENAME_get(stash))
6084 mro_method_changed_in(stash);
6085 gp_free(MUTABLE_GV(sv));
6087 unshare_hek(GvNAME_HEK(sv));
6088 /* If we're in a stash, we don't own a reference to it.
6089 * However it does have a back reference to us, which
6090 * needs to be cleared. */
6091 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
6092 sv_del_backref(MUTABLE_SV(stash), sv);
6094 /* FIXME. There are probably more unreferenced pointers to SVs
6095 * in the interpreter struct that we should check and tidy in
6096 * a similar fashion to this: */
6097 if ((const GV *)sv == PL_last_in_gv)
6098 PL_last_in_gv = NULL;
6104 /* Don't bother with SvOOK_off(sv); as we're only going to
6108 SvOOK_offset(sv, offset);
6109 SvPV_set(sv, SvPVX_mutable(sv) - offset);
6110 /* Don't even bother with turning off the OOK flag. */
6115 SV * const target = SvRV(sv);
6117 sv_del_backref(target, sv);
6122 #ifdef PERL_OLD_COPY_ON_WRITE
6123 else if (SvPVX_const(sv)
6124 && !(SvTYPE(sv) == SVt_PVIO
6125 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6129 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6133 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
6135 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6139 } else if (SvLEN(sv)) {
6140 Safefree(SvPVX_const(sv));
6144 else if (SvPVX_const(sv) && SvLEN(sv)
6145 && !(SvTYPE(sv) == SVt_PVIO
6146 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6147 Safefree(SvPVX_mutable(sv));
6148 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
6149 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6160 SvFLAGS(sv) &= SVf_BREAK;
6161 SvFLAGS(sv) |= SVTYPEMASK;
6163 sv_type_details = bodies_by_type + type;
6164 if (sv_type_details->arena) {
6165 del_body(((char *)SvANY(sv) + sv_type_details->offset),
6166 &PL_body_roots[type]);
6168 else if (sv_type_details->body_size) {
6169 safefree(SvANY(sv));
6173 /* caller is responsible for freeing the head of the original sv */
6174 if (sv != orig_sv && !SvREFCNT(sv))
6177 /* grab and free next sv, if any */
6185 else if (!iter_sv) {
6187 } else if (SvTYPE(iter_sv) == SVt_PVAV) {
6188 AV *const av = (AV*)iter_sv;
6189 if (AvFILLp(av) > -1) {
6190 sv = AvARRAY(av)[AvFILLp(av)--];
6192 else { /* no more elements of current AV to free */
6195 /* restore previous value, squirrelled away */
6196 iter_sv = AvARRAY(av)[AvMAX(av)];
6197 Safefree(AvALLOC(av));
6202 /* unrolled SvREFCNT_dec and sv_free2 follows: */
6206 if (!SvREFCNT(sv)) {
6210 if (--(SvREFCNT(sv)))
6214 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6215 "Attempt to free temp prematurely: SV 0x%"UVxf
6216 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6220 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6221 /* make sure SvREFCNT(sv)==0 happens very seldom */
6222 SvREFCNT(sv) = (~(U32)0)/2;
6232 =for apidoc sv_newref
6234 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6241 Perl_sv_newref(pTHX_ SV *const sv)
6243 PERL_UNUSED_CONTEXT;
6252 Decrement an SV's reference count, and if it drops to zero, call
6253 C<sv_clear> to invoke destructors and free up any memory used by
6254 the body; finally, deallocate the SV's head itself.
6255 Normally called via a wrapper macro C<SvREFCNT_dec>.
6261 Perl_sv_free(pTHX_ SV *const sv)
6266 if (SvREFCNT(sv) == 0) {
6267 if (SvFLAGS(sv) & SVf_BREAK)
6268 /* this SV's refcnt has been artificially decremented to
6269 * trigger cleanup */
6271 if (PL_in_clean_all) /* All is fair */
6273 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6274 /* make sure SvREFCNT(sv)==0 happens very seldom */
6275 SvREFCNT(sv) = (~(U32)0)/2;
6278 if (ckWARN_d(WARN_INTERNAL)) {
6279 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
6280 Perl_dump_sv_child(aTHX_ sv);
6282 #ifdef DEBUG_LEAKING_SCALARS
6285 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6286 if (PL_warnhook == PERL_WARNHOOK_FATAL
6287 || ckDEAD(packWARN(WARN_INTERNAL))) {
6288 /* Don't let Perl_warner cause us to escape our fate: */
6292 /* This may not return: */
6293 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6294 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6295 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6298 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6303 if (--(SvREFCNT(sv)) > 0)
6305 Perl_sv_free2(aTHX_ sv);
6309 Perl_sv_free2(pTHX_ SV *const sv)
6313 PERL_ARGS_ASSERT_SV_FREE2;
6317 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6318 "Attempt to free temp prematurely: SV 0x%"UVxf
6319 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6323 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6324 /* make sure SvREFCNT(sv)==0 happens very seldom */
6325 SvREFCNT(sv) = (~(U32)0)/2;
6336 Returns the length of the string in the SV. Handles magic and type
6337 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6343 Perl_sv_len(pTHX_ register SV *const sv)
6351 len = mg_length(sv);
6353 (void)SvPV_const(sv, len);
6358 =for apidoc sv_len_utf8
6360 Returns the number of characters in the string in an SV, counting wide
6361 UTF-8 bytes as a single character. Handles magic and type coercion.
6367 * The length is cached in PERL_MAGIC_utf8, in the mg_len field. Also the
6368 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6369 * (Note that the mg_len is not the length of the mg_ptr field.
6370 * This allows the cache to store the character length of the string without
6371 * needing to malloc() extra storage to attach to the mg_ptr.)
6376 Perl_sv_len_utf8(pTHX_ register SV *const sv)
6382 return mg_length(sv);
6386 const U8 *s = (U8*)SvPV_const(sv, len);
6390 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6392 if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
6393 if (mg->mg_len != -1)
6396 /* We can use the offset cache for a headstart.
6397 The longer value is stored in the first pair. */
6398 STRLEN *cache = (STRLEN *) mg->mg_ptr;
6400 ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
6404 if (PL_utf8cache < 0) {
6405 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6406 assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
6410 ulen = Perl_utf8_length(aTHX_ s, s + len);
6411 utf8_mg_len_cache_update(sv, &mg, ulen);
6415 return Perl_utf8_length(aTHX_ s, s + len);
6419 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6422 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6423 STRLEN *const uoffset_p, bool *const at_end)
6425 const U8 *s = start;
6426 STRLEN uoffset = *uoffset_p;
6428 PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6430 while (s < send && uoffset) {
6437 else if (s > send) {
6439 /* This is the existing behaviour. Possibly it should be a croak, as
6440 it's actually a bounds error */
6443 *uoffset_p -= uoffset;
6447 /* Given the length of the string in both bytes and UTF-8 characters, decide
6448 whether to walk forwards or backwards to find the byte corresponding to
6449 the passed in UTF-8 offset. */
6451 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6452 STRLEN uoffset, const STRLEN uend)
6454 STRLEN backw = uend - uoffset;
6456 PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6458 if (uoffset < 2 * backw) {
6459 /* The assumption is that going forwards is twice the speed of going
6460 forward (that's where the 2 * backw comes from).
6461 (The real figure of course depends on the UTF-8 data.) */
6462 const U8 *s = start;
6464 while (s < send && uoffset--)
6474 while (UTF8_IS_CONTINUATION(*send))
6477 return send - start;
6480 /* For the string representation of the given scalar, find the byte
6481 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
6482 give another position in the string, *before* the sought offset, which
6483 (which is always true, as 0, 0 is a valid pair of positions), which should
6484 help reduce the amount of linear searching.
6485 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6486 will be used to reduce the amount of linear searching. The cache will be
6487 created if necessary, and the found value offered to it for update. */
6489 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6490 const U8 *const send, STRLEN uoffset,
6491 STRLEN uoffset0, STRLEN boffset0)
6493 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
6495 bool at_end = FALSE;
6497 PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6499 assert (uoffset >= uoffset0);
6506 && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
6507 (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
6508 if ((*mgp)->mg_ptr) {
6509 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6510 if (cache[0] == uoffset) {
6511 /* An exact match. */
6514 if (cache[2] == uoffset) {
6515 /* An exact match. */
6519 if (cache[0] < uoffset) {
6520 /* The cache already knows part of the way. */
6521 if (cache[0] > uoffset0) {
6522 /* The cache knows more than the passed in pair */
6523 uoffset0 = cache[0];
6524 boffset0 = cache[1];
6526 if ((*mgp)->mg_len != -1) {
6527 /* And we know the end too. */
6529 + sv_pos_u2b_midway(start + boffset0, send,
6531 (*mgp)->mg_len - uoffset0);
6533 uoffset -= uoffset0;
6535 + sv_pos_u2b_forwards(start + boffset0,
6536 send, &uoffset, &at_end);
6537 uoffset += uoffset0;
6540 else if (cache[2] < uoffset) {
6541 /* We're between the two cache entries. */
6542 if (cache[2] > uoffset0) {
6543 /* and the cache knows more than the passed in pair */
6544 uoffset0 = cache[2];
6545 boffset0 = cache[3];
6549 + sv_pos_u2b_midway(start + boffset0,
6552 cache[0] - uoffset0);
6555 + sv_pos_u2b_midway(start + boffset0,
6558 cache[2] - uoffset0);
6562 else if ((*mgp)->mg_len != -1) {
6563 /* If we can take advantage of a passed in offset, do so. */
6564 /* In fact, offset0 is either 0, or less than offset, so don't
6565 need to worry about the other possibility. */
6567 + sv_pos_u2b_midway(start + boffset0, send,
6569 (*mgp)->mg_len - uoffset0);
6574 if (!found || PL_utf8cache < 0) {
6575 STRLEN real_boffset;
6576 uoffset -= uoffset0;
6577 real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6578 send, &uoffset, &at_end);
6579 uoffset += uoffset0;
6581 if (found && PL_utf8cache < 0)
6582 assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
6584 boffset = real_boffset;
6589 utf8_mg_len_cache_update(sv, mgp, uoffset);
6591 utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6598 =for apidoc sv_pos_u2b_flags
6600 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6601 the start of the string, to a count of the equivalent number of bytes; if
6602 lenp is non-zero, it does the same to lenp, but this time starting from
6603 the offset, rather than from the start of the string. Handles type coercion.
6604 I<flags> is passed to C<SvPV_flags>, and usually should be
6605 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
6611 * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
6612 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6613 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6618 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
6625 PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
6627 start = (U8*)SvPV_flags(sv, len, flags);
6629 const U8 * const send = start + len;
6631 boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
6634 && *lenp /* don't bother doing work for 0, as its bytes equivalent
6635 is 0, and *lenp is already set to that. */) {
6636 /* Convert the relative offset to absolute. */
6637 const STRLEN uoffset2 = uoffset + *lenp;
6638 const STRLEN boffset2
6639 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6640 uoffset, boffset) - boffset;
6654 =for apidoc sv_pos_u2b
6656 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6657 the start of the string, to a count of the equivalent number of bytes; if
6658 lenp is non-zero, it does the same to lenp, but this time starting from
6659 the offset, rather than from the start of the string. Handles magic and
6662 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
6669 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6670 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6671 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6675 /* This function is subject to size and sign problems */
6678 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6680 PERL_ARGS_ASSERT_SV_POS_U2B;
6683 STRLEN ulen = (STRLEN)*lenp;
6684 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
6685 SV_GMAGIC|SV_CONST_RETURN);
6688 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
6689 SV_GMAGIC|SV_CONST_RETURN);
6694 S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
6697 PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
6701 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6702 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6703 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
6707 (*mgp)->mg_len = ulen;
6708 /* For now, treat "overflowed" as "still unknown". See RT #72924. */
6709 if (ulen != (STRLEN) (*mgp)->mg_len)
6710 (*mgp)->mg_len = -1;
6713 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6714 byte length pairing. The (byte) length of the total SV is passed in too,
6715 as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6716 may not have updated SvCUR, so we can't rely on reading it directly.
6718 The proffered utf8/byte length pairing isn't used if the cache already has
6719 two pairs, and swapping either for the proffered pair would increase the
6720 RMS of the intervals between known byte offsets.
6722 The cache itself consists of 4 STRLEN values
6723 0: larger UTF-8 offset
6724 1: corresponding byte offset
6725 2: smaller UTF-8 offset
6726 3: corresponding byte offset
6728 Unused cache pairs have the value 0, 0.
6729 Keeping the cache "backwards" means that the invariant of
6730 cache[0] >= cache[2] is maintained even with empty slots, which means that
6731 the code that uses it doesn't need to worry if only 1 entry has actually
6732 been set to non-zero. It also makes the "position beyond the end of the
6733 cache" logic much simpler, as the first slot is always the one to start
6737 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6738 const STRLEN utf8, const STRLEN blen)
6742 PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6747 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6748 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6749 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6751 (*mgp)->mg_len = -1;
6755 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6756 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6757 (*mgp)->mg_ptr = (char *) cache;
6761 if (PL_utf8cache < 0 && SvPOKp(sv)) {
6762 /* SvPOKp() because it's possible that sv has string overloading, and
6763 therefore is a reference, hence SvPVX() is actually a pointer.
6764 This cures the (very real) symptoms of RT 69422, but I'm not actually
6765 sure whether we should even be caching the results of UTF-8
6766 operations on overloading, given that nothing stops overloading
6767 returning a different value every time it's called. */
6768 const U8 *start = (const U8 *) SvPVX_const(sv);
6769 const STRLEN realutf8 = utf8_length(start, start + byte);
6771 assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
6775 /* Cache is held with the later position first, to simplify the code
6776 that deals with unbounded ends. */
6778 ASSERT_UTF8_CACHE(cache);
6779 if (cache[1] == 0) {
6780 /* Cache is totally empty */
6783 } else if (cache[3] == 0) {
6784 if (byte > cache[1]) {
6785 /* New one is larger, so goes first. */
6786 cache[2] = cache[0];
6787 cache[3] = cache[1];
6795 #define THREEWAY_SQUARE(a,b,c,d) \
6796 ((float)((d) - (c))) * ((float)((d) - (c))) \
6797 + ((float)((c) - (b))) * ((float)((c) - (b))) \
6798 + ((float)((b) - (a))) * ((float)((b) - (a)))
6800 /* Cache has 2 slots in use, and we know three potential pairs.
6801 Keep the two that give the lowest RMS distance. Do the
6802 calcualation in bytes simply because we always know the byte
6803 length. squareroot has the same ordering as the positive value,
6804 so don't bother with the actual square root. */
6805 const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6806 if (byte > cache[1]) {
6807 /* New position is after the existing pair of pairs. */
6808 const float keep_earlier
6809 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6810 const float keep_later
6811 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6813 if (keep_later < keep_earlier) {
6814 if (keep_later < existing) {
6815 cache[2] = cache[0];
6816 cache[3] = cache[1];
6822 if (keep_earlier < existing) {
6828 else if (byte > cache[3]) {
6829 /* New position is between the existing pair of pairs. */
6830 const float keep_earlier
6831 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6832 const float keep_later
6833 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6835 if (keep_later < keep_earlier) {
6836 if (keep_later < existing) {
6842 if (keep_earlier < existing) {
6849 /* New position is before the existing pair of pairs. */
6850 const float keep_earlier
6851 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6852 const float keep_later
6853 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6855 if (keep_later < keep_earlier) {
6856 if (keep_later < existing) {
6862 if (keep_earlier < existing) {
6863 cache[0] = cache[2];
6864 cache[1] = cache[3];
6871 ASSERT_UTF8_CACHE(cache);
6874 /* We already know all of the way, now we may be able to walk back. The same
6875 assumption is made as in S_sv_pos_u2b_midway(), namely that walking
6876 backward is half the speed of walking forward. */
6878 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
6879 const U8 *end, STRLEN endu)
6881 const STRLEN forw = target - s;
6882 STRLEN backw = end - target;
6884 PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
6886 if (forw < 2 * backw) {
6887 return utf8_length(s, target);
6890 while (end > target) {
6892 while (UTF8_IS_CONTINUATION(*end)) {
6901 =for apidoc sv_pos_b2u
6903 Converts the value pointed to by offsetp from a count of bytes from the
6904 start of the string, to a count of the equivalent number of UTF-8 chars.
6905 Handles magic and type coercion.
6911 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6912 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6917 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
6920 const STRLEN byte = *offsetp;
6921 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
6927 PERL_ARGS_ASSERT_SV_POS_B2U;
6932 s = (const U8*)SvPV_const(sv, blen);
6935 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6941 && SvTYPE(sv) >= SVt_PVMG
6942 && (mg = mg_find(sv, PERL_MAGIC_utf8)))
6945 STRLEN * const cache = (STRLEN *) mg->mg_ptr;
6946 if (cache[1] == byte) {
6947 /* An exact match. */
6948 *offsetp = cache[0];
6951 if (cache[3] == byte) {
6952 /* An exact match. */
6953 *offsetp = cache[2];
6957 if (cache[1] < byte) {
6958 /* We already know part of the way. */
6959 if (mg->mg_len != -1) {
6960 /* Actually, we know the end too. */
6962 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
6963 s + blen, mg->mg_len - cache[0]);
6965 len = cache[0] + utf8_length(s + cache[1], send);
6968 else if (cache[3] < byte) {
6969 /* We're between the two cached pairs, so we do the calculation
6970 offset by the byte/utf-8 positions for the earlier pair,
6971 then add the utf-8 characters from the string start to
6973 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
6974 s + cache[1], cache[0] - cache[2])
6978 else { /* cache[3] > byte */
6979 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
6983 ASSERT_UTF8_CACHE(cache);
6985 } else if (mg->mg_len != -1) {
6986 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
6990 if (!found || PL_utf8cache < 0) {
6991 const STRLEN real_len = utf8_length(s, send);
6993 if (found && PL_utf8cache < 0)
6994 assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
7001 utf8_mg_len_cache_update(sv, &mg, len);
7003 utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
7008 S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
7009 STRLEN real, SV *const sv)
7011 PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
7013 /* As this is debugging only code, save space by keeping this test here,
7014 rather than inlining it in all the callers. */
7015 if (from_cache == real)
7018 /* Need to turn the assertions off otherwise we may recurse infinitely
7019 while printing error messages. */
7020 SAVEI8(PL_utf8cache);
7022 Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
7023 func, (UV) from_cache, (UV) real, SVfARG(sv));
7029 Returns a boolean indicating whether the strings in the two SVs are
7030 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7031 coerce its args to strings if necessary.
7033 =for apidoc sv_eq_flags
7035 Returns a boolean indicating whether the strings in the two SVs are
7036 identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings
7037 if necessary. If the flags include SV_GMAGIC, it handles get-magic, too.
7043 Perl_sv_eq_flags(pTHX_ register SV *sv1, register SV *sv2, const U32 flags)
7052 SV* svrecode = NULL;
7059 /* if pv1 and pv2 are the same, second SvPV_const call may
7060 * invalidate pv1 (if we are handling magic), so we may need to
7062 if (sv1 == sv2 && flags & SV_GMAGIC
7063 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
7064 pv1 = SvPV_const(sv1, cur1);
7065 sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
7067 pv1 = SvPV_flags_const(sv1, cur1, flags);
7075 pv2 = SvPV_flags_const(sv2, cur2, flags);
7077 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7078 /* Differing utf8ness.
7079 * Do not UTF8size the comparands as a side-effect. */
7082 svrecode = newSVpvn(pv2, cur2);
7083 sv_recode_to_utf8(svrecode, PL_encoding);
7084 pv2 = SvPV_const(svrecode, cur2);
7087 svrecode = newSVpvn(pv1, cur1);
7088 sv_recode_to_utf8(svrecode, PL_encoding);
7089 pv1 = SvPV_const(svrecode, cur1);
7091 /* Now both are in UTF-8. */
7093 SvREFCNT_dec(svrecode);
7099 /* sv1 is the UTF-8 one */
7100 return bytes_cmp_utf8((const U8*)pv2, cur2,
7101 (const U8*)pv1, cur1) == 0;
7104 /* sv2 is the UTF-8 one */
7105 return bytes_cmp_utf8((const U8*)pv1, cur1,
7106 (const U8*)pv2, cur2) == 0;
7112 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
7114 SvREFCNT_dec(svrecode);
7124 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7125 string in C<sv1> is less than, equal to, or greater than the string in
7126 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7127 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
7129 =for apidoc sv_cmp_flags
7131 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7132 string in C<sv1> is less than, equal to, or greater than the string in
7133 C<sv2>. Is UTF-8 and 'use bytes' aware and will coerce its args to strings
7134 if necessary. If the flags include SV_GMAGIC, it handles get magic. See
7135 also C<sv_cmp_locale_flags>.
7141 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
7143 return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
7147 Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2,
7152 const char *pv1, *pv2;
7155 SV *svrecode = NULL;
7162 pv1 = SvPV_flags_const(sv1, cur1, flags);
7169 pv2 = SvPV_flags_const(sv2, cur2, flags);
7171 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7172 /* Differing utf8ness.
7173 * Do not UTF8size the comparands as a side-effect. */
7176 svrecode = newSVpvn(pv2, cur2);
7177 sv_recode_to_utf8(svrecode, PL_encoding);
7178 pv2 = SvPV_const(svrecode, cur2);
7181 const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2,
7182 (const U8*)pv1, cur1);
7183 return retval ? retval < 0 ? -1 : +1 : 0;
7188 svrecode = newSVpvn(pv1, cur1);
7189 sv_recode_to_utf8(svrecode, PL_encoding);
7190 pv1 = SvPV_const(svrecode, cur1);
7193 const int retval = bytes_cmp_utf8((const U8*)pv1, cur1,
7194 (const U8*)pv2, cur2);
7195 return retval ? retval < 0 ? -1 : +1 : 0;
7201 cmp = cur2 ? -1 : 0;
7205 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
7208 cmp = retval < 0 ? -1 : 1;
7209 } else if (cur1 == cur2) {
7212 cmp = cur1 < cur2 ? -1 : 1;
7216 SvREFCNT_dec(svrecode);
7224 =for apidoc sv_cmp_locale
7226 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7227 'use bytes' aware, handles get magic, and will coerce its args to strings
7228 if necessary. See also C<sv_cmp>.
7230 =for apidoc sv_cmp_locale_flags
7232 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7233 'use bytes' aware and will coerce its args to strings if necessary. If the
7234 flags contain SV_GMAGIC, it handles get magic. See also C<sv_cmp_flags>.
7240 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
7242 return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
7246 Perl_sv_cmp_locale_flags(pTHX_ register SV *const sv1, register SV *const sv2,
7250 #ifdef USE_LOCALE_COLLATE
7256 if (PL_collation_standard)
7260 pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
7262 pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
7264 if (!pv1 || !len1) {
7275 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
7278 return retval < 0 ? -1 : 1;
7281 * When the result of collation is equality, that doesn't mean
7282 * that there are no differences -- some locales exclude some
7283 * characters from consideration. So to avoid false equalities,
7284 * we use the raw string as a tiebreaker.
7290 #endif /* USE_LOCALE_COLLATE */
7292 return sv_cmp(sv1, sv2);
7296 #ifdef USE_LOCALE_COLLATE
7299 =for apidoc sv_collxfrm
7301 This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag. See
7302 C<sv_collxfrm_flags>.
7304 =for apidoc sv_collxfrm_flags
7306 Add Collate Transform magic to an SV if it doesn't already have it. If the
7307 flags contain SV_GMAGIC, it handles get-magic.
7309 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
7310 scalar data of the variable, but transformed to such a format that a normal
7311 memory comparison can be used to compare the data according to the locale
7318 Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
7323 PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
7325 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
7326 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
7332 Safefree(mg->mg_ptr);
7333 s = SvPV_flags_const(sv, len, flags);
7334 if ((xf = mem_collxfrm(s, len, &xlen))) {
7336 #ifdef PERL_OLD_COPY_ON_WRITE
7338 sv_force_normal_flags(sv, 0);
7340 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
7354 if (mg && mg->mg_ptr) {
7356 return mg->mg_ptr + sizeof(PL_collation_ix);
7364 #endif /* USE_LOCALE_COLLATE */
7369 Get a line from the filehandle and store it into the SV, optionally
7370 appending to the currently-stored string.
7376 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
7381 register STDCHAR rslast;
7382 register STDCHAR *bp;
7387 PERL_ARGS_ASSERT_SV_GETS;
7389 if (SvTHINKFIRST(sv))
7390 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
7391 /* XXX. If you make this PVIV, then copy on write can copy scalars read
7393 However, perlbench says it's slower, because the existing swipe code
7394 is faster than copy on write.
7395 Swings and roundabouts. */
7396 SvUPGRADE(sv, SVt_PV);
7401 if (PerlIO_isutf8(fp)) {
7403 sv_utf8_upgrade_nomg(sv);
7404 sv_pos_u2b(sv,&append,0);
7406 } else if (SvUTF8(sv)) {
7407 SV * const tsv = newSV(0);
7410 sv_gets(tsv, fp, 0);
7411 sv_utf8_upgrade_nomg(tsv);
7412 SvCUR_set(sv,append);
7415 goto return_string_or_null;
7423 if (PerlIO_isutf8(fp))
7426 if (IN_PERL_COMPILETIME) {
7427 /* we always read code in line mode */
7431 else if (RsSNARF(PL_rs)) {
7432 /* If it is a regular disk file use size from stat() as estimate
7433 of amount we are going to read -- may result in mallocing
7434 more memory than we really need if the layers below reduce
7435 the size we read (e.g. CRLF or a gzip layer).
7438 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
7439 const Off_t offset = PerlIO_tell(fp);
7440 if (offset != (Off_t) -1 && st.st_size + append > offset) {
7441 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7447 else if (RsRECORD(PL_rs)) {
7455 /* Grab the size of the record we're getting */
7456 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7457 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7460 /* VMS wants read instead of fread, because fread doesn't respect */
7461 /* RMS record boundaries. This is not necessarily a good thing to be */
7462 /* doing, but we've got no other real choice - except avoid stdio
7463 as implementation - perhaps write a :vms layer ?
7465 fd = PerlIO_fileno(fp);
7466 if (fd == -1) { /* in-memory file from PerlIO::Scalar */
7467 bytesread = PerlIO_read(fp, buffer, recsize);
7470 bytesread = PerlLIO_read(fd, buffer, recsize);
7473 bytesread = PerlIO_read(fp, buffer, recsize);
7477 SvCUR_set(sv, bytesread + append);
7478 buffer[bytesread] = '\0';
7479 goto return_string_or_null;
7481 else if (RsPARA(PL_rs)) {
7487 /* Get $/ i.e. PL_rs into same encoding as stream wants */
7488 if (PerlIO_isutf8(fp)) {
7489 rsptr = SvPVutf8(PL_rs, rslen);
7492 if (SvUTF8(PL_rs)) {
7493 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7494 Perl_croak(aTHX_ "Wide character in $/");
7497 rsptr = SvPV_const(PL_rs, rslen);
7501 rslast = rslen ? rsptr[rslen - 1] : '\0';
7503 if (rspara) { /* have to do this both before and after */
7504 do { /* to make sure file boundaries work right */
7507 i = PerlIO_getc(fp);
7511 PerlIO_ungetc(fp,i);
7517 /* See if we know enough about I/O mechanism to cheat it ! */
7519 /* This used to be #ifdef test - it is made run-time test for ease
7520 of abstracting out stdio interface. One call should be cheap
7521 enough here - and may even be a macro allowing compile
7525 if (PerlIO_fast_gets(fp)) {
7528 * We're going to steal some values from the stdio struct
7529 * and put EVERYTHING in the innermost loop into registers.
7531 register STDCHAR *ptr;
7535 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7536 /* An ungetc()d char is handled separately from the regular
7537 * buffer, so we getc() it back out and stuff it in the buffer.
7539 i = PerlIO_getc(fp);
7540 if (i == EOF) return 0;
7541 *(--((*fp)->_ptr)) = (unsigned char) i;
7545 /* Here is some breathtakingly efficient cheating */
7547 cnt = PerlIO_get_cnt(fp); /* get count into register */
7548 /* make sure we have the room */
7549 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7550 /* Not room for all of it
7551 if we are looking for a separator and room for some
7553 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7554 /* just process what we have room for */
7555 shortbuffered = cnt - SvLEN(sv) + append + 1;
7556 cnt -= shortbuffered;
7560 /* remember that cnt can be negative */
7561 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7566 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
7567 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7568 DEBUG_P(PerlIO_printf(Perl_debug_log,
7569 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7570 DEBUG_P(PerlIO_printf(Perl_debug_log,
7571 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7572 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7573 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7578 while (cnt > 0) { /* this | eat */
7580 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7581 goto thats_all_folks; /* screams | sed :-) */
7585 Copy(ptr, bp, cnt, char); /* this | eat */
7586 bp += cnt; /* screams | dust */
7587 ptr += cnt; /* louder | sed :-) */
7592 if (shortbuffered) { /* oh well, must extend */
7593 cnt = shortbuffered;
7595 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7597 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7598 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7602 DEBUG_P(PerlIO_printf(Perl_debug_log,
7603 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7604 PTR2UV(ptr),(long)cnt));
7605 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7607 DEBUG_P(PerlIO_printf(Perl_debug_log,
7608 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7609 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7610 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7612 /* This used to call 'filbuf' in stdio form, but as that behaves like
7613 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7614 another abstraction. */
7615 i = PerlIO_getc(fp); /* get more characters */
7617 DEBUG_P(PerlIO_printf(Perl_debug_log,
7618 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7619 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7620 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7622 cnt = PerlIO_get_cnt(fp);
7623 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7624 DEBUG_P(PerlIO_printf(Perl_debug_log,
7625 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7627 if (i == EOF) /* all done for ever? */
7628 goto thats_really_all_folks;
7630 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7632 SvGROW(sv, bpx + cnt + 2);
7633 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7635 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7637 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7638 goto thats_all_folks;
7642 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7643 memNE((char*)bp - rslen, rsptr, rslen))
7644 goto screamer; /* go back to the fray */
7645 thats_really_all_folks:
7647 cnt += shortbuffered;
7648 DEBUG_P(PerlIO_printf(Perl_debug_log,
7649 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7650 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7651 DEBUG_P(PerlIO_printf(Perl_debug_log,
7652 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7653 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7654 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7656 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
7657 DEBUG_P(PerlIO_printf(Perl_debug_log,
7658 "Screamer: done, len=%ld, string=|%.*s|\n",
7659 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7663 /*The big, slow, and stupid way. */
7664 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
7665 STDCHAR *buf = NULL;
7666 Newx(buf, 8192, STDCHAR);
7674 register const STDCHAR * const bpe = buf + sizeof(buf);
7676 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7677 ; /* keep reading */
7681 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7682 /* Accomodate broken VAXC compiler, which applies U8 cast to
7683 * both args of ?: operator, causing EOF to change into 255
7686 i = (U8)buf[cnt - 1];
7692 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7694 sv_catpvn(sv, (char *) buf, cnt);
7696 sv_setpvn(sv, (char *) buf, cnt);
7698 if (i != EOF && /* joy */
7700 SvCUR(sv) < rslen ||
7701 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7705 * If we're reading from a TTY and we get a short read,
7706 * indicating that the user hit his EOF character, we need
7707 * to notice it now, because if we try to read from the TTY
7708 * again, the EOF condition will disappear.
7710 * The comparison of cnt to sizeof(buf) is an optimization
7711 * that prevents unnecessary calls to feof().
7715 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7719 #ifdef USE_HEAP_INSTEAD_OF_STACK
7724 if (rspara) { /* have to do this both before and after */
7725 while (i != EOF) { /* to make sure file boundaries work right */
7726 i = PerlIO_getc(fp);
7728 PerlIO_ungetc(fp,i);
7734 return_string_or_null:
7735 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7741 Auto-increment of the value in the SV, doing string to numeric conversion
7742 if necessary. Handles 'get' magic and operator overloading.
7748 Perl_sv_inc(pTHX_ register SV *const sv)
7757 =for apidoc sv_inc_nomg
7759 Auto-increment of the value in the SV, doing string to numeric conversion
7760 if necessary. Handles operator overloading. Skips handling 'get' magic.
7766 Perl_sv_inc_nomg(pTHX_ register SV *const sv)
7774 if (SvTHINKFIRST(sv)) {
7776 sv_force_normal_flags(sv, 0);
7777 if (SvREADONLY(sv)) {
7778 if (IN_PERL_RUNTIME)
7779 Perl_croak_no_modify(aTHX);
7783 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7785 i = PTR2IV(SvRV(sv));
7790 flags = SvFLAGS(sv);
7791 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7792 /* It's (privately or publicly) a float, but not tested as an
7793 integer, so test it to see. */
7795 flags = SvFLAGS(sv);
7797 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7798 /* It's publicly an integer, or privately an integer-not-float */
7799 #ifdef PERL_PRESERVE_IVUV
7803 if (SvUVX(sv) == UV_MAX)
7804 sv_setnv(sv, UV_MAX_P1);
7806 (void)SvIOK_only_UV(sv);
7807 SvUV_set(sv, SvUVX(sv) + 1);
7809 if (SvIVX(sv) == IV_MAX)
7810 sv_setuv(sv, (UV)IV_MAX + 1);
7812 (void)SvIOK_only(sv);
7813 SvIV_set(sv, SvIVX(sv) + 1);
7818 if (flags & SVp_NOK) {
7819 const NV was = SvNVX(sv);
7820 if (NV_OVERFLOWS_INTEGERS_AT &&
7821 was >= NV_OVERFLOWS_INTEGERS_AT) {
7822 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7823 "Lost precision when incrementing %" NVff " by 1",
7826 (void)SvNOK_only(sv);
7827 SvNV_set(sv, was + 1.0);
7831 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7832 if ((flags & SVTYPEMASK) < SVt_PVIV)
7833 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
7834 (void)SvIOK_only(sv);
7839 while (isALPHA(*d)) d++;
7840 while (isDIGIT(*d)) d++;
7841 if (d < SvEND(sv)) {
7842 #ifdef PERL_PRESERVE_IVUV
7843 /* Got to punt this as an integer if needs be, but we don't issue
7844 warnings. Probably ought to make the sv_iv_please() that does
7845 the conversion if possible, and silently. */
7846 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7847 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7848 /* Need to try really hard to see if it's an integer.
7849 9.22337203685478e+18 is an integer.
7850 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7851 so $a="9.22337203685478e+18"; $a+0; $a++
7852 needs to be the same as $a="9.22337203685478e+18"; $a++
7859 /* sv_2iv *should* have made this an NV */
7860 if (flags & SVp_NOK) {
7861 (void)SvNOK_only(sv);
7862 SvNV_set(sv, SvNVX(sv) + 1.0);
7865 /* I don't think we can get here. Maybe I should assert this
7866 And if we do get here I suspect that sv_setnv will croak. NWC
7868 #if defined(USE_LONG_DOUBLE)
7869 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",
7870 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7872 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7873 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7876 #endif /* PERL_PRESERVE_IVUV */
7877 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7881 while (d >= SvPVX_const(sv)) {
7889 /* MKS: The original code here died if letters weren't consecutive.
7890 * at least it didn't have to worry about non-C locales. The
7891 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7892 * arranged in order (although not consecutively) and that only
7893 * [A-Za-z] are accepted by isALPHA in the C locale.
7895 if (*d != 'z' && *d != 'Z') {
7896 do { ++*d; } while (!isALPHA(*d));
7899 *(d--) -= 'z' - 'a';
7904 *(d--) -= 'z' - 'a' + 1;
7908 /* oh,oh, the number grew */
7909 SvGROW(sv, SvCUR(sv) + 2);
7910 SvCUR_set(sv, SvCUR(sv) + 1);
7911 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7922 Auto-decrement of the value in the SV, doing string to numeric conversion
7923 if necessary. Handles 'get' magic and operator overloading.
7929 Perl_sv_dec(pTHX_ register SV *const sv)
7939 =for apidoc sv_dec_nomg
7941 Auto-decrement of the value in the SV, doing string to numeric conversion
7942 if necessary. Handles operator overloading. Skips handling 'get' magic.
7948 Perl_sv_dec_nomg(pTHX_ register SV *const sv)
7955 if (SvTHINKFIRST(sv)) {
7957 sv_force_normal_flags(sv, 0);
7958 if (SvREADONLY(sv)) {
7959 if (IN_PERL_RUNTIME)
7960 Perl_croak_no_modify(aTHX);
7964 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7966 i = PTR2IV(SvRV(sv));
7971 /* Unlike sv_inc we don't have to worry about string-never-numbers
7972 and keeping them magic. But we mustn't warn on punting */
7973 flags = SvFLAGS(sv);
7974 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7975 /* It's publicly an integer, or privately an integer-not-float */
7976 #ifdef PERL_PRESERVE_IVUV
7980 if (SvUVX(sv) == 0) {
7981 (void)SvIOK_only(sv);
7985 (void)SvIOK_only_UV(sv);
7986 SvUV_set(sv, SvUVX(sv) - 1);
7989 if (SvIVX(sv) == IV_MIN) {
7990 sv_setnv(sv, (NV)IV_MIN);
7994 (void)SvIOK_only(sv);
7995 SvIV_set(sv, SvIVX(sv) - 1);
8000 if (flags & SVp_NOK) {
8003 const NV was = SvNVX(sv);
8004 if (NV_OVERFLOWS_INTEGERS_AT &&
8005 was <= -NV_OVERFLOWS_INTEGERS_AT) {
8006 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
8007 "Lost precision when decrementing %" NVff " by 1",
8010 (void)SvNOK_only(sv);
8011 SvNV_set(sv, was - 1.0);
8015 if (!(flags & SVp_POK)) {
8016 if ((flags & SVTYPEMASK) < SVt_PVIV)
8017 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
8019 (void)SvIOK_only(sv);
8022 #ifdef PERL_PRESERVE_IVUV
8024 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8025 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
8026 /* Need to try really hard to see if it's an integer.
8027 9.22337203685478e+18 is an integer.
8028 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8029 so $a="9.22337203685478e+18"; $a+0; $a--
8030 needs to be the same as $a="9.22337203685478e+18"; $a--
8037 /* sv_2iv *should* have made this an NV */
8038 if (flags & SVp_NOK) {
8039 (void)SvNOK_only(sv);
8040 SvNV_set(sv, SvNVX(sv) - 1.0);
8043 /* I don't think we can get here. Maybe I should assert this
8044 And if we do get here I suspect that sv_setnv will croak. NWC
8046 #if defined(USE_LONG_DOUBLE)
8047 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",
8048 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8050 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8051 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8055 #endif /* PERL_PRESERVE_IVUV */
8056 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
8059 /* this define is used to eliminate a chunk of duplicated but shared logic
8060 * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
8061 * used anywhere but here - yves
8063 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
8066 PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
8070 =for apidoc sv_mortalcopy
8072 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
8073 The new SV is marked as mortal. It will be destroyed "soon", either by an
8074 explicit call to FREETMPS, or by an implicit call at places such as
8075 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
8080 /* Make a string that will exist for the duration of the expression
8081 * evaluation. Actually, it may have to last longer than that, but
8082 * hopefully we won't free it until it has been assigned to a
8083 * permanent location. */
8086 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
8092 sv_setsv(sv,oldstr);
8093 PUSH_EXTEND_MORTAL__SV_C(sv);
8099 =for apidoc sv_newmortal
8101 Creates a new null SV which is mortal. The reference count of the SV is
8102 set to 1. It will be destroyed "soon", either by an explicit call to
8103 FREETMPS, or by an implicit call at places such as statement boundaries.
8104 See also C<sv_mortalcopy> and C<sv_2mortal>.
8110 Perl_sv_newmortal(pTHX)
8116 SvFLAGS(sv) = SVs_TEMP;
8117 PUSH_EXTEND_MORTAL__SV_C(sv);
8123 =for apidoc newSVpvn_flags
8125 Creates a new SV and copies a string into it. The reference count for the
8126 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
8127 string. You are responsible for ensuring that the source string is at least
8128 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
8129 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
8130 If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before
8131 returning. If C<SVf_UTF8> is set, C<s> is considered to be in UTF-8 and the
8132 C<SVf_UTF8> flag will be set on the new SV.
8133 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
8135 #define newSVpvn_utf8(s, len, u) \
8136 newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
8142 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
8147 /* All the flags we don't support must be zero.
8148 And we're new code so I'm going to assert this from the start. */
8149 assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
8151 sv_setpvn(sv,s,len);
8153 /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal()
8154 * and do what it does outselves here.
8155 * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags
8156 * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which
8157 * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we
8158 * eleminate quite a few steps than it looks - Yves (explaining patch by gfx)
8161 SvFLAGS(sv) |= flags;
8163 if(flags & SVs_TEMP){
8164 PUSH_EXTEND_MORTAL__SV_C(sv);
8171 =for apidoc sv_2mortal
8173 Marks an existing SV as mortal. The SV will be destroyed "soon", either
8174 by an explicit call to FREETMPS, or by an implicit call at places such as
8175 statement boundaries. SvTEMP() is turned on which means that the SV's
8176 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
8177 and C<sv_mortalcopy>.
8183 Perl_sv_2mortal(pTHX_ register SV *const sv)
8188 if (SvREADONLY(sv) && SvIMMORTAL(sv))
8190 PUSH_EXTEND_MORTAL__SV_C(sv);
8198 Creates a new SV and copies a string into it. The reference count for the
8199 SV is set to 1. If C<len> is zero, Perl will compute the length using
8200 strlen(). For efficiency, consider using C<newSVpvn> instead.
8206 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
8212 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
8217 =for apidoc newSVpvn
8219 Creates a new SV and copies a string into it. The reference count for the
8220 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
8221 string. You are responsible for ensuring that the source string is at least
8222 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
8228 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
8234 sv_setpvn(sv,s,len);
8239 =for apidoc newSVhek
8241 Creates a new SV from the hash key structure. It will generate scalars that
8242 point to the shared string table where possible. Returns a new (undefined)
8243 SV if the hek is NULL.
8249 Perl_newSVhek(pTHX_ const HEK *const hek)
8259 if (HEK_LEN(hek) == HEf_SVKEY) {
8260 return newSVsv(*(SV**)HEK_KEY(hek));
8262 const int flags = HEK_FLAGS(hek);
8263 if (flags & HVhek_WASUTF8) {
8265 Andreas would like keys he put in as utf8 to come back as utf8
8267 STRLEN utf8_len = HEK_LEN(hek);
8268 SV * const sv = newSV_type(SVt_PV);
8269 char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
8270 /* bytes_to_utf8() allocates a new string, which we can repurpose: */
8271 sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
8274 } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
8275 /* We don't have a pointer to the hv, so we have to replicate the
8276 flag into every HEK. This hv is using custom a hasing
8277 algorithm. Hence we can't return a shared string scalar, as
8278 that would contain the (wrong) hash value, and might get passed
8279 into an hv routine with a regular hash.
8280 Similarly, a hash that isn't using shared hash keys has to have
8281 the flag in every key so that we know not to try to call
8282 share_hek_kek on it. */
8284 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
8289 /* This will be overwhelminly the most common case. */
8291 /* Inline most of newSVpvn_share(), because share_hek_hek() is far
8292 more efficient than sharepvn(). */
8296 sv_upgrade(sv, SVt_PV);
8297 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
8298 SvCUR_set(sv, HEK_LEN(hek));
8311 =for apidoc newSVpvn_share
8313 Creates a new SV with its SvPVX_const pointing to a shared string in the string
8314 table. If the string does not already exist in the table, it is created
8315 first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
8316 value is used; otherwise the hash is computed. The string's hash can be later
8317 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
8318 that as the string table is used for shared hash keys these strings will have
8319 SvPVX_const == HeKEY and hash lookup will avoid string compare.
8325 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
8329 bool is_utf8 = FALSE;
8330 const char *const orig_src = src;
8333 STRLEN tmplen = -len;
8335 /* See the note in hv.c:hv_fetch() --jhi */
8336 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
8340 PERL_HASH(hash, src, len);
8342 /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
8343 changes here, update it there too. */
8344 sv_upgrade(sv, SVt_PV);
8345 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
8353 if (src != orig_src)
8359 =for apidoc newSVpv_share
8361 Like C<newSVpvn_share>, but takes a nul-terminated string instead of a
8368 Perl_newSVpv_share(pTHX_ const char *src, U32 hash)
8370 return newSVpvn_share(src, strlen(src), hash);
8373 #if defined(PERL_IMPLICIT_CONTEXT)
8375 /* pTHX_ magic can't cope with varargs, so this is a no-context
8376 * version of the main function, (which may itself be aliased to us).
8377 * Don't access this version directly.
8381 Perl_newSVpvf_nocontext(const char *const pat, ...)
8387 PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
8389 va_start(args, pat);
8390 sv = vnewSVpvf(pat, &args);
8397 =for apidoc newSVpvf
8399 Creates a new SV and initializes it with the string formatted like
8406 Perl_newSVpvf(pTHX_ const char *const pat, ...)
8411 PERL_ARGS_ASSERT_NEWSVPVF;
8413 va_start(args, pat);
8414 sv = vnewSVpvf(pat, &args);
8419 /* backend for newSVpvf() and newSVpvf_nocontext() */
8422 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
8427 PERL_ARGS_ASSERT_VNEWSVPVF;
8430 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8437 Creates a new SV and copies a floating point value into it.
8438 The reference count for the SV is set to 1.
8444 Perl_newSVnv(pTHX_ const NV n)
8457 Creates a new SV and copies an integer into it. The reference count for the
8464 Perl_newSViv(pTHX_ const IV i)
8477 Creates a new SV and copies an unsigned integer into it.
8478 The reference count for the SV is set to 1.
8484 Perl_newSVuv(pTHX_ const UV u)
8495 =for apidoc newSV_type
8497 Creates a new SV, of the type specified. The reference count for the new SV
8504 Perl_newSV_type(pTHX_ const svtype type)
8509 sv_upgrade(sv, type);
8514 =for apidoc newRV_noinc
8516 Creates an RV wrapper for an SV. The reference count for the original
8517 SV is B<not> incremented.
8523 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
8526 register SV *sv = newSV_type(SVt_IV);
8528 PERL_ARGS_ASSERT_NEWRV_NOINC;
8531 SvRV_set(sv, tmpRef);
8536 /* newRV_inc is the official function name to use now.
8537 * newRV_inc is in fact #defined to newRV in sv.h
8541 Perl_newRV(pTHX_ SV *const sv)
8545 PERL_ARGS_ASSERT_NEWRV;
8547 return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
8553 Creates a new SV which is an exact duplicate of the original SV.
8560 Perl_newSVsv(pTHX_ register SV *const old)
8567 if (SvTYPE(old) == SVTYPEMASK) {
8568 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
8572 /* SV_GMAGIC is the default for sv_setv()
8573 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
8574 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
8575 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
8580 =for apidoc sv_reset
8582 Underlying implementation for the C<reset> Perl function.
8583 Note that the perl-level function is vaguely deprecated.
8589 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
8592 char todo[PERL_UCHAR_MAX+1];
8594 PERL_ARGS_ASSERT_SV_RESET;
8599 if (!*s) { /* reset ?? searches */
8600 MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
8602 const U32 count = mg->mg_len / sizeof(PMOP**);
8603 PMOP **pmp = (PMOP**) mg->mg_ptr;
8604 PMOP *const *const end = pmp + count;
8608 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
8610 (*pmp)->op_pmflags &= ~PMf_USED;
8618 /* reset variables */
8620 if (!HvARRAY(stash))
8623 Zero(todo, 256, char);
8626 I32 i = (unsigned char)*s;
8630 max = (unsigned char)*s++;
8631 for ( ; i <= max; i++) {
8634 for (i = 0; i <= (I32) HvMAX(stash); i++) {
8636 for (entry = HvARRAY(stash)[i];
8638 entry = HeNEXT(entry))
8643 if (!todo[(U8)*HeKEY(entry)])
8645 gv = MUTABLE_GV(HeVAL(entry));
8648 if (SvTHINKFIRST(sv)) {
8649 if (!SvREADONLY(sv) && SvROK(sv))
8651 /* XXX Is this continue a bug? Why should THINKFIRST
8652 exempt us from resetting arrays and hashes? */
8656 if (SvTYPE(sv) >= SVt_PV) {
8658 if (SvPVX_const(sv) != NULL)
8666 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8668 Perl_die(aTHX_ "Can't reset %%ENV on this system");
8671 # if defined(USE_ENVIRON_ARRAY)
8674 # endif /* USE_ENVIRON_ARRAY */
8685 Using various gambits, try to get an IO from an SV: the IO slot if its a
8686 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8687 named after the PV if we're a string.
8693 Perl_sv_2io(pTHX_ SV *const sv)
8698 PERL_ARGS_ASSERT_SV_2IO;
8700 switch (SvTYPE(sv)) {
8702 io = MUTABLE_IO(sv);
8706 if (isGV_with_GP(sv)) {
8707 gv = MUTABLE_GV(sv);
8710 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8716 Perl_croak(aTHX_ PL_no_usym, "filehandle");
8718 return sv_2io(SvRV(sv));
8719 gv = gv_fetchsv(sv, 0, SVt_PVIO);
8725 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
8734 Using various gambits, try to get a CV from an SV; in addition, try if
8735 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8736 The flags in C<lref> are passed to gv_fetchsv.
8742 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8748 PERL_ARGS_ASSERT_SV_2CV;
8755 switch (SvTYPE(sv)) {
8759 return MUTABLE_CV(sv);
8766 if (isGV_with_GP(sv)) {
8767 gv = MUTABLE_GV(sv);
8777 sv = amagic_deref_call(sv, to_cv_amg);
8778 /* At this point I'd like to do SPAGAIN, but really I need to
8779 force it upon my callers. Hmmm. This is a mess... */
8782 if (SvTYPE(sv) == SVt_PVCV) {
8783 cv = MUTABLE_CV(sv);
8788 else if(isGV_with_GP(sv))
8789 gv = MUTABLE_GV(sv);
8791 Perl_croak(aTHX_ "Not a subroutine reference");
8793 else if (isGV_with_GP(sv)) {
8795 gv = MUTABLE_GV(sv);
8798 gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
8804 /* Some flags to gv_fetchsv mean don't really create the GV */
8805 if (!isGV_with_GP(gv)) {
8811 if (lref && !GvCVu(gv)) {
8815 gv_efullname3(tmpsv, gv, NULL);
8816 /* XXX this is probably not what they think they're getting.
8817 * It has the same effect as "sub name;", i.e. just a forward
8819 newSUB(start_subparse(FALSE, 0),
8820 newSVOP(OP_CONST, 0, tmpsv),
8824 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8825 SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8834 Returns true if the SV has a true value by Perl's rules.
8835 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8836 instead use an in-line version.
8842 Perl_sv_true(pTHX_ register SV *const sv)
8847 register const XPV* const tXpv = (XPV*)SvANY(sv);
8849 (tXpv->xpv_cur > 1 ||
8850 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
8857 return SvIVX(sv) != 0;
8860 return SvNVX(sv) != 0.0;
8862 return sv_2bool(sv);
8868 =for apidoc sv_pvn_force
8870 Get a sensible string out of the SV somehow.
8871 A private implementation of the C<SvPV_force> macro for compilers which
8872 can't cope with complex macro expressions. Always use the macro instead.
8874 =for apidoc sv_pvn_force_flags
8876 Get a sensible string out of the SV somehow.
8877 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8878 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8879 implemented in terms of this function.
8880 You normally want to use the various wrapper macros instead: see
8881 C<SvPV_force> and C<SvPV_force_nomg>
8887 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
8891 PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
8893 if (SvTHINKFIRST(sv) && !SvROK(sv))
8894 sv_force_normal_flags(sv, 0);
8904 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8905 const char * const ref = sv_reftype(sv,0);
8907 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8908 ref, OP_DESC(PL_op));
8910 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
8912 if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
8913 || isGV_with_GP(sv))
8914 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8916 s = sv_2pv_flags(sv, &len, flags);
8920 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
8923 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8924 SvGROW(sv, len + 1);
8925 Move(s,SvPVX(sv),len,char);
8927 SvPVX(sv)[len] = '\0';
8930 SvPOK_on(sv); /* validate pointer */
8932 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8933 PTR2UV(sv),SvPVX_const(sv)));
8936 return SvPVX_mutable(sv);
8940 =for apidoc sv_pvbyten_force
8942 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
8948 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
8950 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
8952 sv_pvn_force(sv,lp);
8953 sv_utf8_downgrade(sv,0);
8959 =for apidoc sv_pvutf8n_force
8961 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
8967 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
8969 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
8971 sv_pvn_force(sv,lp);
8972 sv_utf8_upgrade(sv);
8978 =for apidoc sv_reftype
8980 Returns a string describing what the SV is a reference to.
8986 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
8988 PERL_ARGS_ASSERT_SV_REFTYPE;
8990 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8991 inside return suggests a const propagation bug in g++. */
8992 if (ob && SvOBJECT(sv)) {
8993 char * const name = HvNAME_get(SvSTASH(sv));
8994 return name ? name : (char *) "__ANON__";
8997 switch (SvTYPE(sv)) {
9012 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
9013 /* tied lvalues should appear to be
9014 * scalars for backwards compatitbility */
9015 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
9016 ? "SCALAR" : "LVALUE");
9017 case SVt_PVAV: return "ARRAY";
9018 case SVt_PVHV: return "HASH";
9019 case SVt_PVCV: return "CODE";
9020 case SVt_PVGV: return (char *) (isGV_with_GP(sv)
9021 ? "GLOB" : "SCALAR");
9022 case SVt_PVFM: return "FORMAT";
9023 case SVt_PVIO: return "IO";
9024 case SVt_BIND: return "BIND";
9025 case SVt_REGEXP: return "REGEXP";
9026 default: return "UNKNOWN";
9032 =for apidoc sv_isobject
9034 Returns a boolean indicating whether the SV is an RV pointing to a blessed
9035 object. If the SV is not an RV, or if the object is not blessed, then this
9042 Perl_sv_isobject(pTHX_ SV *sv)
9058 Returns a boolean indicating whether the SV is blessed into the specified
9059 class. This does not check for subtypes; use C<sv_derived_from> to verify
9060 an inheritance relationship.
9066 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
9070 PERL_ARGS_ASSERT_SV_ISA;
9080 hvname = HvNAME_get(SvSTASH(sv));
9084 return strEQ(hvname, name);
9090 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
9091 it will be upgraded to one. If C<classname> is non-null then the new SV will
9092 be blessed in the specified package. The new SV is returned and its
9093 reference count is 1.
9099 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
9104 PERL_ARGS_ASSERT_NEWSVRV;
9108 SV_CHECK_THINKFIRST_COW_DROP(rv);
9109 (void)SvAMAGIC_off(rv);
9111 if (SvTYPE(rv) >= SVt_PVMG) {
9112 const U32 refcnt = SvREFCNT(rv);
9116 SvREFCNT(rv) = refcnt;
9118 sv_upgrade(rv, SVt_IV);
9119 } else if (SvROK(rv)) {
9120 SvREFCNT_dec(SvRV(rv));
9122 prepare_SV_for_RV(rv);
9130 HV* const stash = gv_stashpv(classname, GV_ADD);
9131 (void)sv_bless(rv, stash);
9137 =for apidoc sv_setref_pv
9139 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
9140 argument will be upgraded to an RV. That RV will be modified to point to
9141 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
9142 into the SV. The C<classname> argument indicates the package for the
9143 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9144 will have a reference count of 1, and the RV will be returned.
9146 Do not use with other Perl types such as HV, AV, SV, CV, because those
9147 objects will become corrupted by the pointer copy process.
9149 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
9155 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
9159 PERL_ARGS_ASSERT_SV_SETREF_PV;
9162 sv_setsv(rv, &PL_sv_undef);
9166 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
9171 =for apidoc sv_setref_iv
9173 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
9174 argument will be upgraded to an RV. That RV will be modified to point to
9175 the new SV. The C<classname> argument indicates the package for the
9176 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9177 will have a reference count of 1, and the RV will be returned.
9183 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
9185 PERL_ARGS_ASSERT_SV_SETREF_IV;
9187 sv_setiv(newSVrv(rv,classname), iv);
9192 =for apidoc sv_setref_uv
9194 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
9195 argument will be upgraded to an RV. That RV will be modified to point to
9196 the new SV. The C<classname> argument indicates the package for the
9197 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9198 will have a reference count of 1, and the RV will be returned.
9204 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
9206 PERL_ARGS_ASSERT_SV_SETREF_UV;
9208 sv_setuv(newSVrv(rv,classname), uv);
9213 =for apidoc sv_setref_nv
9215 Copies a double into a new SV, optionally blessing the SV. The C<rv>
9216 argument will be upgraded to an RV. That RV will be modified to point to
9217 the new SV. The C<classname> argument indicates the package for the
9218 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9219 will have a reference count of 1, and the RV will be returned.
9225 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
9227 PERL_ARGS_ASSERT_SV_SETREF_NV;
9229 sv_setnv(newSVrv(rv,classname), nv);
9234 =for apidoc sv_setref_pvn
9236 Copies a string into a new SV, optionally blessing the SV. The length of the
9237 string must be specified with C<n>. The C<rv> argument will be upgraded to
9238 an RV. That RV will be modified to point to the new SV. The C<classname>
9239 argument indicates the package for the blessing. Set C<classname> to
9240 C<NULL> to avoid the blessing. The new SV will have a reference count
9241 of 1, and the RV will be returned.
9243 Note that C<sv_setref_pv> copies the pointer while this copies the string.
9249 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
9250 const char *const pv, const STRLEN n)
9252 PERL_ARGS_ASSERT_SV_SETREF_PVN;
9254 sv_setpvn(newSVrv(rv,classname), pv, n);
9259 =for apidoc sv_bless
9261 Blesses an SV into a specified package. The SV must be an RV. The package
9262 must be designated by its stash (see C<gv_stashpv()>). The reference count
9263 of the SV is unaffected.
9269 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
9274 PERL_ARGS_ASSERT_SV_BLESS;
9277 Perl_croak(aTHX_ "Can't bless non-reference value");
9279 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
9280 if (SvIsCOW(tmpRef))
9281 sv_force_normal_flags(tmpRef, 0);
9282 if (SvREADONLY(tmpRef))
9283 Perl_croak_no_modify(aTHX);
9284 if (SvOBJECT(tmpRef)) {
9285 if (SvTYPE(tmpRef) != SVt_PVIO)
9287 SvREFCNT_dec(SvSTASH(tmpRef));
9290 SvOBJECT_on(tmpRef);
9291 if (SvTYPE(tmpRef) != SVt_PVIO)
9293 SvUPGRADE(tmpRef, SVt_PVMG);
9294 SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
9299 (void)SvAMAGIC_off(sv);
9301 if(SvSMAGICAL(tmpRef))
9302 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
9310 /* Downgrades a PVGV to a PVMG. If it’s actually a PVLV, we leave the type
9311 * as it is after unglobbing it.
9315 S_sv_unglob(pTHX_ SV *const sv)
9320 SV * const temp = sv_newmortal();
9322 PERL_ARGS_ASSERT_SV_UNGLOB;
9324 assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
9326 gv_efullname3(temp, MUTABLE_GV(sv), "*");
9329 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
9330 && HvNAME_get(stash))
9331 mro_method_changed_in(stash);
9332 gp_free(MUTABLE_GV(sv));
9335 sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
9339 if (GvNAME_HEK(sv)) {
9340 unshare_hek(GvNAME_HEK(sv));
9342 isGV_with_GP_off(sv);
9344 if(SvTYPE(sv) == SVt_PVGV) {
9345 /* need to keep SvANY(sv) in the right arena */
9346 xpvmg = new_XPVMG();
9347 StructCopy(SvANY(sv), xpvmg, XPVMG);
9348 del_XPVGV(SvANY(sv));
9351 SvFLAGS(sv) &= ~SVTYPEMASK;
9352 SvFLAGS(sv) |= SVt_PVMG;
9355 /* Intentionally not calling any local SET magic, as this isn't so much a
9356 set operation as merely an internal storage change. */
9357 sv_setsv_flags(sv, temp, 0);
9361 =for apidoc sv_unref_flags
9363 Unsets the RV status of the SV, and decrements the reference count of
9364 whatever was being referenced by the RV. This can almost be thought of
9365 as a reversal of C<newSVrv>. The C<cflags> argument can contain
9366 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
9367 (otherwise the decrementing is conditional on the reference count being
9368 different from one or the reference being a readonly SV).
9375 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
9377 SV* const target = SvRV(ref);
9379 PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
9381 if (SvWEAKREF(ref)) {
9382 sv_del_backref(target, ref);
9384 SvRV_set(ref, NULL);
9387 SvRV_set(ref, NULL);
9389 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
9390 assigned to as BEGIN {$a = \"Foo"} will fail. */
9391 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
9392 SvREFCNT_dec(target);
9393 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
9394 sv_2mortal(target); /* Schedule for freeing later */
9398 =for apidoc sv_untaint
9400 Untaint an SV. Use C<SvTAINTED_off> instead.
9405 Perl_sv_untaint(pTHX_ SV *const sv)
9407 PERL_ARGS_ASSERT_SV_UNTAINT;
9409 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9410 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9417 =for apidoc sv_tainted
9419 Test an SV for taintedness. Use C<SvTAINTED> instead.
9424 Perl_sv_tainted(pTHX_ SV *const sv)
9426 PERL_ARGS_ASSERT_SV_TAINTED;
9428 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9429 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9430 if (mg && (mg->mg_len & 1) )
9437 =for apidoc sv_setpviv
9439 Copies an integer into the given SV, also updating its string value.
9440 Does not handle 'set' magic. See C<sv_setpviv_mg>.
9446 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
9448 char buf[TYPE_CHARS(UV)];
9450 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
9452 PERL_ARGS_ASSERT_SV_SETPVIV;
9454 sv_setpvn(sv, ptr, ebuf - ptr);
9458 =for apidoc sv_setpviv_mg
9460 Like C<sv_setpviv>, but also handles 'set' magic.
9466 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
9468 PERL_ARGS_ASSERT_SV_SETPVIV_MG;
9474 #if defined(PERL_IMPLICIT_CONTEXT)
9476 /* pTHX_ magic can't cope with varargs, so this is a no-context
9477 * version of the main function, (which may itself be aliased to us).
9478 * Don't access this version directly.
9482 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
9487 PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
9489 va_start(args, pat);
9490 sv_vsetpvf(sv, pat, &args);
9494 /* pTHX_ magic can't cope with varargs, so this is a no-context
9495 * version of the main function, (which may itself be aliased to us).
9496 * Don't access this version directly.
9500 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9505 PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
9507 va_start(args, pat);
9508 sv_vsetpvf_mg(sv, pat, &args);
9514 =for apidoc sv_setpvf
9516 Works like C<sv_catpvf> but copies the text into the SV instead of
9517 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
9523 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
9527 PERL_ARGS_ASSERT_SV_SETPVF;
9529 va_start(args, pat);
9530 sv_vsetpvf(sv, pat, &args);
9535 =for apidoc sv_vsetpvf
9537 Works like C<sv_vcatpvf> but copies the text into the SV instead of
9538 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
9540 Usually used via its frontend C<sv_setpvf>.
9546 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9548 PERL_ARGS_ASSERT_SV_VSETPVF;
9550 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9554 =for apidoc sv_setpvf_mg
9556 Like C<sv_setpvf>, but also handles 'set' magic.
9562 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9566 PERL_ARGS_ASSERT_SV_SETPVF_MG;
9568 va_start(args, pat);
9569 sv_vsetpvf_mg(sv, pat, &args);
9574 =for apidoc sv_vsetpvf_mg
9576 Like C<sv_vsetpvf>, but also handles 'set' magic.
9578 Usually used via its frontend C<sv_setpvf_mg>.
9584 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9586 PERL_ARGS_ASSERT_SV_VSETPVF_MG;
9588 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9592 #if defined(PERL_IMPLICIT_CONTEXT)
9594 /* pTHX_ magic can't cope with varargs, so this is a no-context
9595 * version of the main function, (which may itself be aliased to us).
9596 * Don't access this version directly.
9600 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
9605 PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
9607 va_start(args, pat);
9608 sv_vcatpvf(sv, pat, &args);
9612 /* pTHX_ magic can't cope with varargs, so this is a no-context
9613 * version of the main function, (which may itself be aliased to us).
9614 * Don't access this version directly.
9618 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9623 PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9625 va_start(args, pat);
9626 sv_vcatpvf_mg(sv, pat, &args);
9632 =for apidoc sv_catpvf
9634 Processes its arguments like C<sprintf> and appends the formatted
9635 output to an SV. If the appended data contains "wide" characters
9636 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9637 and characters >255 formatted with %c), the original SV might get
9638 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
9639 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9640 valid UTF-8; if the original SV was bytes, the pattern should be too.
9645 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9649 PERL_ARGS_ASSERT_SV_CATPVF;
9651 va_start(args, pat);
9652 sv_vcatpvf(sv, pat, &args);
9657 =for apidoc sv_vcatpvf
9659 Processes its arguments like C<vsprintf> and appends the formatted output
9660 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
9662 Usually used via its frontend C<sv_catpvf>.
9668 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9670 PERL_ARGS_ASSERT_SV_VCATPVF;
9672 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9676 =for apidoc sv_catpvf_mg
9678 Like C<sv_catpvf>, but also handles 'set' magic.
9684 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9688 PERL_ARGS_ASSERT_SV_CATPVF_MG;
9690 va_start(args, pat);
9691 sv_vcatpvf_mg(sv, pat, &args);
9696 =for apidoc sv_vcatpvf_mg
9698 Like C<sv_vcatpvf>, but also handles 'set' magic.
9700 Usually used via its frontend C<sv_catpvf_mg>.
9706 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9708 PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9710 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9715 =for apidoc sv_vsetpvfn
9717 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9720 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9726 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9727 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9729 PERL_ARGS_ASSERT_SV_VSETPVFN;
9732 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9737 * Warn of missing argument to sprintf, and then return a defined value
9738 * to avoid inappropriate "use of uninit" warnings [perl #71000].
9740 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
9742 S_vcatpvfn_missing_argument(pTHX) {
9743 if (ckWARN(WARN_MISSING)) {
9744 Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
9745 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
9752 S_expect_number(pTHX_ char **const pattern)
9757 PERL_ARGS_ASSERT_EXPECT_NUMBER;
9759 switch (**pattern) {
9760 case '1': case '2': case '3':
9761 case '4': case '5': case '6':
9762 case '7': case '8': case '9':
9763 var = *(*pattern)++ - '0';
9764 while (isDIGIT(**pattern)) {
9765 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
9767 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
9775 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
9777 const int neg = nv < 0;
9780 PERL_ARGS_ASSERT_F0CONVERT;
9788 if (uv & 1 && uv == nv)
9789 uv--; /* Round to even */
9791 const unsigned dig = uv % 10;
9804 =for apidoc sv_vcatpvfn
9806 Processes its arguments like C<vsprintf> and appends the formatted output
9807 to an SV. Uses an array of SVs if the C style variable argument list is
9808 missing (NULL). When running with taint checks enabled, indicates via
9809 C<maybe_tainted> if results are untrustworthy (often due to the use of
9812 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9818 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
9819 vecstr = (U8*)SvPV_const(vecsv,veclen);\
9820 vec_utf8 = DO_UTF8(vecsv);
9822 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9825 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9826 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9834 static const char nullstr[] = "(null)";
9836 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
9837 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9839 /* Times 4: a decimal digit takes more than 3 binary digits.
9840 * NV_DIG: mantissa takes than many decimal digits.
9841 * Plus 32: Playing safe. */
9842 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9843 /* large enough for "%#.#f" --chip */
9844 /* what about long double NVs? --jhi */
9846 PERL_ARGS_ASSERT_SV_VCATPVFN;
9847 PERL_UNUSED_ARG(maybe_tainted);
9849 /* no matter what, this is a string now */
9850 (void)SvPV_force(sv, origlen);
9852 /* special-case "", "%s", and "%-p" (SVf - see below) */
9855 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9857 const char * const s = va_arg(*args, char*);
9858 sv_catpv(sv, s ? s : nullstr);
9860 else if (svix < svmax) {
9861 sv_catsv(sv, *svargs);
9864 S_vcatpvfn_missing_argument(aTHX);
9867 if (args && patlen == 3 && pat[0] == '%' &&
9868 pat[1] == '-' && pat[2] == 'p') {
9869 argsv = MUTABLE_SV(va_arg(*args, void*));
9870 sv_catsv(sv, argsv);
9874 #ifndef USE_LONG_DOUBLE
9875 /* special-case "%.<number>[gf]" */
9876 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9877 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9878 unsigned digits = 0;
9882 while (*pp >= '0' && *pp <= '9')
9883 digits = 10 * digits + (*pp++ - '0');
9884 if (pp - pat == (int)patlen - 1 && svix < svmax) {
9885 const NV nv = SvNV(*svargs);
9887 /* Add check for digits != 0 because it seems that some
9888 gconverts are buggy in this case, and we don't yet have
9889 a Configure test for this. */
9890 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9891 /* 0, point, slack */
9892 Gconvert(nv, (int)digits, 0, ebuf);
9894 if (*ebuf) /* May return an empty string for digits==0 */
9897 } else if (!digits) {
9900 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9901 sv_catpvn(sv, p, l);
9907 #endif /* !USE_LONG_DOUBLE */
9909 if (!args && svix < svmax && DO_UTF8(*svargs))
9912 patend = (char*)pat + patlen;
9913 for (p = (char*)pat; p < patend; p = q) {
9916 bool vectorize = FALSE;
9917 bool vectorarg = FALSE;
9918 bool vec_utf8 = FALSE;
9924 bool has_precis = FALSE;
9926 const I32 osvix = svix;
9927 bool is_utf8 = FALSE; /* is this item utf8? */
9928 #ifdef HAS_LDBL_SPRINTF_BUG
9929 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9930 with sfio - Allen <allens@cpan.org> */
9931 bool fix_ldbl_sprintf_bug = FALSE;
9935 U8 utf8buf[UTF8_MAXBYTES+1];
9936 STRLEN esignlen = 0;
9938 const char *eptr = NULL;
9939 const char *fmtstart;
9942 const U8 *vecstr = NULL;
9949 /* we need a long double target in case HAS_LONG_DOUBLE but
9952 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9960 const char *dotstr = ".";
9961 STRLEN dotstrlen = 1;
9962 I32 efix = 0; /* explicit format parameter index */
9963 I32 ewix = 0; /* explicit width index */
9964 I32 epix = 0; /* explicit precision index */
9965 I32 evix = 0; /* explicit vector index */
9966 bool asterisk = FALSE;
9968 /* echo everything up to the next format specification */
9969 for (q = p; q < patend && *q != '%'; ++q) ;
9971 if (has_utf8 && !pat_utf8)
9972 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9974 sv_catpvn(sv, p, q - p);
9983 We allow format specification elements in this order:
9984 \d+\$ explicit format parameter index
9986 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9987 0 flag (as above): repeated to allow "v02"
9988 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9989 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9991 [%bcdefginopsuxDFOUX] format (mandatory)
9996 As of perl5.9.3, printf format checking is on by default.
9997 Internally, perl uses %p formats to provide an escape to
9998 some extended formatting. This block deals with those
9999 extensions: if it does not match, (char*)q is reset and
10000 the normal format processing code is used.
10002 Currently defined extensions are:
10003 %p include pointer address (standard)
10004 %-p (SVf) include an SV (previously %_)
10005 %-<num>p include an SV with precision <num>
10006 %<num>p reserved for future extensions
10008 Robin Barker 2005-07-14
10010 %1p (VDf) removed. RMB 2007-10-19
10017 n = expect_number(&q);
10019 if (sv) { /* SVf */
10024 argsv = MUTABLE_SV(va_arg(*args, void*));
10025 eptr = SvPV_const(argsv, elen);
10026 if (DO_UTF8(argsv))
10031 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
10032 "internal %%<num>p might conflict with future printf extensions");
10038 if ( (width = expect_number(&q)) ) {
10053 if (plus == '+' && *q == ' ') /* '+' over ' ' */
10082 if ( (ewix = expect_number(&q)) )
10091 if ((vectorarg = asterisk)) {
10104 width = expect_number(&q);
10110 vecsv = va_arg(*args, SV*);
10112 vecsv = (evix > 0 && evix <= svmax)
10113 ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
10115 vecsv = svix < svmax
10116 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10118 dotstr = SvPV_const(vecsv, dotstrlen);
10119 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
10120 bad with tied or overloaded values that return UTF8. */
10121 if (DO_UTF8(vecsv))
10123 else if (has_utf8) {
10124 vecsv = sv_mortalcopy(vecsv);
10125 sv_utf8_upgrade(vecsv);
10126 dotstr = SvPV_const(vecsv, dotstrlen);
10133 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
10134 vecsv = svargs[efix ? efix-1 : svix++];
10135 vecstr = (U8*)SvPV_const(vecsv,veclen);
10136 vec_utf8 = DO_UTF8(vecsv);
10138 /* if this is a version object, we need to convert
10139 * back into v-string notation and then let the
10140 * vectorize happen normally
10142 if (sv_derived_from(vecsv, "version")) {
10143 char *version = savesvpv(vecsv);
10144 if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
10145 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
10146 "vector argument not supported with alpha versions");
10149 vecsv = sv_newmortal();
10150 scan_vstring(version, version + veclen, vecsv);
10151 vecstr = (U8*)SvPV_const(vecsv, veclen);
10152 vec_utf8 = DO_UTF8(vecsv);
10164 i = va_arg(*args, int);
10166 i = (ewix ? ewix <= svmax : svix < svmax) ?
10167 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10169 width = (i < 0) ? -i : i;
10179 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
10181 /* XXX: todo, support specified precision parameter */
10185 i = va_arg(*args, int);
10187 i = (ewix ? ewix <= svmax : svix < svmax)
10188 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10190 has_precis = !(i < 0);
10194 while (isDIGIT(*q))
10195 precis = precis * 10 + (*q++ - '0');
10204 case 'I': /* Ix, I32x, and I64x */
10206 if (q[1] == '6' && q[2] == '4') {
10212 if (q[1] == '3' && q[2] == '2') {
10222 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10233 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10234 if (*(q + 1) == 'l') { /* lld, llf */
10260 if (!vectorize && !args) {
10262 const I32 i = efix-1;
10263 argsv = (i >= 0 && i < svmax)
10264 ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
10266 argsv = (svix >= 0 && svix < svmax)
10267 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10271 switch (c = *q++) {
10278 uv = (args) ? va_arg(*args, int) : SvIV(argsv);
10280 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
10282 eptr = (char*)utf8buf;
10283 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
10297 eptr = va_arg(*args, char*);
10299 elen = strlen(eptr);
10301 eptr = (char *)nullstr;
10302 elen = sizeof nullstr - 1;
10306 eptr = SvPV_const(argsv, elen);
10307 if (DO_UTF8(argsv)) {
10308 STRLEN old_precis = precis;
10309 if (has_precis && precis < elen) {
10310 STRLEN ulen = sv_len_utf8(argsv);
10311 I32 p = precis > ulen ? ulen : precis;
10312 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
10315 if (width) { /* fudge width (can't fudge elen) */
10316 if (has_precis && precis < elen)
10317 width += precis - old_precis;
10319 width += elen - sv_len_utf8(argsv);
10326 if (has_precis && precis < elen)
10333 if (alt || vectorize)
10335 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
10356 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10365 esignbuf[esignlen++] = plus;
10369 case 'h': iv = (short)va_arg(*args, int); break;
10370 case 'l': iv = va_arg(*args, long); break;
10371 case 'V': iv = va_arg(*args, IV); break;
10372 default: iv = va_arg(*args, int); break;
10375 iv = va_arg(*args, Quad_t); break;
10382 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
10384 case 'h': iv = (short)tiv; break;
10385 case 'l': iv = (long)tiv; break;
10387 default: iv = tiv; break;
10390 iv = (Quad_t)tiv; break;
10396 if ( !vectorize ) /* we already set uv above */
10401 esignbuf[esignlen++] = plus;
10405 esignbuf[esignlen++] = '-';
10449 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10460 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
10461 case 'l': uv = va_arg(*args, unsigned long); break;
10462 case 'V': uv = va_arg(*args, UV); break;
10463 default: uv = va_arg(*args, unsigned); break;
10466 uv = va_arg(*args, Uquad_t); break;
10473 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
10475 case 'h': uv = (unsigned short)tuv; break;
10476 case 'l': uv = (unsigned long)tuv; break;
10478 default: uv = tuv; break;
10481 uv = (Uquad_t)tuv; break;
10490 char *ptr = ebuf + sizeof ebuf;
10491 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
10497 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
10501 } while (uv >>= 4);
10503 esignbuf[esignlen++] = '0';
10504 esignbuf[esignlen++] = c; /* 'x' or 'X' */
10510 *--ptr = '0' + dig;
10511 } while (uv >>= 3);
10512 if (alt && *ptr != '0')
10518 *--ptr = '0' + dig;
10519 } while (uv >>= 1);
10521 esignbuf[esignlen++] = '0';
10522 esignbuf[esignlen++] = c;
10525 default: /* it had better be ten or less */
10528 *--ptr = '0' + dig;
10529 } while (uv /= base);
10532 elen = (ebuf + sizeof ebuf) - ptr;
10536 zeros = precis - elen;
10537 else if (precis == 0 && elen == 1 && *eptr == '0'
10538 && !(base == 8 && alt)) /* "%#.0o" prints "0" */
10541 /* a precision nullifies the 0 flag. */
10548 /* FLOATING POINT */
10551 c = 'f'; /* maybe %F isn't supported here */
10553 case 'e': case 'E':
10555 case 'g': case 'G':
10559 /* This is evil, but floating point is even more evil */
10561 /* for SV-style calling, we can only get NV
10562 for C-style calling, we assume %f is double;
10563 for simplicity we allow any of %Lf, %llf, %qf for long double
10567 #if defined(USE_LONG_DOUBLE)
10571 /* [perl #20339] - we should accept and ignore %lf rather than die */
10575 #if defined(USE_LONG_DOUBLE)
10576 intsize = args ? 0 : 'q';
10580 #if defined(HAS_LONG_DOUBLE)
10589 /* now we need (long double) if intsize == 'q', else (double) */
10591 #if LONG_DOUBLESIZE > DOUBLESIZE
10593 va_arg(*args, long double) :
10594 va_arg(*args, double)
10596 va_arg(*args, double)
10601 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
10602 else. frexp() has some unspecified behaviour for those three */
10603 if (c != 'e' && c != 'E' && (nv * 0) == 0) {
10605 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
10606 will cast our (long double) to (double) */
10607 (void)Perl_frexp(nv, &i);
10608 if (i == PERL_INT_MIN)
10609 Perl_die(aTHX_ "panic: frexp");
10611 need = BIT_DIGITS(i);
10613 need += has_precis ? precis : 6; /* known default */
10618 #ifdef HAS_LDBL_SPRINTF_BUG
10619 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10620 with sfio - Allen <allens@cpan.org> */
10623 # define MY_DBL_MAX DBL_MAX
10624 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
10625 # if DOUBLESIZE >= 8
10626 # define MY_DBL_MAX 1.7976931348623157E+308L
10628 # define MY_DBL_MAX 3.40282347E+38L
10632 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10633 # define MY_DBL_MAX_BUG 1L
10635 # define MY_DBL_MAX_BUG MY_DBL_MAX
10639 # define MY_DBL_MIN DBL_MIN
10640 # else /* XXX guessing! -Allen */
10641 # if DOUBLESIZE >= 8
10642 # define MY_DBL_MIN 2.2250738585072014E-308L
10644 # define MY_DBL_MIN 1.17549435E-38L
10648 if ((intsize == 'q') && (c == 'f') &&
10649 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10650 (need < DBL_DIG)) {
10651 /* it's going to be short enough that
10652 * long double precision is not needed */
10654 if ((nv <= 0L) && (nv >= -0L))
10655 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10657 /* would use Perl_fp_class as a double-check but not
10658 * functional on IRIX - see perl.h comments */
10660 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10661 /* It's within the range that a double can represent */
10662 #if defined(DBL_MAX) && !defined(DBL_MIN)
10663 if ((nv >= ((long double)1/DBL_MAX)) ||
10664 (nv <= (-(long double)1/DBL_MAX)))
10666 fix_ldbl_sprintf_bug = TRUE;
10669 if (fix_ldbl_sprintf_bug == TRUE) {
10679 # undef MY_DBL_MAX_BUG
10682 #endif /* HAS_LDBL_SPRINTF_BUG */
10684 need += 20; /* fudge factor */
10685 if (PL_efloatsize < need) {
10686 Safefree(PL_efloatbuf);
10687 PL_efloatsize = need + 20; /* more fudge */
10688 Newx(PL_efloatbuf, PL_efloatsize, char);
10689 PL_efloatbuf[0] = '\0';
10692 if ( !(width || left || plus || alt) && fill != '0'
10693 && has_precis && intsize != 'q' ) { /* Shortcuts */
10694 /* See earlier comment about buggy Gconvert when digits,
10696 if ( c == 'g' && precis) {
10697 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10698 /* May return an empty string for digits==0 */
10699 if (*PL_efloatbuf) {
10700 elen = strlen(PL_efloatbuf);
10701 goto float_converted;
10703 } else if ( c == 'f' && !precis) {
10704 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10709 char *ptr = ebuf + sizeof ebuf;
10712 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10713 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10714 if (intsize == 'q') {
10715 /* Copy the one or more characters in a long double
10716 * format before the 'base' ([efgEFG]) character to
10717 * the format string. */
10718 static char const prifldbl[] = PERL_PRIfldbl;
10719 char const *p = prifldbl + sizeof(prifldbl) - 3;
10720 while (p >= prifldbl) { *--ptr = *p--; }
10725 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10730 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10742 /* No taint. Otherwise we are in the strange situation
10743 * where printf() taints but print($float) doesn't.
10745 #if defined(HAS_LONG_DOUBLE)
10746 elen = ((intsize == 'q')
10747 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
10748 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
10750 elen = my_sprintf(PL_efloatbuf, ptr, nv);
10754 eptr = PL_efloatbuf;
10762 i = SvCUR(sv) - origlen;
10765 case 'h': *(va_arg(*args, short*)) = i; break;
10766 default: *(va_arg(*args, int*)) = i; break;
10767 case 'l': *(va_arg(*args, long*)) = i; break;
10768 case 'V': *(va_arg(*args, IV*)) = i; break;
10771 *(va_arg(*args, Quad_t*)) = i; break;
10778 sv_setuv_mg(argsv, (UV)i);
10779 continue; /* not "break" */
10786 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
10787 && ckWARN(WARN_PRINTF))
10789 SV * const msg = sv_newmortal();
10790 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10791 (PL_op->op_type == OP_PRTF) ? "" : "s");
10792 if (fmtstart < patend) {
10793 const char * const fmtend = q < patend ? q : patend;
10795 sv_catpvs(msg, "\"%");
10796 for (f = fmtstart; f < fmtend; f++) {
10798 sv_catpvn(msg, f, 1);
10800 Perl_sv_catpvf(aTHX_ msg,
10801 "\\%03"UVof, (UV)*f & 0xFF);
10804 sv_catpvs(msg, "\"");
10806 sv_catpvs(msg, "end of string");
10808 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
10811 /* output mangled stuff ... */
10817 /* ... right here, because formatting flags should not apply */
10818 SvGROW(sv, SvCUR(sv) + elen + 1);
10820 Copy(eptr, p, elen, char);
10823 SvCUR_set(sv, p - SvPVX_const(sv));
10825 continue; /* not "break" */
10828 if (is_utf8 != has_utf8) {
10831 sv_utf8_upgrade(sv);
10834 const STRLEN old_elen = elen;
10835 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
10836 sv_utf8_upgrade(nsv);
10837 eptr = SvPVX_const(nsv);
10840 if (width) { /* fudge width (can't fudge elen) */
10841 width += elen - old_elen;
10847 have = esignlen + zeros + elen;
10849 Perl_croak_nocontext("%s", PL_memory_wrap);
10851 need = (have > width ? have : width);
10854 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
10855 Perl_croak_nocontext("%s", PL_memory_wrap);
10856 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10858 if (esignlen && fill == '0') {
10860 for (i = 0; i < (int)esignlen; i++)
10861 *p++ = esignbuf[i];
10863 if (gap && !left) {
10864 memset(p, fill, gap);
10867 if (esignlen && fill != '0') {
10869 for (i = 0; i < (int)esignlen; i++)
10870 *p++ = esignbuf[i];
10874 for (i = zeros; i; i--)
10878 Copy(eptr, p, elen, char);
10882 memset(p, ' ', gap);
10887 Copy(dotstr, p, dotstrlen, char);
10891 vectorize = FALSE; /* done iterating over vecstr */
10898 SvCUR_set(sv, p - SvPVX_const(sv));
10907 /* =========================================================================
10909 =head1 Cloning an interpreter
10911 All the macros and functions in this section are for the private use of
10912 the main function, perl_clone().
10914 The foo_dup() functions make an exact copy of an existing foo thingy.
10915 During the course of a cloning, a hash table is used to map old addresses
10916 to new addresses. The table is created and manipulated with the
10917 ptr_table_* functions.
10921 * =========================================================================*/
10924 #if defined(USE_ITHREADS)
10926 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
10927 #ifndef GpREFCNT_inc
10928 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10932 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
10933 that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
10934 If this changes, please unmerge ss_dup.
10935 Likewise, sv_dup_inc_multiple() relies on this fact. */
10936 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup_inc(s,t))
10937 #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
10938 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
10939 #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
10940 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
10941 #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
10942 #define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t))
10943 #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
10944 #define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t))
10945 #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
10946 #define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t))
10947 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
10948 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
10950 /* clone a parser */
10953 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
10957 PERL_ARGS_ASSERT_PARSER_DUP;
10962 /* look for it in the table first */
10963 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
10967 /* create anew and remember what it is */
10968 Newxz(parser, 1, yy_parser);
10969 ptr_table_store(PL_ptr_table, proto, parser);
10971 /* XXX these not yet duped */
10972 parser->old_parser = NULL;
10973 parser->stack = NULL;
10975 parser->stack_size = 0;
10976 /* XXX parser->stack->state = 0; */
10978 /* XXX eventually, just Copy() most of the parser struct ? */
10980 parser->lex_brackets = proto->lex_brackets;
10981 parser->lex_casemods = proto->lex_casemods;
10982 parser->lex_brackstack = savepvn(proto->lex_brackstack,
10983 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
10984 parser->lex_casestack = savepvn(proto->lex_casestack,
10985 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
10986 parser->lex_defer = proto->lex_defer;
10987 parser->lex_dojoin = proto->lex_dojoin;
10988 parser->lex_expect = proto->lex_expect;
10989 parser->lex_formbrack = proto->lex_formbrack;
10990 parser->lex_inpat = proto->lex_inpat;
10991 parser->lex_inwhat = proto->lex_inwhat;
10992 parser->lex_op = proto->lex_op;
10993 parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
10994 parser->lex_starts = proto->lex_starts;
10995 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
10996 parser->multi_close = proto->multi_close;
10997 parser->multi_open = proto->multi_open;
10998 parser->multi_start = proto->multi_start;
10999 parser->multi_end = proto->multi_end;
11000 parser->pending_ident = proto->pending_ident;
11001 parser->preambled = proto->preambled;
11002 parser->sublex_info = proto->sublex_info; /* XXX not quite right */
11003 parser->linestr = sv_dup_inc(proto->linestr, param);
11004 parser->expect = proto->expect;
11005 parser->copline = proto->copline;
11006 parser->last_lop_op = proto->last_lop_op;
11007 parser->lex_state = proto->lex_state;
11008 parser->rsfp = fp_dup(proto->rsfp, '<', param);
11009 /* rsfp_filters entries have fake IoDIRP() */
11010 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
11011 parser->in_my = proto->in_my;
11012 parser->in_my_stash = hv_dup(proto->in_my_stash, param);
11013 parser->error_count = proto->error_count;
11016 parser->linestr = sv_dup_inc(proto->linestr, param);
11019 char * const ols = SvPVX(proto->linestr);
11020 char * const ls = SvPVX(parser->linestr);
11022 parser->bufptr = ls + (proto->bufptr >= ols ?
11023 proto->bufptr - ols : 0);
11024 parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
11025 proto->oldbufptr - ols : 0);
11026 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
11027 proto->oldoldbufptr - ols : 0);
11028 parser->linestart = ls + (proto->linestart >= ols ?
11029 proto->linestart - ols : 0);
11030 parser->last_uni = ls + (proto->last_uni >= ols ?
11031 proto->last_uni - ols : 0);
11032 parser->last_lop = ls + (proto->last_lop >= ols ?
11033 proto->last_lop - ols : 0);
11035 parser->bufend = ls + SvCUR(parser->linestr);
11038 Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
11042 parser->endwhite = proto->endwhite;
11043 parser->faketokens = proto->faketokens;
11044 parser->lasttoke = proto->lasttoke;
11045 parser->nextwhite = proto->nextwhite;
11046 parser->realtokenstart = proto->realtokenstart;
11047 parser->skipwhite = proto->skipwhite;
11048 parser->thisclose = proto->thisclose;
11049 parser->thismad = proto->thismad;
11050 parser->thisopen = proto->thisopen;
11051 parser->thisstuff = proto->thisstuff;
11052 parser->thistoken = proto->thistoken;
11053 parser->thiswhite = proto->thiswhite;
11055 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
11056 parser->curforce = proto->curforce;
11058 Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
11059 Copy(proto->nexttype, parser->nexttype, 5, I32);
11060 parser->nexttoke = proto->nexttoke;
11063 /* XXX should clone saved_curcop here, but we aren't passed
11064 * proto_perl; so do it in perl_clone_using instead */
11070 /* duplicate a file handle */
11073 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
11077 PERL_ARGS_ASSERT_FP_DUP;
11078 PERL_UNUSED_ARG(type);
11081 return (PerlIO*)NULL;
11083 /* look for it in the table first */
11084 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
11088 /* create anew and remember what it is */
11089 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
11090 ptr_table_store(PL_ptr_table, fp, ret);
11094 /* duplicate a directory handle */
11097 Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
11103 register const Direntry_t *dirent;
11104 char smallbuf[256];
11110 PERL_UNUSED_CONTEXT;
11111 PERL_ARGS_ASSERT_DIRP_DUP;
11116 /* look for it in the table first */
11117 ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
11123 PERL_UNUSED_ARG(param);
11127 /* open the current directory (so we can switch back) */
11128 if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
11130 /* chdir to our dir handle and open the present working directory */
11131 if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
11132 PerlDir_close(pwd);
11133 return (DIR *)NULL;
11135 /* Now we should have two dir handles pointing to the same dir. */
11137 /* Be nice to the calling code and chdir back to where we were. */
11138 fchdir(my_dirfd(pwd)); /* If this fails, then what? */
11140 /* We have no need of the pwd handle any more. */
11141 PerlDir_close(pwd);
11144 # define d_namlen(d) (d)->d_namlen
11146 # define d_namlen(d) strlen((d)->d_name)
11148 /* Iterate once through dp, to get the file name at the current posi-
11149 tion. Then step back. */
11150 pos = PerlDir_tell(dp);
11151 if ((dirent = PerlDir_read(dp))) {
11152 len = d_namlen(dirent);
11153 if (len <= sizeof smallbuf) name = smallbuf;
11154 else Newx(name, len, char);
11155 Move(dirent->d_name, name, len, char);
11157 PerlDir_seek(dp, pos);
11159 /* Iterate through the new dir handle, till we find a file with the
11161 if (!dirent) /* just before the end */
11163 pos = PerlDir_tell(ret);
11164 if (PerlDir_read(ret)) continue; /* not there yet */
11165 PerlDir_seek(ret, pos); /* step back */
11169 const long pos0 = PerlDir_tell(ret);
11171 pos = PerlDir_tell(ret);
11172 if ((dirent = PerlDir_read(ret))) {
11173 if (len == d_namlen(dirent)
11174 && memEQ(name, dirent->d_name, len)) {
11176 PerlDir_seek(ret, pos); /* step back */
11179 /* else we are not there yet; keep iterating */
11181 else { /* This is not meant to happen. The best we can do is
11182 reset the iterator to the beginning. */
11183 PerlDir_seek(ret, pos0);
11190 if (name && name != smallbuf)
11195 ret = win32_dirp_dup(dp, param);
11198 /* pop it in the pointer table */
11200 ptr_table_store(PL_ptr_table, dp, ret);
11205 /* duplicate a typeglob */
11208 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
11212 PERL_ARGS_ASSERT_GP_DUP;
11216 /* look for it in the table first */
11217 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
11221 /* create anew and remember what it is */
11223 ptr_table_store(PL_ptr_table, gp, ret);
11226 /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
11227 on Newxz() to do this for us. */
11228 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
11229 ret->gp_io = io_dup_inc(gp->gp_io, param);
11230 ret->gp_form = cv_dup_inc(gp->gp_form, param);
11231 ret->gp_av = av_dup_inc(gp->gp_av, param);
11232 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
11233 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
11234 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
11235 ret->gp_cvgen = gp->gp_cvgen;
11236 ret->gp_line = gp->gp_line;
11237 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
11241 /* duplicate a chain of magic */
11244 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
11246 MAGIC *mgret = NULL;
11247 MAGIC **mgprev_p = &mgret;
11249 PERL_ARGS_ASSERT_MG_DUP;
11251 for (; mg; mg = mg->mg_moremagic) {
11254 if ((param->flags & CLONEf_JOIN_IN)
11255 && mg->mg_type == PERL_MAGIC_backref)
11256 /* when joining, we let the individual SVs add themselves to
11257 * backref as needed. */
11260 Newx(nmg, 1, MAGIC);
11262 mgprev_p = &(nmg->mg_moremagic);
11264 /* There was a comment "XXX copy dynamic vtable?" but as we don't have
11265 dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
11266 from the original commit adding Perl_mg_dup() - revision 4538.
11267 Similarly there is the annotation "XXX random ptr?" next to the
11268 assignment to nmg->mg_ptr. */
11271 /* FIXME for plugins
11272 if (nmg->mg_type == PERL_MAGIC_qr) {
11273 nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
11277 nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
11278 ? nmg->mg_type == PERL_MAGIC_backref
11279 /* The backref AV has its reference
11280 * count deliberately bumped by 1 */
11281 ? SvREFCNT_inc(av_dup_inc((const AV *)
11282 nmg->mg_obj, param))
11283 : sv_dup_inc(nmg->mg_obj, param)
11284 : sv_dup(nmg->mg_obj, param);
11286 if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
11287 if (nmg->mg_len > 0) {
11288 nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
11289 if (nmg->mg_type == PERL_MAGIC_overload_table &&
11290 AMT_AMAGIC((AMT*)nmg->mg_ptr))
11292 AMT * const namtp = (AMT*)nmg->mg_ptr;
11293 sv_dup_inc_multiple((SV**)(namtp->table),
11294 (SV**)(namtp->table), NofAMmeth, param);
11297 else if (nmg->mg_len == HEf_SVKEY)
11298 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
11300 if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
11301 nmg->mg_virtual->svt_dup(aTHX_ nmg, param);
11307 #endif /* USE_ITHREADS */
11309 struct ptr_tbl_arena {
11310 struct ptr_tbl_arena *next;
11311 struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */
11314 /* create a new pointer-mapping table */
11317 Perl_ptr_table_new(pTHX)
11320 PERL_UNUSED_CONTEXT;
11322 Newx(tbl, 1, PTR_TBL_t);
11323 tbl->tbl_max = 511;
11324 tbl->tbl_items = 0;
11325 tbl->tbl_arena = NULL;
11326 tbl->tbl_arena_next = NULL;
11327 tbl->tbl_arena_end = NULL;
11328 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
11332 #define PTR_TABLE_HASH(ptr) \
11333 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
11335 /* map an existing pointer using a table */
11337 STATIC PTR_TBL_ENT_t *
11338 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
11340 PTR_TBL_ENT_t *tblent;
11341 const UV hash = PTR_TABLE_HASH(sv);
11343 PERL_ARGS_ASSERT_PTR_TABLE_FIND;
11345 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
11346 for (; tblent; tblent = tblent->next) {
11347 if (tblent->oldval == sv)
11354 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
11356 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
11358 PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
11359 PERL_UNUSED_CONTEXT;
11361 return tblent ? tblent->newval : NULL;
11364 /* add a new entry to a pointer-mapping table */
11367 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
11369 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
11371 PERL_ARGS_ASSERT_PTR_TABLE_STORE;
11372 PERL_UNUSED_CONTEXT;
11375 tblent->newval = newsv;
11377 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
11379 if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
11380 struct ptr_tbl_arena *new_arena;
11382 Newx(new_arena, 1, struct ptr_tbl_arena);
11383 new_arena->next = tbl->tbl_arena;
11384 tbl->tbl_arena = new_arena;
11385 tbl->tbl_arena_next = new_arena->array;
11386 tbl->tbl_arena_end = new_arena->array
11387 + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
11390 tblent = tbl->tbl_arena_next++;
11392 tblent->oldval = oldsv;
11393 tblent->newval = newsv;
11394 tblent->next = tbl->tbl_ary[entry];
11395 tbl->tbl_ary[entry] = tblent;
11397 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
11398 ptr_table_split(tbl);
11402 /* double the hash bucket size of an existing ptr table */
11405 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
11407 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
11408 const UV oldsize = tbl->tbl_max + 1;
11409 UV newsize = oldsize * 2;
11412 PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
11413 PERL_UNUSED_CONTEXT;
11415 Renew(ary, newsize, PTR_TBL_ENT_t*);
11416 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
11417 tbl->tbl_max = --newsize;
11418 tbl->tbl_ary = ary;
11419 for (i=0; i < oldsize; i++, ary++) {
11420 PTR_TBL_ENT_t **entp = ary;
11421 PTR_TBL_ENT_t *ent = *ary;
11422 PTR_TBL_ENT_t **curentp;
11425 curentp = ary + oldsize;
11427 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
11429 ent->next = *curentp;
11439 /* remove all the entries from a ptr table */
11440 /* Deprecated - will be removed post 5.14 */
11443 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
11445 if (tbl && tbl->tbl_items) {
11446 struct ptr_tbl_arena *arena = tbl->tbl_arena;
11448 Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
11451 struct ptr_tbl_arena *next = arena->next;
11457 tbl->tbl_items = 0;
11458 tbl->tbl_arena = NULL;
11459 tbl->tbl_arena_next = NULL;
11460 tbl->tbl_arena_end = NULL;
11464 /* clear and free a ptr table */
11467 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
11469 struct ptr_tbl_arena *arena;
11475 arena = tbl->tbl_arena;
11478 struct ptr_tbl_arena *next = arena->next;
11484 Safefree(tbl->tbl_ary);
11488 #if defined(USE_ITHREADS)
11491 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
11493 PERL_ARGS_ASSERT_RVPV_DUP;
11496 if (SvWEAKREF(sstr)) {
11497 SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
11498 if (param->flags & CLONEf_JOIN_IN) {
11499 /* if joining, we add any back references individually rather
11500 * than copying the whole backref array */
11501 Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
11505 SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
11507 else if (SvPVX_const(sstr)) {
11508 /* Has something there */
11510 /* Normal PV - clone whole allocated space */
11511 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
11512 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
11513 /* Not that normal - actually sstr is copy on write.
11514 But we are a true, independant SV, so: */
11515 SvREADONLY_off(dstr);
11520 /* Special case - not normally malloced for some reason */
11521 if (isGV_with_GP(sstr)) {
11522 /* Don't need to do anything here. */
11524 else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
11525 /* A "shared" PV - clone it as "shared" PV */
11527 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
11531 /* Some other special case - random pointer */
11532 SvPV_set(dstr, (char *) SvPVX_const(sstr));
11537 /* Copy the NULL */
11538 SvPV_set(dstr, NULL);
11542 /* duplicate a list of SVs. source and dest may point to the same memory. */
11544 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
11545 SSize_t items, CLONE_PARAMS *const param)
11547 PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
11549 while (items-- > 0) {
11550 *dest++ = sv_dup_inc(*source++, param);
11556 /* duplicate an SV of any type (including AV, HV etc) */
11559 S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11564 PERL_ARGS_ASSERT_SV_DUP_COMMON;
11566 if (SvTYPE(sstr) == SVTYPEMASK) {
11567 #ifdef DEBUG_LEAKING_SCALARS_ABORT
11572 /* look for it in the table first */
11573 dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
11577 if(param->flags & CLONEf_JOIN_IN) {
11578 /** We are joining here so we don't want do clone
11579 something that is bad **/
11580 if (SvTYPE(sstr) == SVt_PVHV) {
11581 const HEK * const hvname = HvNAME_HEK(sstr);
11583 /** don't clone stashes if they already exist **/
11584 dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
11585 ptr_table_store(PL_ptr_table, sstr, dstr);
11591 /* create anew and remember what it is */
11594 #ifdef DEBUG_LEAKING_SCALARS
11595 dstr->sv_debug_optype = sstr->sv_debug_optype;
11596 dstr->sv_debug_line = sstr->sv_debug_line;
11597 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
11598 dstr->sv_debug_parent = (SV*)sstr;
11599 FREE_SV_DEBUG_FILE(dstr);
11600 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
11603 ptr_table_store(PL_ptr_table, sstr, dstr);
11606 SvFLAGS(dstr) = SvFLAGS(sstr);
11607 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
11608 SvREFCNT(dstr) = 0; /* must be before any other dups! */
11611 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
11612 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
11613 (void*)PL_watch_pvx, SvPVX_const(sstr));
11616 /* don't clone objects whose class has asked us not to */
11617 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
11622 switch (SvTYPE(sstr)) {
11624 SvANY(dstr) = NULL;
11627 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
11629 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11631 SvIV_set(dstr, SvIVX(sstr));
11635 SvANY(dstr) = new_XNV();
11636 SvNV_set(dstr, SvNVX(sstr));
11638 /* case SVt_BIND: */
11641 /* These are all the types that need complex bodies allocating. */
11643 const svtype sv_type = SvTYPE(sstr);
11644 const struct body_details *const sv_type_details
11645 = bodies_by_type + sv_type;
11649 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11664 assert(sv_type_details->body_size);
11665 if (sv_type_details->arena) {
11666 new_body_inline(new_body, sv_type);
11668 = (void*)((char*)new_body - sv_type_details->offset);
11670 new_body = new_NOARENA(sv_type_details);
11674 SvANY(dstr) = new_body;
11677 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
11678 ((char*)SvANY(dstr)) + sv_type_details->offset,
11679 sv_type_details->copy, char);
11681 Copy(((char*)SvANY(sstr)),
11682 ((char*)SvANY(dstr)),
11683 sv_type_details->body_size + sv_type_details->offset, char);
11686 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
11687 && !isGV_with_GP(dstr)
11688 && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
11689 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11691 /* The Copy above means that all the source (unduplicated) pointers
11692 are now in the destination. We can check the flags and the
11693 pointers in either, but it's possible that there's less cache
11694 missing by always going for the destination.
11695 FIXME - instrument and check that assumption */
11696 if (sv_type >= SVt_PVMG) {
11697 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
11698 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
11699 } else if (SvMAGIC(dstr))
11700 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
11702 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
11705 /* The cast silences a GCC warning about unhandled types. */
11706 switch ((int)sv_type) {
11716 /* FIXME for plugins */
11717 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
11720 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
11721 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
11722 LvTARG(dstr) = dstr;
11723 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
11724 LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
11726 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
11728 /* non-GP case already handled above */
11729 if(isGV_with_GP(sstr)) {
11730 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
11731 /* Don't call sv_add_backref here as it's going to be
11732 created as part of the magic cloning of the symbol
11733 table--unless this is during a join and the stash
11734 is not actually being cloned. */
11735 /* Danger Will Robinson - GvGP(dstr) isn't initialised
11736 at the point of this comment. */
11737 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
11738 if (param->flags & CLONEf_JOIN_IN)
11739 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
11740 GvGP(dstr) = gp_dup(GvGP(sstr), param);
11741 (void)GpREFCNT_inc(GvGP(dstr));
11745 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
11746 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
11747 /* I have no idea why fake dirp (rsfps)
11748 should be treated differently but otherwise
11749 we end up with leaks -- sky*/
11750 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
11751 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
11752 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
11754 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
11755 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
11756 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
11757 if (IoDIRP(dstr)) {
11758 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr), param);
11761 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
11763 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param);
11765 if (IoOFP(dstr) == IoIFP(sstr))
11766 IoOFP(dstr) = IoIFP(dstr);
11768 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
11769 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
11770 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
11771 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
11774 /* avoid cloning an empty array */
11775 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
11776 SV **dst_ary, **src_ary;
11777 SSize_t items = AvFILLp((const AV *)sstr) + 1;
11779 src_ary = AvARRAY((const AV *)sstr);
11780 Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
11781 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
11782 AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
11783 AvALLOC((const AV *)dstr) = dst_ary;
11784 if (AvREAL((const AV *)sstr)) {
11785 dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
11789 while (items-- > 0)
11790 *dst_ary++ = sv_dup(*src_ary++, param);
11792 items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
11793 while (items-- > 0) {
11794 *dst_ary++ = &PL_sv_undef;
11798 AvARRAY(MUTABLE_AV(dstr)) = NULL;
11799 AvALLOC((const AV *)dstr) = (SV**)NULL;
11800 AvMAX( (const AV *)dstr) = -1;
11801 AvFILLp((const AV *)dstr) = -1;
11805 if (HvARRAY((const HV *)sstr)) {
11807 const bool sharekeys = !!HvSHAREKEYS(sstr);
11808 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
11809 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
11811 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
11812 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
11814 HvARRAY(dstr) = (HE**)darray;
11815 while (i <= sxhv->xhv_max) {
11816 const HE * const source = HvARRAY(sstr)[i];
11817 HvARRAY(dstr)[i] = source
11818 ? he_dup(source, sharekeys, param) : 0;
11823 const struct xpvhv_aux * const saux = HvAUX(sstr);
11824 struct xpvhv_aux * const daux = HvAUX(dstr);
11825 /* This flag isn't copied. */
11826 /* SvOOK_on(hv) attacks the IV flags. */
11827 SvFLAGS(dstr) |= SVf_OOK;
11829 hvname = saux->xhv_name;
11830 if (saux->xhv_name_count) {
11831 HEK ** const sname = (HEK **)saux->xhv_name;
11833 = saux->xhv_name_count < 0
11834 ? -saux->xhv_name_count
11835 : saux->xhv_name_count;
11836 HEK **shekp = sname + count;
11838 Newxc(daux->xhv_name, count, HEK *, HEK);
11839 dhekp = (HEK **)daux->xhv_name + count;
11840 while (shekp-- > sname) {
11842 *dhekp = hek_dup(*shekp, param);
11845 else daux->xhv_name = hek_dup(hvname, param);
11846 daux->xhv_name_count = saux->xhv_name_count;
11848 daux->xhv_riter = saux->xhv_riter;
11849 daux->xhv_eiter = saux->xhv_eiter
11850 ? he_dup(saux->xhv_eiter,
11851 cBOOL(HvSHAREKEYS(sstr)), param) : 0;
11852 /* backref array needs refcnt=2; see sv_add_backref */
11853 daux->xhv_backreferences =
11854 (param->flags & CLONEf_JOIN_IN)
11855 /* when joining, we let the individual GVs and
11856 * CVs add themselves to backref as
11857 * needed. This avoids pulling in stuff
11858 * that isn't required, and simplifies the
11859 * case where stashes aren't cloned back
11860 * if they already exist in the parent
11863 : saux->xhv_backreferences
11864 ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
11865 ? MUTABLE_AV(SvREFCNT_inc(
11866 sv_dup_inc((const SV *)
11867 saux->xhv_backreferences, param)))
11868 : MUTABLE_AV(sv_dup((const SV *)
11869 saux->xhv_backreferences, param))
11872 daux->xhv_mro_meta = saux->xhv_mro_meta
11873 ? mro_meta_dup(saux->xhv_mro_meta, param)
11876 /* Record stashes for possible cloning in Perl_clone(). */
11878 av_push(param->stashes, dstr);
11882 HvARRAY(MUTABLE_HV(dstr)) = NULL;
11885 if (!(param->flags & CLONEf_COPY_STACKS)) {
11890 /* NOTE: not refcounted */
11891 SvANY(MUTABLE_CV(dstr))->xcv_stash =
11892 hv_dup(CvSTASH(dstr), param);
11893 if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
11894 Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
11896 if (!CvISXSUB(dstr))
11897 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
11899 if (CvCONST(dstr) && CvISXSUB(dstr)) {
11900 CvXSUBANY(dstr).any_ptr =
11901 sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
11903 /* don't dup if copying back - CvGV isn't refcounted, so the
11904 * duped GV may never be freed. A bit of a hack! DAPM */
11905 SvANY(MUTABLE_CV(dstr))->xcv_gv =
11907 ? gv_dup_inc(CvGV(sstr), param)
11908 : (param->flags & CLONEf_JOIN_IN)
11910 : gv_dup(CvGV(sstr), param);
11912 CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
11914 CvWEAKOUTSIDE(sstr)
11915 ? cv_dup( CvOUTSIDE(dstr), param)
11916 : cv_dup_inc(CvOUTSIDE(dstr), param);
11917 if (!CvISXSUB(dstr))
11918 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
11924 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11931 Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11933 PERL_ARGS_ASSERT_SV_DUP_INC;
11934 return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
11938 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11940 SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
11941 PERL_ARGS_ASSERT_SV_DUP;
11943 /* Track every SV that (at least initially) had a reference count of 0.
11944 We need to do this by holding an actual reference to it in this array.
11945 If we attempt to cheat, turn AvREAL_off(), and store only pointers
11946 (akin to the stashes hash, and the perl stack), we come unstuck if
11947 a weak reference (or other SV legitimately SvREFCNT() == 0 for this
11948 thread) is manipulated in a CLONE method, because CLONE runs before the
11949 unreferenced array is walked to find SVs still with SvREFCNT() == 0
11950 (and fix things up by giving each a reference via the temps stack).
11951 Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
11952 then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
11953 before the walk of unreferenced happens and a reference to that is SV
11954 added to the temps stack. At which point we have the same SV considered
11955 to be in use, and free to be re-used. Not good.
11957 if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
11958 assert(param->unreferenced);
11959 av_push(param->unreferenced, SvREFCNT_inc(dstr));
11965 /* duplicate a context */
11968 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11970 PERL_CONTEXT *ncxs;
11972 PERL_ARGS_ASSERT_CX_DUP;
11975 return (PERL_CONTEXT*)NULL;
11977 /* look for it in the table first */
11978 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11982 /* create anew and remember what it is */
11983 Newx(ncxs, max + 1, PERL_CONTEXT);
11984 ptr_table_store(PL_ptr_table, cxs, ncxs);
11985 Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
11988 PERL_CONTEXT * const ncx = &ncxs[ix];
11989 if (CxTYPE(ncx) == CXt_SUBST) {
11990 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11993 switch (CxTYPE(ncx)) {
11995 ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
11996 ? cv_dup_inc(ncx->blk_sub.cv, param)
11997 : cv_dup(ncx->blk_sub.cv,param));
11998 ncx->blk_sub.argarray = (CxHASARGS(ncx)
11999 ? av_dup_inc(ncx->blk_sub.argarray,
12002 ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
12004 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
12005 ncx->blk_sub.oldcomppad);
12008 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
12010 ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
12012 case CXt_LOOP_LAZYSV:
12013 ncx->blk_loop.state_u.lazysv.end
12014 = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
12015 /* We are taking advantage of av_dup_inc and sv_dup_inc
12016 actually being the same function, and order equivalance of
12018 We can assert the later [but only at run time :-(] */
12019 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
12020 (void *) &ncx->blk_loop.state_u.lazysv.cur);
12022 ncx->blk_loop.state_u.ary.ary
12023 = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
12024 case CXt_LOOP_LAZYIV:
12025 case CXt_LOOP_PLAIN:
12026 if (CxPADLOOP(ncx)) {
12027 ncx->blk_loop.itervar_u.oldcomppad
12028 = (PAD*)ptr_table_fetch(PL_ptr_table,
12029 ncx->blk_loop.itervar_u.oldcomppad);
12031 ncx->blk_loop.itervar_u.gv
12032 = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
12037 ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
12038 ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
12039 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
12052 /* duplicate a stack info structure */
12055 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
12059 PERL_ARGS_ASSERT_SI_DUP;
12062 return (PERL_SI*)NULL;
12064 /* look for it in the table first */
12065 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
12069 /* create anew and remember what it is */
12070 Newxz(nsi, 1, PERL_SI);
12071 ptr_table_store(PL_ptr_table, si, nsi);
12073 nsi->si_stack = av_dup_inc(si->si_stack, param);
12074 nsi->si_cxix = si->si_cxix;
12075 nsi->si_cxmax = si->si_cxmax;
12076 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
12077 nsi->si_type = si->si_type;
12078 nsi->si_prev = si_dup(si->si_prev, param);
12079 nsi->si_next = si_dup(si->si_next, param);
12080 nsi->si_markoff = si->si_markoff;
12085 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
12086 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
12087 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
12088 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
12089 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
12090 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
12091 #define POPUV(ss,ix) ((ss)[--(ix)].any_uv)
12092 #define TOPUV(ss,ix) ((ss)[ix].any_uv)
12093 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
12094 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
12095 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
12096 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
12097 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
12098 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
12099 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
12100 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
12103 #define pv_dup_inc(p) SAVEPV(p)
12104 #define pv_dup(p) SAVEPV(p)
12105 #define svp_dup_inc(p,pp) any_dup(p,pp)
12107 /* map any object to the new equivent - either something in the
12108 * ptr table, or something in the interpreter structure
12112 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
12116 PERL_ARGS_ASSERT_ANY_DUP;
12119 return (void*)NULL;
12121 /* look for it in the table first */
12122 ret = ptr_table_fetch(PL_ptr_table, v);
12126 /* see if it is part of the interpreter structure */
12127 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
12128 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
12136 /* duplicate the save stack */
12139 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
12142 ANY * const ss = proto_perl->Isavestack;
12143 const I32 max = proto_perl->Isavestack_max;
12144 I32 ix = proto_perl->Isavestack_ix;
12157 void (*dptr) (void*);
12158 void (*dxptr) (pTHX_ void*);
12160 PERL_ARGS_ASSERT_SS_DUP;
12162 Newxz(nss, max, ANY);
12165 const UV uv = POPUV(ss,ix);
12166 const U8 type = (U8)uv & SAVE_MASK;
12168 TOPUV(nss,ix) = uv;
12170 case SAVEt_CLEARSV:
12172 case SAVEt_HELEM: /* hash element */
12173 sv = (const SV *)POPPTR(ss,ix);
12174 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12176 case SAVEt_ITEM: /* normal string */
12177 case SAVEt_GVSV: /* scalar slot in GV */
12178 case SAVEt_SV: /* scalar reference */
12179 sv = (const SV *)POPPTR(ss,ix);
12180 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12183 case SAVEt_MORTALIZESV:
12184 sv = (const SV *)POPPTR(ss,ix);
12185 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12187 case SAVEt_SHARED_PVREF: /* char* in shared space */
12188 c = (char*)POPPTR(ss,ix);
12189 TOPPTR(nss,ix) = savesharedpv(c);
12190 ptr = POPPTR(ss,ix);
12191 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12193 case SAVEt_GENERIC_SVREF: /* generic sv */
12194 case SAVEt_SVREF: /* scalar reference */
12195 sv = (const SV *)POPPTR(ss,ix);
12196 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12197 ptr = POPPTR(ss,ix);
12198 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
12200 case SAVEt_HV: /* hash reference */
12201 case SAVEt_AV: /* array reference */
12202 sv = (const SV *) POPPTR(ss,ix);
12203 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12205 case SAVEt_COMPPAD:
12207 sv = (const SV *) POPPTR(ss,ix);
12208 TOPPTR(nss,ix) = sv_dup(sv, param);
12210 case SAVEt_INT: /* int reference */
12211 ptr = POPPTR(ss,ix);
12212 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12213 intval = (int)POPINT(ss,ix);
12214 TOPINT(nss,ix) = intval;
12216 case SAVEt_LONG: /* long reference */
12217 ptr = POPPTR(ss,ix);
12218 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12219 longval = (long)POPLONG(ss,ix);
12220 TOPLONG(nss,ix) = longval;
12222 case SAVEt_I32: /* I32 reference */
12223 case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
12224 ptr = POPPTR(ss,ix);
12225 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12227 TOPINT(nss,ix) = i;
12229 case SAVEt_IV: /* IV reference */
12230 ptr = POPPTR(ss,ix);
12231 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12233 TOPIV(nss,ix) = iv;
12235 case SAVEt_HPTR: /* HV* reference */
12236 case SAVEt_APTR: /* AV* reference */
12237 case SAVEt_SPTR: /* SV* reference */
12238 ptr = POPPTR(ss,ix);
12239 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12240 sv = (const SV *)POPPTR(ss,ix);
12241 TOPPTR(nss,ix) = sv_dup(sv, param);
12243 case SAVEt_VPTR: /* random* reference */
12244 ptr = POPPTR(ss,ix);
12245 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12247 case SAVEt_INT_SMALL:
12248 case SAVEt_I32_SMALL:
12249 case SAVEt_I16: /* I16 reference */
12250 case SAVEt_I8: /* I8 reference */
12252 ptr = POPPTR(ss,ix);
12253 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12255 case SAVEt_GENERIC_PVREF: /* generic char* */
12256 case SAVEt_PPTR: /* char* reference */
12257 ptr = POPPTR(ss,ix);
12258 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12259 c = (char*)POPPTR(ss,ix);
12260 TOPPTR(nss,ix) = pv_dup(c);
12262 case SAVEt_GP: /* scalar reference */
12263 gv = (const GV *)POPPTR(ss,ix);
12264 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
12265 gp = (GP*)POPPTR(ss,ix);
12266 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
12267 (void)GpREFCNT_inc(gp);
12269 TOPINT(nss,ix) = i;
12272 ptr = POPPTR(ss,ix);
12273 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
12274 /* these are assumed to be refcounted properly */
12276 switch (((OP*)ptr)->op_type) {
12278 case OP_LEAVESUBLV:
12282 case OP_LEAVEWRITE:
12283 TOPPTR(nss,ix) = ptr;
12286 (void) OpREFCNT_inc(o);
12290 TOPPTR(nss,ix) = NULL;
12295 TOPPTR(nss,ix) = NULL;
12297 case SAVEt_FREECOPHH:
12298 ptr = POPPTR(ss,ix);
12299 TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr);
12302 hv = (const HV *)POPPTR(ss,ix);
12303 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12305 TOPINT(nss,ix) = i;
12308 c = (char*)POPPTR(ss,ix);
12309 TOPPTR(nss,ix) = pv_dup_inc(c);
12311 case SAVEt_STACK_POS: /* Position on Perl stack */
12313 TOPINT(nss,ix) = i;
12315 case SAVEt_DESTRUCTOR:
12316 ptr = POPPTR(ss,ix);
12317 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
12318 dptr = POPDPTR(ss,ix);
12319 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
12320 any_dup(FPTR2DPTR(void *, dptr),
12323 case SAVEt_DESTRUCTOR_X:
12324 ptr = POPPTR(ss,ix);
12325 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
12326 dxptr = POPDXPTR(ss,ix);
12327 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
12328 any_dup(FPTR2DPTR(void *, dxptr),
12331 case SAVEt_REGCONTEXT:
12333 ix -= uv >> SAVE_TIGHT_SHIFT;
12335 case SAVEt_AELEM: /* array element */
12336 sv = (const SV *)POPPTR(ss,ix);
12337 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12339 TOPINT(nss,ix) = i;
12340 av = (const AV *)POPPTR(ss,ix);
12341 TOPPTR(nss,ix) = av_dup_inc(av, param);
12344 ptr = POPPTR(ss,ix);
12345 TOPPTR(nss,ix) = ptr;
12348 ptr = POPPTR(ss,ix);
12349 ptr = cophh_copy((COPHH*)ptr);
12350 TOPPTR(nss,ix) = ptr;
12352 TOPINT(nss,ix) = i;
12353 if (i & HINT_LOCALIZE_HH) {
12354 hv = (const HV *)POPPTR(ss,ix);
12355 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12358 case SAVEt_PADSV_AND_MORTALIZE:
12359 longval = (long)POPLONG(ss,ix);
12360 TOPLONG(nss,ix) = longval;
12361 ptr = POPPTR(ss,ix);
12362 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12363 sv = (const SV *)POPPTR(ss,ix);
12364 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12366 case SAVEt_SET_SVFLAGS:
12368 TOPINT(nss,ix) = i;
12370 TOPINT(nss,ix) = i;
12371 sv = (const SV *)POPPTR(ss,ix);
12372 TOPPTR(nss,ix) = sv_dup(sv, param);
12374 case SAVEt_RE_STATE:
12376 const struct re_save_state *const old_state
12377 = (struct re_save_state *)
12378 (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12379 struct re_save_state *const new_state
12380 = (struct re_save_state *)
12381 (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12383 Copy(old_state, new_state, 1, struct re_save_state);
12384 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
12386 new_state->re_state_bostr
12387 = pv_dup(old_state->re_state_bostr);
12388 new_state->re_state_reginput
12389 = pv_dup(old_state->re_state_reginput);
12390 new_state->re_state_regeol
12391 = pv_dup(old_state->re_state_regeol);
12392 new_state->re_state_regoffs
12393 = (regexp_paren_pair*)
12394 any_dup(old_state->re_state_regoffs, proto_perl);
12395 new_state->re_state_reglastparen
12396 = (U32*) any_dup(old_state->re_state_reglastparen,
12398 new_state->re_state_reglastcloseparen
12399 = (U32*)any_dup(old_state->re_state_reglastcloseparen,
12401 /* XXX This just has to be broken. The old save_re_context
12402 code did SAVEGENERICPV(PL_reg_start_tmp);
12403 PL_reg_start_tmp is char **.
12404 Look above to what the dup code does for
12405 SAVEt_GENERIC_PVREF
12406 It can never have worked.
12407 So this is merely a faithful copy of the exiting bug: */
12408 new_state->re_state_reg_start_tmp
12409 = (char **) pv_dup((char *)
12410 old_state->re_state_reg_start_tmp);
12411 /* I assume that it only ever "worked" because no-one called
12412 (pseudo)fork while the regexp engine had re-entered itself.
12414 #ifdef PERL_OLD_COPY_ON_WRITE
12415 new_state->re_state_nrs
12416 = sv_dup(old_state->re_state_nrs, param);
12418 new_state->re_state_reg_magic
12419 = (MAGIC*) any_dup(old_state->re_state_reg_magic,
12421 new_state->re_state_reg_oldcurpm
12422 = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
12424 new_state->re_state_reg_curpm
12425 = (PMOP*) any_dup(old_state->re_state_reg_curpm,
12427 new_state->re_state_reg_oldsaved
12428 = pv_dup(old_state->re_state_reg_oldsaved);
12429 new_state->re_state_reg_poscache
12430 = pv_dup(old_state->re_state_reg_poscache);
12431 new_state->re_state_reg_starttry
12432 = pv_dup(old_state->re_state_reg_starttry);
12435 case SAVEt_COMPILE_WARNINGS:
12436 ptr = POPPTR(ss,ix);
12437 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
12440 ptr = POPPTR(ss,ix);
12441 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
12445 "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
12453 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
12454 * flag to the result. This is done for each stash before cloning starts,
12455 * so we know which stashes want their objects cloned */
12458 do_mark_cloneable_stash(pTHX_ SV *const sv)
12460 const HEK * const hvname = HvNAME_HEK((const HV *)sv);
12462 GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
12463 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
12464 if (cloner && GvCV(cloner)) {
12471 mXPUSHs(newSVhek(hvname));
12473 call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
12480 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
12488 =for apidoc perl_clone
12490 Create and return a new interpreter by cloning the current one.
12492 perl_clone takes these flags as parameters:
12494 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
12495 without it we only clone the data and zero the stacks,
12496 with it we copy the stacks and the new perl interpreter is
12497 ready to run at the exact same point as the previous one.
12498 The pseudo-fork code uses COPY_STACKS while the
12499 threads->create doesn't.
12501 CLONEf_KEEP_PTR_TABLE
12502 perl_clone keeps a ptr_table with the pointer of the old
12503 variable as a key and the new variable as a value,
12504 this allows it to check if something has been cloned and not
12505 clone it again but rather just use the value and increase the
12506 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
12507 the ptr_table using the function
12508 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
12509 reason to keep it around is if you want to dup some of your own
12510 variable who are outside the graph perl scans, example of this
12511 code is in threads.xs create
12514 This is a win32 thing, it is ignored on unix, it tells perls
12515 win32host code (which is c++) to clone itself, this is needed on
12516 win32 if you want to run two threads at the same time,
12517 if you just want to do some stuff in a separate perl interpreter
12518 and then throw it away and return to the original one,
12519 you don't need to do anything.
12524 /* XXX the above needs expanding by someone who actually understands it ! */
12525 EXTERN_C PerlInterpreter *
12526 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
12529 perl_clone(PerlInterpreter *proto_perl, UV flags)
12532 #ifdef PERL_IMPLICIT_SYS
12534 PERL_ARGS_ASSERT_PERL_CLONE;
12536 /* perlhost.h so we need to call into it
12537 to clone the host, CPerlHost should have a c interface, sky */
12539 if (flags & CLONEf_CLONE_HOST) {
12540 return perl_clone_host(proto_perl,flags);
12542 return perl_clone_using(proto_perl, flags,
12544 proto_perl->IMemShared,
12545 proto_perl->IMemParse,
12547 proto_perl->IStdIO,
12551 proto_perl->IProc);
12555 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
12556 struct IPerlMem* ipM, struct IPerlMem* ipMS,
12557 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
12558 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
12559 struct IPerlDir* ipD, struct IPerlSock* ipS,
12560 struct IPerlProc* ipP)
12562 /* XXX many of the string copies here can be optimized if they're
12563 * constants; they need to be allocated as common memory and just
12564 * their pointers copied. */
12567 CLONE_PARAMS clone_params;
12568 CLONE_PARAMS* const param = &clone_params;
12570 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
12572 PERL_ARGS_ASSERT_PERL_CLONE_USING;
12573 #else /* !PERL_IMPLICIT_SYS */
12575 CLONE_PARAMS clone_params;
12576 CLONE_PARAMS* param = &clone_params;
12577 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
12579 PERL_ARGS_ASSERT_PERL_CLONE;
12580 #endif /* PERL_IMPLICIT_SYS */
12582 /* for each stash, determine whether its objects should be cloned */
12583 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
12584 PERL_SET_THX(my_perl);
12587 PoisonNew(my_perl, 1, PerlInterpreter);
12592 PL_scopestack_name = 0;
12594 PL_savestack_ix = 0;
12595 PL_savestack_max = -1;
12596 PL_sig_pending = 0;
12598 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
12599 # ifdef DEBUG_LEAKING_SCALARS
12600 PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
12602 #else /* !DEBUGGING */
12603 Zero(my_perl, 1, PerlInterpreter);
12604 #endif /* DEBUGGING */
12606 #ifdef PERL_IMPLICIT_SYS
12607 /* host pointers */
12609 PL_MemShared = ipMS;
12610 PL_MemParse = ipMP;
12617 #endif /* PERL_IMPLICIT_SYS */
12619 param->flags = flags;
12620 /* Nothing in the core code uses this, but we make it available to
12621 extensions (using mg_dup). */
12622 param->proto_perl = proto_perl;
12623 /* Likely nothing will use this, but it is initialised to be consistent
12624 with Perl_clone_params_new(). */
12625 param->new_perl = my_perl;
12626 param->unreferenced = NULL;
12628 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
12630 PL_body_arenas = NULL;
12631 Zero(&PL_body_roots, 1, PL_body_roots);
12634 PL_sv_objcount = 0;
12636 PL_sv_arenaroot = NULL;
12638 PL_debug = proto_perl->Idebug;
12640 PL_hash_seed = proto_perl->Ihash_seed;
12641 PL_rehash_seed = proto_perl->Irehash_seed;
12643 #ifdef USE_REENTRANT_API
12644 /* XXX: things like -Dm will segfault here in perlio, but doing
12645 * PERL_SET_CONTEXT(proto_perl);
12646 * breaks too many other things
12648 Perl_reentrant_init(aTHX);
12651 /* create SV map for pointer relocation */
12652 PL_ptr_table = ptr_table_new();
12654 /* initialize these special pointers as early as possible */
12655 SvANY(&PL_sv_undef) = NULL;
12656 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
12657 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
12658 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
12660 SvANY(&PL_sv_no) = new_XPVNV();
12661 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
12662 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12663 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12664 SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
12665 SvCUR_set(&PL_sv_no, 0);
12666 SvLEN_set(&PL_sv_no, 1);
12667 SvIV_set(&PL_sv_no, 0);
12668 SvNV_set(&PL_sv_no, 0);
12669 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
12671 SvANY(&PL_sv_yes) = new_XPVNV();
12672 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
12673 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12674 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12675 SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
12676 SvCUR_set(&PL_sv_yes, 1);
12677 SvLEN_set(&PL_sv_yes, 2);
12678 SvIV_set(&PL_sv_yes, 1);
12679 SvNV_set(&PL_sv_yes, 1);
12680 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
12682 /* dbargs array probably holds garbage */
12685 /* create (a non-shared!) shared string table */
12686 PL_strtab = newHV();
12687 HvSHAREKEYS_off(PL_strtab);
12688 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
12689 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
12691 PL_compiling = proto_perl->Icompiling;
12693 /* These two PVs will be free'd special way so must set them same way op.c does */
12694 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
12695 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
12697 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
12698 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
12700 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
12701 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
12702 CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));
12703 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
12704 #ifdef PERL_DEBUG_READONLY_OPS
12709 /* pseudo environmental stuff */
12710 PL_origargc = proto_perl->Iorigargc;
12711 PL_origargv = proto_perl->Iorigargv;
12713 param->stashes = newAV(); /* Setup array of objects to call clone on */
12714 /* This makes no difference to the implementation, as it always pushes
12715 and shifts pointers to other SVs without changing their reference
12716 count, with the array becoming empty before it is freed. However, it
12717 makes it conceptually clear what is going on, and will avoid some
12718 work inside av.c, filling slots between AvFILL() and AvMAX() with
12719 &PL_sv_undef, and SvREFCNT_dec()ing those. */
12720 AvREAL_off(param->stashes);
12722 if (!(flags & CLONEf_COPY_STACKS)) {
12723 param->unreferenced = newAV();
12726 /* Set tainting stuff before PerlIO_debug can possibly get called */
12727 PL_tainting = proto_perl->Itainting;
12728 PL_taint_warn = proto_perl->Itaint_warn;
12730 #ifdef PERLIO_LAYERS
12731 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
12732 PerlIO_clone(aTHX_ proto_perl, param);
12735 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
12736 PL_incgv = gv_dup(proto_perl->Iincgv, param);
12737 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
12738 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
12739 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
12740 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
12743 PL_minus_c = proto_perl->Iminus_c;
12744 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
12745 PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
12746 PL_localpatches = proto_perl->Ilocalpatches;
12747 PL_splitstr = proto_perl->Isplitstr;
12748 PL_minus_n = proto_perl->Iminus_n;
12749 PL_minus_p = proto_perl->Iminus_p;
12750 PL_minus_l = proto_perl->Iminus_l;
12751 PL_minus_a = proto_perl->Iminus_a;
12752 PL_minus_E = proto_perl->Iminus_E;
12753 PL_minus_F = proto_perl->Iminus_F;
12754 PL_doswitches = proto_perl->Idoswitches;
12755 PL_dowarn = proto_perl->Idowarn;
12756 PL_sawampersand = proto_perl->Isawampersand;
12757 PL_unsafe = proto_perl->Iunsafe;
12758 PL_inplace = SAVEPV(proto_perl->Iinplace);
12759 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
12760 PL_perldb = proto_perl->Iperldb;
12761 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
12762 PL_exit_flags = proto_perl->Iexit_flags;
12764 /* magical thingies */
12765 /* XXX time(&PL_basetime) when asked for? */
12766 PL_basetime = proto_perl->Ibasetime;
12767 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
12769 PL_maxsysfd = proto_perl->Imaxsysfd;
12770 PL_statusvalue = proto_perl->Istatusvalue;
12772 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
12774 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
12776 PL_encoding = sv_dup(proto_perl->Iencoding, param);
12778 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
12779 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
12780 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
12783 /* RE engine related */
12784 Zero(&PL_reg_state, 1, struct re_save_state);
12785 PL_reginterp_cnt = 0;
12786 PL_regmatch_slab = NULL;
12788 /* Clone the regex array */
12789 /* ORANGE FIXME for plugins, probably in the SV dup code.
12790 newSViv(PTR2IV(CALLREGDUPE(
12791 INT2PTR(REGEXP *, SvIVX(regex)), param))))
12793 PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
12794 PL_regex_pad = AvARRAY(PL_regex_padav);
12796 /* shortcuts to various I/O objects */
12797 PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param);
12798 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
12799 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
12800 PL_defgv = gv_dup(proto_perl->Idefgv, param);
12801 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
12802 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
12803 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
12805 /* shortcuts to regexp stuff */
12806 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
12808 /* shortcuts to misc objects */
12809 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
12811 /* shortcuts to debugging objects */
12812 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
12813 PL_DBline = gv_dup(proto_perl->IDBline, param);
12814 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
12815 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
12816 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
12817 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
12819 /* symbol tables */
12820 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
12821 PL_curstash = hv_dup(proto_perl->Icurstash, param);
12822 PL_debstash = hv_dup(proto_perl->Idebstash, param);
12823 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
12824 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
12826 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
12827 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
12828 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
12829 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
12830 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
12831 PL_endav = av_dup_inc(proto_perl->Iendav, param);
12832 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
12833 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
12835 PL_sub_generation = proto_perl->Isub_generation;
12836 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
12838 /* funky return mechanisms */
12839 PL_forkprocess = proto_perl->Iforkprocess;
12841 /* subprocess state */
12842 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
12844 /* internal state */
12845 PL_maxo = proto_perl->Imaxo;
12846 if (proto_perl->Iop_mask)
12847 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
12850 /* PL_asserting = proto_perl->Iasserting; */
12852 /* current interpreter roots */
12853 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
12855 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
12857 PL_main_start = proto_perl->Imain_start;
12858 PL_eval_root = proto_perl->Ieval_root;
12859 PL_eval_start = proto_perl->Ieval_start;
12861 /* runtime control stuff */
12862 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
12864 PL_filemode = proto_perl->Ifilemode;
12865 PL_lastfd = proto_perl->Ilastfd;
12866 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
12869 PL_gensym = proto_perl->Igensym;
12870 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
12871 PL_laststatval = proto_perl->Ilaststatval;
12872 PL_laststype = proto_perl->Ilaststype;
12875 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
12877 /* interpreter atexit processing */
12878 PL_exitlistlen = proto_perl->Iexitlistlen;
12879 if (PL_exitlistlen) {
12880 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12881 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12884 PL_exitlist = (PerlExitListEntry*)NULL;
12886 PL_my_cxt_size = proto_perl->Imy_cxt_size;
12887 if (PL_my_cxt_size) {
12888 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
12889 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
12890 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12891 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
12892 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
12896 PL_my_cxt_list = (void**)NULL;
12897 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12898 PL_my_cxt_keys = (const char**)NULL;
12901 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
12902 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
12903 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
12904 PL_custom_ops = hv_dup_inc(proto_perl->Icustom_ops, param);
12906 PL_profiledata = NULL;
12908 PL_compcv = cv_dup(proto_perl->Icompcv, param);
12910 PAD_CLONE_VARS(proto_perl, param);
12912 #ifdef HAVE_INTERP_INTERN
12913 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
12916 /* more statics moved here */
12917 PL_generation = proto_perl->Igeneration;
12918 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
12920 PL_in_clean_objs = proto_perl->Iin_clean_objs;
12921 PL_in_clean_all = proto_perl->Iin_clean_all;
12923 PL_uid = proto_perl->Iuid;
12924 PL_euid = proto_perl->Ieuid;
12925 PL_gid = proto_perl->Igid;
12926 PL_egid = proto_perl->Iegid;
12927 PL_nomemok = proto_perl->Inomemok;
12928 PL_an = proto_perl->Ian;
12929 PL_evalseq = proto_perl->Ievalseq;
12930 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
12931 PL_origalen = proto_perl->Iorigalen;
12932 #ifdef PERL_USES_PL_PIDSTATUS
12933 PL_pidstatus = newHV(); /* XXX flag for cloning? */
12935 PL_osname = SAVEPV(proto_perl->Iosname);
12936 PL_sighandlerp = proto_perl->Isighandlerp;
12938 PL_runops = proto_perl->Irunops;
12940 PL_parser = parser_dup(proto_perl->Iparser, param);
12942 /* XXX this only works if the saved cop has already been cloned */
12943 if (proto_perl->Iparser) {
12944 PL_parser->saved_curcop = (COP*)any_dup(
12945 proto_perl->Iparser->saved_curcop,
12949 PL_subline = proto_perl->Isubline;
12950 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
12953 PL_cryptseen = proto_perl->Icryptseen;
12956 PL_hints = proto_perl->Ihints;
12958 PL_amagic_generation = proto_perl->Iamagic_generation;
12960 #ifdef USE_LOCALE_COLLATE
12961 PL_collation_ix = proto_perl->Icollation_ix;
12962 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
12963 PL_collation_standard = proto_perl->Icollation_standard;
12964 PL_collxfrm_base = proto_perl->Icollxfrm_base;
12965 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
12966 #endif /* USE_LOCALE_COLLATE */
12968 #ifdef USE_LOCALE_NUMERIC
12969 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
12970 PL_numeric_standard = proto_perl->Inumeric_standard;
12971 PL_numeric_local = proto_perl->Inumeric_local;
12972 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12973 #endif /* !USE_LOCALE_NUMERIC */
12975 /* utf8 character classes */
12976 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12977 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12978 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12979 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
12980 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12981 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
12982 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
12983 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
12984 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
12985 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
12986 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
12987 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12988 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
12989 PL_utf8_X_begin = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
12990 PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
12991 PL_utf8_X_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
12992 PL_utf8_X_non_hangul = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
12993 PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
12994 PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
12995 PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
12996 PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
12997 PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
12998 PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
12999 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
13000 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
13001 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
13002 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
13003 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
13004 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
13006 /* Did the locale setup indicate UTF-8? */
13007 PL_utf8locale = proto_perl->Iutf8locale;
13008 /* Unicode features (see perlrun/-C) */
13009 PL_unicode = proto_perl->Iunicode;
13011 /* Pre-5.8 signals control */
13012 PL_signals = proto_perl->Isignals;
13014 /* times() ticks per second */
13015 PL_clocktick = proto_perl->Iclocktick;
13017 /* Recursion stopper for PerlIO_find_layer */
13018 PL_in_load_module = proto_perl->Iin_load_module;
13020 /* sort() routine */
13021 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
13023 /* Not really needed/useful since the reenrant_retint is "volatile",
13024 * but do it for consistency's sake. */
13025 PL_reentrant_retint = proto_perl->Ireentrant_retint;
13027 /* Hooks to shared SVs and locks. */
13028 PL_sharehook = proto_perl->Isharehook;
13029 PL_lockhook = proto_perl->Ilockhook;
13030 PL_unlockhook = proto_perl->Iunlockhook;
13031 PL_threadhook = proto_perl->Ithreadhook;
13032 PL_destroyhook = proto_perl->Idestroyhook;
13033 PL_signalhook = proto_perl->Isignalhook;
13035 #ifdef THREADS_HAVE_PIDS
13036 PL_ppid = proto_perl->Ippid;
13040 PL_last_swash_hv = NULL; /* reinits on demand */
13041 PL_last_swash_klen = 0;
13042 PL_last_swash_key[0]= '\0';
13043 PL_last_swash_tmps = (U8*)NULL;
13044 PL_last_swash_slen = 0;
13046 PL_glob_index = proto_perl->Iglob_index;
13047 PL_srand_called = proto_perl->Isrand_called;
13049 if (proto_perl->Ipsig_pend) {
13050 Newxz(PL_psig_pend, SIG_SIZE, int);
13053 PL_psig_pend = (int*)NULL;
13056 if (proto_perl->Ipsig_name) {
13057 Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
13058 sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
13060 PL_psig_ptr = PL_psig_name + SIG_SIZE;
13063 PL_psig_ptr = (SV**)NULL;
13064 PL_psig_name = (SV**)NULL;
13067 /* intrpvar.h stuff */
13069 if (flags & CLONEf_COPY_STACKS) {
13070 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
13071 PL_tmps_ix = proto_perl->Itmps_ix;
13072 PL_tmps_max = proto_perl->Itmps_max;
13073 PL_tmps_floor = proto_perl->Itmps_floor;
13074 Newx(PL_tmps_stack, PL_tmps_max, SV*);
13075 sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
13076 PL_tmps_ix+1, param);
13078 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
13079 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
13080 Newxz(PL_markstack, i, I32);
13081 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
13082 - proto_perl->Imarkstack);
13083 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
13084 - proto_perl->Imarkstack);
13085 Copy(proto_perl->Imarkstack, PL_markstack,
13086 PL_markstack_ptr - PL_markstack + 1, I32);
13088 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13089 * NOTE: unlike the others! */
13090 PL_scopestack_ix = proto_perl->Iscopestack_ix;
13091 PL_scopestack_max = proto_perl->Iscopestack_max;
13092 Newxz(PL_scopestack, PL_scopestack_max, I32);
13093 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
13096 Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
13097 Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
13099 /* NOTE: si_dup() looks at PL_markstack */
13100 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
13102 /* PL_curstack = PL_curstackinfo->si_stack; */
13103 PL_curstack = av_dup(proto_perl->Icurstack, param);
13104 PL_mainstack = av_dup(proto_perl->Imainstack, param);
13106 /* next PUSHs() etc. set *(PL_stack_sp+1) */
13107 PL_stack_base = AvARRAY(PL_curstack);
13108 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
13109 - proto_perl->Istack_base);
13110 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
13112 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
13113 * NOTE: unlike the others! */
13114 PL_savestack_ix = proto_perl->Isavestack_ix;
13115 PL_savestack_max = proto_perl->Isavestack_max;
13116 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
13117 PL_savestack = ss_dup(proto_perl, param);
13121 ENTER; /* perl_destruct() wants to LEAVE; */
13124 PL_start_env = proto_perl->Istart_env; /* XXXXXX */
13125 PL_top_env = &PL_start_env;
13127 PL_op = proto_perl->Iop;
13130 PL_Xpv = (XPV*)NULL;
13131 my_perl->Ina = proto_perl->Ina;
13133 PL_statbuf = proto_perl->Istatbuf;
13134 PL_statcache = proto_perl->Istatcache;
13135 PL_statgv = gv_dup(proto_perl->Istatgv, param);
13136 PL_statname = sv_dup_inc(proto_perl->Istatname, param);
13138 PL_timesbuf = proto_perl->Itimesbuf;
13141 PL_tainted = proto_perl->Itainted;
13142 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
13143 PL_rs = sv_dup_inc(proto_perl->Irs, param);
13144 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
13145 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
13146 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
13147 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
13148 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
13149 PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
13151 PL_restartjmpenv = proto_perl->Irestartjmpenv;
13152 PL_restartop = proto_perl->Irestartop;
13153 PL_in_eval = proto_perl->Iin_eval;
13154 PL_delaymagic = proto_perl->Idelaymagic;
13155 PL_phase = proto_perl->Iphase;
13156 PL_localizing = proto_perl->Ilocalizing;
13158 PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
13159 PL_hv_fetch_ent_mh = NULL;
13160 PL_modcount = proto_perl->Imodcount;
13161 PL_lastgotoprobe = NULL;
13162 PL_dumpindent = proto_perl->Idumpindent;
13164 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
13165 PL_sortstash = hv_dup(proto_perl->Isortstash, param);
13166 PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
13167 PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
13168 PL_efloatbuf = NULL; /* reinits on demand */
13169 PL_efloatsize = 0; /* reinits on demand */
13173 PL_screamfirst = NULL;
13174 PL_screamnext = NULL;
13175 PL_maxscream = -1; /* reinits on demand */
13176 PL_lastscream = NULL;
13179 PL_regdummy = proto_perl->Iregdummy;
13180 PL_colorset = 0; /* reinits PL_colors[] */
13181 /*PL_colors[6] = {0,0,0,0,0,0};*/
13185 /* Pluggable optimizer */
13186 PL_peepp = proto_perl->Ipeepp;
13187 PL_rpeepp = proto_perl->Irpeepp;
13188 /* op_free() hook */
13189 PL_opfreehook = proto_perl->Iopfreehook;
13191 PL_stashcache = newHV();
13193 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
13194 proto_perl->Iwatchaddr);
13195 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
13196 if (PL_debug && PL_watchaddr) {
13197 PerlIO_printf(Perl_debug_log,
13198 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
13199 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
13200 PTR2UV(PL_watchok));
13203 PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
13204 PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param);
13205 PL_utf8_foldclosures = hv_dup_inc(proto_perl->Iutf8_foldclosures, param);
13207 /* Call the ->CLONE method, if it exists, for each of the stashes
13208 identified by sv_dup() above.
13210 while(av_len(param->stashes) != -1) {
13211 HV* const stash = MUTABLE_HV(av_shift(param->stashes));
13212 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
13213 if (cloner && GvCV(cloner)) {
13218 mXPUSHs(newSVhek(HvNAME_HEK(stash)));
13220 call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
13226 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
13227 ptr_table_free(PL_ptr_table);
13228 PL_ptr_table = NULL;
13231 if (!(flags & CLONEf_COPY_STACKS)) {
13232 unreferenced_to_tmp_stack(param->unreferenced);
13235 SvREFCNT_dec(param->stashes);
13237 /* orphaned? eg threads->new inside BEGIN or use */
13238 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
13239 SvREFCNT_inc_simple_void(PL_compcv);
13240 SAVEFREESV(PL_compcv);
13247 S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
13249 PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
13251 if (AvFILLp(unreferenced) > -1) {
13252 SV **svp = AvARRAY(unreferenced);
13253 SV **const last = svp + AvFILLp(unreferenced);
13257 if (SvREFCNT(*svp) == 1)
13259 } while (++svp <= last);
13261 EXTEND_MORTAL(count);
13262 svp = AvARRAY(unreferenced);
13265 if (SvREFCNT(*svp) == 1) {
13266 /* Our reference is the only one to this SV. This means that
13267 in this thread, the scalar effectively has a 0 reference.
13268 That doesn't work (cleanup never happens), so donate our
13269 reference to it onto the save stack. */
13270 PL_tmps_stack[++PL_tmps_ix] = *svp;
13272 /* As an optimisation, because we are already walking the
13273 entire array, instead of above doing either
13274 SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
13275 release our reference to the scalar, so that at the end of
13276 the array owns zero references to the scalars it happens to
13277 point to. We are effectively converting the array from
13278 AvREAL() on to AvREAL() off. This saves the av_clear()
13279 (triggered by the SvREFCNT_dec(unreferenced) below) from
13280 walking the array a second time. */
13281 SvREFCNT_dec(*svp);
13284 } while (++svp <= last);
13285 AvREAL_off(unreferenced);
13287 SvREFCNT_dec(unreferenced);
13291 Perl_clone_params_del(CLONE_PARAMS *param)
13293 /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
13295 PerlInterpreter *const to = param->new_perl;
13297 PerlInterpreter *const was = PERL_GET_THX;
13299 PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
13305 SvREFCNT_dec(param->stashes);
13306 if (param->unreferenced)
13307 unreferenced_to_tmp_stack(param->unreferenced);
13317 Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
13320 /* Need to play this game, as newAV() can call safesysmalloc(), and that
13321 does a dTHX; to get the context from thread local storage.
13322 FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
13323 a version that passes in my_perl. */
13324 PerlInterpreter *const was = PERL_GET_THX;
13325 CLONE_PARAMS *param;
13327 PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
13333 /* Given that we've set the context, we can do this unshared. */
13334 Newx(param, 1, CLONE_PARAMS);
13337 param->proto_perl = from;
13338 param->new_perl = to;
13339 param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
13340 AvREAL_off(param->stashes);
13341 param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
13349 #endif /* USE_ITHREADS */
13352 =head1 Unicode Support
13354 =for apidoc sv_recode_to_utf8
13356 The encoding is assumed to be an Encode object, on entry the PV
13357 of the sv is assumed to be octets in that encoding, and the sv
13358 will be converted into Unicode (and UTF-8).
13360 If the sv already is UTF-8 (or if it is not POK), or if the encoding
13361 is not a reference, nothing is done to the sv. If the encoding is not
13362 an C<Encode::XS> Encoding object, bad things will happen.
13363 (See F<lib/encoding.pm> and L<Encode>).
13365 The PV of the sv is returned.
13370 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
13374 PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
13376 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
13390 Passing sv_yes is wrong - it needs to be or'ed set of constants
13391 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
13392 remove converted chars from source.
13394 Both will default the value - let them.
13396 XPUSHs(&PL_sv_yes);
13399 call_method("decode", G_SCALAR);
13403 s = SvPV_const(uni, len);
13404 if (s != SvPVX_const(sv)) {
13405 SvGROW(sv, len + 1);
13406 Move(s, SvPVX(sv), len + 1, char);
13407 SvCUR_set(sv, len);
13414 return SvPOKp(sv) ? SvPVX(sv) : NULL;
13418 =for apidoc sv_cat_decode
13420 The encoding is assumed to be an Encode object, the PV of the ssv is
13421 assumed to be octets in that encoding and decoding the input starts
13422 from the position which (PV + *offset) pointed to. The dsv will be
13423 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
13424 when the string tstr appears in decoding output or the input ends on
13425 the PV of the ssv. The value which the offset points will be modified
13426 to the last input position on the ssv.
13428 Returns TRUE if the terminator was found, else returns FALSE.
13433 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
13434 SV *ssv, int *offset, char *tstr, int tlen)
13439 PERL_ARGS_ASSERT_SV_CAT_DECODE;
13441 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
13452 offsv = newSViv(*offset);
13454 mXPUSHp(tstr, tlen);
13456 call_method("cat_decode", G_SCALAR);
13458 ret = SvTRUE(TOPs);
13459 *offset = SvIV(offsv);
13465 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
13470 /* ---------------------------------------------------------------------
13472 * support functions for report_uninit()
13475 /* the maxiumum size of array or hash where we will scan looking
13476 * for the undefined element that triggered the warning */
13478 #define FUV_MAX_SEARCH_SIZE 1000
13480 /* Look for an entry in the hash whose value has the same SV as val;
13481 * If so, return a mortal copy of the key. */
13484 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
13487 register HE **array;
13490 PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
13492 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
13493 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
13496 array = HvARRAY(hv);
13498 for (i=HvMAX(hv); i>0; i--) {
13499 register HE *entry;
13500 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
13501 if (HeVAL(entry) != val)
13503 if ( HeVAL(entry) == &PL_sv_undef ||
13504 HeVAL(entry) == &PL_sv_placeholder)
13508 if (HeKLEN(entry) == HEf_SVKEY)
13509 return sv_mortalcopy(HeKEY_sv(entry));
13510 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
13516 /* Look for an entry in the array whose value has the same SV as val;
13517 * If so, return the index, otherwise return -1. */
13520 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
13524 PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
13526 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
13527 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
13530 if (val != &PL_sv_undef) {
13531 SV ** const svp = AvARRAY(av);
13534 for (i=AvFILLp(av); i>=0; i--)
13541 /* S_varname(): return the name of a variable, optionally with a subscript.
13542 * If gv is non-zero, use the name of that global, along with gvtype (one
13543 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
13544 * targ. Depending on the value of the subscript_type flag, return:
13547 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
13548 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
13549 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
13550 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
13553 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
13554 const SV *const keyname, I32 aindex, int subscript_type)
13557 SV * const name = sv_newmortal();
13560 buffer[0] = gvtype;
13563 /* as gv_fullname4(), but add literal '^' for $^FOO names */
13565 gv_fullname4(name, gv, buffer, 0);
13567 if ((unsigned int)SvPVX(name)[1] <= 26) {
13569 buffer[1] = SvPVX(name)[1] + 'A' - 1;
13571 /* Swap the 1 unprintable control character for the 2 byte pretty
13572 version - ie substr($name, 1, 1) = $buffer; */
13573 sv_insert(name, 1, 1, buffer, 2);
13577 CV * const cv = find_runcv(NULL);
13581 if (!cv || !CvPADLIST(cv))
13583 av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
13584 sv = *av_fetch(av, targ, FALSE);
13585 sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
13588 if (subscript_type == FUV_SUBSCRIPT_HASH) {
13589 SV * const sv = newSV(0);
13590 *SvPVX(name) = '$';
13591 Perl_sv_catpvf(aTHX_ name, "{%s}",
13592 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
13595 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
13596 *SvPVX(name) = '$';
13597 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
13599 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
13600 /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
13601 Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
13609 =for apidoc find_uninit_var
13611 Find the name of the undefined variable (if any) that caused the operator o
13612 to issue a "Use of uninitialized value" warning.
13613 If match is true, only return a name if it's value matches uninit_sv.
13614 So roughly speaking, if a unary operator (such as OP_COS) generates a
13615 warning, then following the direct child of the op may yield an
13616 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
13617 other hand, with OP_ADD there are two branches to follow, so we only print
13618 the variable name if we get an exact match.
13620 The name is returned as a mortal SV.
13622 Assumes that PL_op is the op that originally triggered the error, and that
13623 PL_comppad/PL_curpad points to the currently executing pad.
13629 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
13635 const OP *o, *o2, *kid;
13637 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
13638 uninit_sv == &PL_sv_placeholder)))
13641 switch (obase->op_type) {
13648 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
13649 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
13652 int subscript_type = FUV_SUBSCRIPT_WITHIN;
13654 if (pad) { /* @lex, %lex */
13655 sv = PAD_SVl(obase->op_targ);
13659 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
13660 /* @global, %global */
13661 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
13664 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
13666 else /* @{expr}, %{expr} */
13667 return find_uninit_var(cUNOPx(obase)->op_first,
13671 /* attempt to find a match within the aggregate */
13673 keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13675 subscript_type = FUV_SUBSCRIPT_HASH;
13678 index = find_array_subscript((const AV *)sv, uninit_sv);
13680 subscript_type = FUV_SUBSCRIPT_ARRAY;
13683 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
13686 return varname(gv, hash ? '%' : '@', obase->op_targ,
13687 keysv, index, subscript_type);
13691 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
13693 return varname(NULL, '$', obase->op_targ,
13694 NULL, 0, FUV_SUBSCRIPT_NONE);
13697 gv = cGVOPx_gv(obase);
13698 if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))
13700 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
13703 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
13706 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
13707 if (!av || SvRMAGICAL(av))
13709 svp = av_fetch(av, (I32)obase->op_private, FALSE);
13710 if (!svp || *svp != uninit_sv)
13713 return varname(NULL, '$', obase->op_targ,
13714 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
13717 gv = cGVOPx_gv(obase);
13722 AV *const av = GvAV(gv);
13723 if (!av || SvRMAGICAL(av))
13725 svp = av_fetch(av, (I32)obase->op_private, FALSE);
13726 if (!svp || *svp != uninit_sv)
13729 return varname(gv, '$', 0,
13730 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
13735 o = cUNOPx(obase)->op_first;
13736 if (!o || o->op_type != OP_NULL ||
13737 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
13739 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
13743 if (PL_op == obase)
13744 /* $a[uninit_expr] or $h{uninit_expr} */
13745 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
13748 o = cBINOPx(obase)->op_first;
13749 kid = cBINOPx(obase)->op_last;
13751 /* get the av or hv, and optionally the gv */
13753 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
13754 sv = PAD_SV(o->op_targ);
13756 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
13757 && cUNOPo->op_first->op_type == OP_GV)
13759 gv = cGVOPx_gv(cUNOPo->op_first);
13763 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
13768 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
13769 /* index is constant */
13773 if (obase->op_type == OP_HELEM) {
13774 HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
13775 if (!he || HeVAL(he) != uninit_sv)
13779 SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
13780 if (!svp || *svp != uninit_sv)
13784 if (obase->op_type == OP_HELEM)
13785 return varname(gv, '%', o->op_targ,
13786 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
13788 return varname(gv, '@', o->op_targ, NULL,
13789 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
13792 /* index is an expression;
13793 * attempt to find a match within the aggregate */
13794 if (obase->op_type == OP_HELEM) {
13795 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13797 return varname(gv, '%', o->op_targ,
13798 keysv, 0, FUV_SUBSCRIPT_HASH);
13802 = find_array_subscript((const AV *)sv, uninit_sv);
13804 return varname(gv, '@', o->op_targ,
13805 NULL, index, FUV_SUBSCRIPT_ARRAY);
13810 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
13812 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
13817 /* only examine RHS */
13818 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
13821 o = cUNOPx(obase)->op_first;
13822 if (o->op_type == OP_PUSHMARK)
13825 if (!o->op_sibling) {
13826 /* one-arg version of open is highly magical */
13828 if (o->op_type == OP_GV) { /* open FOO; */
13830 if (match && GvSV(gv) != uninit_sv)
13832 return varname(gv, '$', 0,
13833 NULL, 0, FUV_SUBSCRIPT_NONE);
13835 /* other possibilities not handled are:
13836 * open $x; or open my $x; should return '${*$x}'
13837 * open expr; should return '$'.expr ideally
13843 /* ops where $_ may be an implicit arg */
13847 if ( !(obase->op_flags & OPf_STACKED)) {
13848 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
13849 ? PAD_SVl(obase->op_targ)
13852 sv = sv_newmortal();
13853 sv_setpvs(sv, "$_");
13862 match = 1; /* print etc can return undef on defined args */
13863 /* skip filehandle as it can't produce 'undef' warning */
13864 o = cUNOPx(obase)->op_first;
13865 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
13866 o = o->op_sibling->op_sibling;
13870 case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
13872 case OP_CUSTOM: /* XS or custom code could trigger random warnings */
13874 /* the following ops are capable of returning PL_sv_undef even for
13875 * defined arg(s) */
13894 case OP_GETPEERNAME:
13942 case OP_SMARTMATCH:
13951 /* XXX tmp hack: these two may call an XS sub, and currently
13952 XS subs don't have a SUB entry on the context stack, so CV and
13953 pad determination goes wrong, and BAD things happen. So, just
13954 don't try to determine the value under those circumstances.
13955 Need a better fix at dome point. DAPM 11/2007 */
13961 GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
13962 if (gv && GvSV(gv) == uninit_sv)
13963 return newSVpvs_flags("$.", SVs_TEMP);
13968 /* def-ness of rval pos() is independent of the def-ness of its arg */
13969 if ( !(obase->op_flags & OPf_MOD))
13974 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
13975 return newSVpvs_flags("${$/}", SVs_TEMP);
13980 if (!(obase->op_flags & OPf_KIDS))
13982 o = cUNOPx(obase)->op_first;
13988 /* if all except one arg are constant, or have no side-effects,
13989 * or are optimized away, then it's unambiguous */
13991 for (kid=o; kid; kid = kid->op_sibling) {
13993 const OPCODE type = kid->op_type;
13994 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
13995 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
13996 || (type == OP_PUSHMARK)
14000 if (o2) { /* more than one found */
14007 return find_uninit_var(o2, uninit_sv, match);
14009 /* scan all args */
14011 sv = find_uninit_var(o, uninit_sv, 1);
14023 =for apidoc report_uninit
14025 Print appropriate "Use of uninitialized variable" warning
14031 Perl_report_uninit(pTHX_ const SV *uninit_sv)
14035 SV* varname = NULL;
14037 varname = find_uninit_var(PL_op, uninit_sv,0);
14039 sv_insert(varname, 0, 0, " ", 1);
14041 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
14042 varname ? SvPV_nolen_const(varname) : "",
14043 " in ", OP_DESC(PL_op));
14046 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
14052 * c-indentation-style: bsd
14053 * c-basic-offset: 4
14054 * indent-tabs-mode: t
14057 * ex: set ts=8 sts=4 sw=4 noet: