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;
3031 sv_utf8_downgrade(sv,0);
3032 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3036 =for apidoc sv_2pvutf8
3038 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3039 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3041 Usually accessed via the C<SvPVutf8> macro.
3047 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3049 PERL_ARGS_ASSERT_SV_2PVUTF8;
3051 sv_utf8_upgrade(sv);
3052 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3057 =for apidoc sv_2bool
3059 This macro is only used by sv_true() or its macro equivalent, and only if
3060 the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3061 It calls sv_2bool_flags with the SV_GMAGIC flag.
3063 =for apidoc sv_2bool_flags
3065 This function is only used by sv_true() and friends, and only if
3066 the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
3067 contain SV_GMAGIC, then it does an mg_get() first.
3074 Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags)
3078 PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3080 if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3086 SV * const tmpsv = AMG_CALLun(sv,bool_);
3087 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3088 return cBOOL(SvTRUE(tmpsv));
3090 return SvRV(sv) != 0;
3093 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3095 (*sv->sv_u.svu_pv > '0' ||
3096 Xpvtmp->xpv_cur > 1 ||
3097 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3104 return SvIVX(sv) != 0;
3107 return SvNVX(sv) != 0.0;
3109 if (isGV_with_GP(sv))
3119 =for apidoc sv_utf8_upgrade
3121 Converts the PV of an SV to its UTF-8-encoded form.
3122 Forces the SV to string form if it is not already.
3123 Will C<mg_get> on C<sv> if appropriate.
3124 Always sets the SvUTF8 flag to avoid future validity checks even
3125 if the whole string is the same in UTF-8 as not.
3126 Returns the number of bytes in the converted string
3128 This is not as a general purpose byte encoding to Unicode interface:
3129 use the Encode extension for that.
3131 =for apidoc sv_utf8_upgrade_nomg
3133 Like sv_utf8_upgrade, but doesn't do magic on C<sv>
3135 =for apidoc sv_utf8_upgrade_flags
3137 Converts the PV of an SV to its UTF-8-encoded form.
3138 Forces the SV to string form if it is not already.
3139 Always sets the SvUTF8 flag to avoid future validity checks even
3140 if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
3141 will C<mg_get> on C<sv> if appropriate, else not.
3142 Returns the number of bytes in the converted string
3143 C<sv_utf8_upgrade> and
3144 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3146 This is not as a general purpose byte encoding to Unicode interface:
3147 use the Encode extension for that.
3151 The grow version is currently not externally documented. It adds a parameter,
3152 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3153 have free after it upon return. This allows the caller to reserve extra space
3154 that it intends to fill, to avoid extra grows.
3156 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3157 which can be used to tell this function to not first check to see if there are
3158 any characters that are different in UTF-8 (variant characters) which would
3159 force it to allocate a new string to sv, but to assume there are. Typically
3160 this flag is used by a routine that has already parsed the string to find that
3161 there are such characters, and passes this information on so that the work
3162 doesn't have to be repeated.
3164 (One might think that the calling routine could pass in the position of the
3165 first such variant, so it wouldn't have to be found again. But that is not the
3166 case, because typically when the caller is likely to use this flag, it won't be
3167 calling this routine unless it finds something that won't fit into a byte.
3168 Otherwise it tries to not upgrade and just use bytes. But some things that
3169 do fit into a byte are variants in utf8, and the caller may not have been
3170 keeping track of these.)
3172 If the routine itself changes the string, it adds a trailing NUL. Such a NUL
3173 isn't guaranteed due to having other routines do the work in some input cases,
3174 or if the input is already flagged as being in utf8.
3176 The speed of this could perhaps be improved for many cases if someone wanted to
3177 write a fast function that counts the number of variant characters in a string,
3178 especially if it could return the position of the first one.
3183 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
3187 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3189 if (sv == &PL_sv_undef)
3193 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3194 (void) sv_2pv_flags(sv,&len, flags);
3196 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3200 (void) SvPV_force(sv,len);
3205 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3210 sv_force_normal_flags(sv, 0);
3213 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3214 sv_recode_to_utf8(sv, PL_encoding);
3215 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3219 if (SvCUR(sv) == 0) {
3220 if (extra) SvGROW(sv, extra);
3221 } else { /* Assume Latin-1/EBCDIC */
3222 /* This function could be much more efficient if we
3223 * had a FLAG in SVs to signal if there are any variant
3224 * chars in the PV. Given that there isn't such a flag
3225 * make the loop as fast as possible (although there are certainly ways
3226 * to speed this up, eg. through vectorization) */
3227 U8 * s = (U8 *) SvPVX_const(sv);
3228 U8 * e = (U8 *) SvEND(sv);
3230 STRLEN two_byte_count = 0;
3232 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3234 /* See if really will need to convert to utf8. We mustn't rely on our
3235 * incoming SV being well formed and having a trailing '\0', as certain
3236 * code in pp_formline can send us partially built SVs. */
3240 if (NATIVE_IS_INVARIANT(ch)) continue;
3242 t--; /* t already incremented; re-point to first variant */
3247 /* utf8 conversion not needed because all are invariants. Mark as
3248 * UTF-8 even if no variant - saves scanning loop */
3254 /* Here, the string should be converted to utf8, either because of an
3255 * input flag (two_byte_count = 0), or because a character that
3256 * requires 2 bytes was found (two_byte_count = 1). t points either to
3257 * the beginning of the string (if we didn't examine anything), or to
3258 * the first variant. In either case, everything from s to t - 1 will
3259 * occupy only 1 byte each on output.
3261 * There are two main ways to convert. One is to create a new string
3262 * and go through the input starting from the beginning, appending each
3263 * converted value onto the new string as we go along. It's probably
3264 * best to allocate enough space in the string for the worst possible
3265 * case rather than possibly running out of space and having to
3266 * reallocate and then copy what we've done so far. Since everything
3267 * from s to t - 1 is invariant, the destination can be initialized
3268 * with these using a fast memory copy
3270 * The other way is to figure out exactly how big the string should be
3271 * by parsing the entire input. Then you don't have to make it big
3272 * enough to handle the worst possible case, and more importantly, if
3273 * the string you already have is large enough, you don't have to
3274 * allocate a new string, you can copy the last character in the input
3275 * string to the final position(s) that will be occupied by the
3276 * converted string and go backwards, stopping at t, since everything
3277 * before that is invariant.
3279 * There are advantages and disadvantages to each method.
3281 * In the first method, we can allocate a new string, do the memory
3282 * copy from the s to t - 1, and then proceed through the rest of the
3283 * string byte-by-byte.
3285 * In the second method, we proceed through the rest of the input
3286 * string just calculating how big the converted string will be. Then
3287 * there are two cases:
3288 * 1) if the string has enough extra space to handle the converted
3289 * value. We go backwards through the string, converting until we
3290 * get to the position we are at now, and then stop. If this
3291 * position is far enough along in the string, this method is
3292 * faster than the other method. If the memory copy were the same
3293 * speed as the byte-by-byte loop, that position would be about
3294 * half-way, as at the half-way mark, parsing to the end and back
3295 * is one complete string's parse, the same amount as starting
3296 * over and going all the way through. Actually, it would be
3297 * somewhat less than half-way, as it's faster to just count bytes
3298 * than to also copy, and we don't have the overhead of allocating
3299 * a new string, changing the scalar to use it, and freeing the
3300 * existing one. But if the memory copy is fast, the break-even
3301 * point is somewhere after half way. The counting loop could be
3302 * sped up by vectorization, etc, to move the break-even point
3303 * further towards the beginning.
3304 * 2) if the string doesn't have enough space to handle the converted
3305 * value. A new string will have to be allocated, and one might
3306 * as well, given that, start from the beginning doing the first
3307 * method. We've spent extra time parsing the string and in
3308 * exchange all we've gotten is that we know precisely how big to
3309 * make the new one. Perl is more optimized for time than space,
3310 * so this case is a loser.
3311 * So what I've decided to do is not use the 2nd method unless it is
3312 * guaranteed that a new string won't have to be allocated, assuming
3313 * the worst case. I also decided not to put any more conditions on it
3314 * than this, for now. It seems likely that, since the worst case is
3315 * twice as big as the unknown portion of the string (plus 1), we won't
3316 * be guaranteed enough space, causing us to go to the first method,
3317 * unless the string is short, or the first variant character is near
3318 * the end of it. In either of these cases, it seems best to use the
3319 * 2nd method. The only circumstance I can think of where this would
3320 * be really slower is if the string had once had much more data in it
3321 * than it does now, but there is still a substantial amount in it */
3324 STRLEN invariant_head = t - s;
3325 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3326 if (SvLEN(sv) < size) {
3328 /* Here, have decided to allocate a new string */
3333 Newx(dst, size, U8);
3335 /* If no known invariants at the beginning of the input string,
3336 * set so starts from there. Otherwise, can use memory copy to
3337 * get up to where we are now, and then start from here */
3339 if (invariant_head <= 0) {
3342 Copy(s, dst, invariant_head, char);
3343 d = dst + invariant_head;
3347 const UV uv = NATIVE8_TO_UNI(*t++);
3348 if (UNI_IS_INVARIANT(uv))
3349 *d++ = (U8)UNI_TO_NATIVE(uv);
3351 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3352 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3356 SvPV_free(sv); /* No longer using pre-existing string */
3357 SvPV_set(sv, (char*)dst);
3358 SvCUR_set(sv, d - dst);
3359 SvLEN_set(sv, size);
3362 /* Here, have decided to get the exact size of the string.
3363 * Currently this happens only when we know that there is
3364 * guaranteed enough space to fit the converted string, so
3365 * don't have to worry about growing. If two_byte_count is 0,
3366 * then t points to the first byte of the string which hasn't
3367 * been examined yet. Otherwise two_byte_count is 1, and t
3368 * points to the first byte in the string that will expand to
3369 * two. Depending on this, start examining at t or 1 after t.
3372 U8 *d = t + two_byte_count;
3375 /* Count up the remaining bytes that expand to two */
3378 const U8 chr = *d++;
3379 if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3382 /* The string will expand by just the number of bytes that
3383 * occupy two positions. But we are one afterwards because of
3384 * the increment just above. This is the place to put the
3385 * trailing NUL, and to set the length before we decrement */
3387 d += two_byte_count;
3388 SvCUR_set(sv, d - s);
3392 /* Having decremented d, it points to the position to put the
3393 * very last byte of the expanded string. Go backwards through
3394 * the string, copying and expanding as we go, stopping when we
3395 * get to the part that is invariant the rest of the way down */
3399 const U8 ch = NATIVE8_TO_UNI(*e--);
3400 if (UNI_IS_INVARIANT(ch)) {
3401 *d-- = UNI_TO_NATIVE(ch);
3403 *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3404 *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3411 /* Mark as UTF-8 even if no variant - saves scanning loop */
3417 =for apidoc sv_utf8_downgrade
3419 Attempts to convert the PV of an SV from characters to bytes.
3420 If the PV contains a character that cannot fit
3421 in a byte, this conversion will fail;
3422 in this case, either returns false or, if C<fail_ok> is not
3425 This is not as a general purpose Unicode to byte encoding interface:
3426 use the Encode extension for that.
3432 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3436 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3438 if (SvPOKp(sv) && SvUTF8(sv)) {
3444 sv_force_normal_flags(sv, 0);
3446 s = (U8 *) SvPV(sv, len);
3447 if (!utf8_to_bytes(s, &len)) {
3452 Perl_croak(aTHX_ "Wide character in %s",
3455 Perl_croak(aTHX_ "Wide character");
3466 =for apidoc sv_utf8_encode
3468 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3469 flag off so that it looks like octets again.
3475 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3477 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3480 sv_force_normal_flags(sv, 0);
3482 if (SvREADONLY(sv)) {
3483 Perl_croak_no_modify(aTHX);
3485 (void) sv_utf8_upgrade(sv);
3490 =for apidoc sv_utf8_decode
3492 If the PV of the SV is an octet sequence in UTF-8
3493 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3494 so that it looks like a character. If the PV contains only single-byte
3495 characters, the C<SvUTF8> flag stays being off.
3496 Scans PV for validity and returns false if the PV is invalid UTF-8.
3502 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3504 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3510 /* The octets may have got themselves encoded - get them back as
3513 if (!sv_utf8_downgrade(sv, TRUE))
3516 /* it is actually just a matter of turning the utf8 flag on, but
3517 * we want to make sure everything inside is valid utf8 first.
3519 c = (const U8 *) SvPVX_const(sv);
3520 if (!is_utf8_string(c, SvCUR(sv)+1))
3522 e = (const U8 *) SvEND(sv);
3525 if (!UTF8_IS_INVARIANT(ch)) {
3535 =for apidoc sv_setsv
3537 Copies the contents of the source SV C<ssv> into the destination SV
3538 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3539 function if the source SV needs to be reused. Does not handle 'set' magic.
3540 Loosely speaking, it performs a copy-by-value, obliterating any previous
3541 content of the destination.
3543 You probably want to use one of the assortment of wrappers, such as
3544 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3545 C<SvSetMagicSV_nosteal>.
3547 =for apidoc sv_setsv_flags
3549 Copies the contents of the source SV C<ssv> into the destination SV
3550 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3551 function if the source SV needs to be reused. Does not handle 'set' magic.
3552 Loosely speaking, it performs a copy-by-value, obliterating any previous
3553 content of the destination.
3554 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3555 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3556 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3557 and C<sv_setsv_nomg> are implemented in terms of this function.
3559 You probably want to use one of the assortment of wrappers, such as
3560 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3561 C<SvSetMagicSV_nosteal>.
3563 This is the primary function for copying scalars, and most other
3564 copy-ish functions and macros use this underneath.
3570 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3572 I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3573 HV *old_stash = NULL;
3575 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3577 if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3578 const char * const name = GvNAME(sstr);
3579 const STRLEN len = GvNAMELEN(sstr);
3581 if (dtype >= SVt_PV) {
3587 SvUPGRADE(dstr, SVt_PVGV);
3588 (void)SvOK_off(dstr);
3589 /* FIXME - why are we doing this, then turning it off and on again
3591 isGV_with_GP_on(dstr);
3593 GvSTASH(dstr) = GvSTASH(sstr);
3595 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3596 gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
3597 SvFAKE_on(dstr); /* can coerce to non-glob */
3600 if(GvGP(MUTABLE_GV(sstr))) {
3601 /* If source has method cache entry, clear it */
3603 SvREFCNT_dec(GvCV(sstr));
3607 /* If source has a real method, then a method is
3609 else if(GvCV((const GV *)sstr)) {
3614 /* If dest already had a real method, that's a change as well */
3615 if(!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)) {
3619 /* We don’t need to check the name of the destination if it was not a
3620 glob to begin with. */
3621 if(dtype == SVt_PVGV) {
3622 const char * const name = GvNAME((const GV *)dstr);
3623 if(strEQ(name,"ISA"))
3626 const STRLEN len = GvNAMELEN(dstr);
3627 if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
3630 /* Set aside the old stash, so we can reset isa caches on
3632 old_stash = GvHV(dstr);
3637 gp_free(MUTABLE_GV(dstr));
3638 isGV_with_GP_off(dstr);
3639 (void)SvOK_off(dstr);
3640 isGV_with_GP_on(dstr);
3641 GvINTRO_off(dstr); /* one-shot flag */
3642 GvGP(dstr) = gp_ref(GvGP(sstr));
3643 if (SvTAINTED(sstr))
3645 if (GvIMPORTED(dstr) != GVf_IMPORTED
3646 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3648 GvIMPORTED_on(dstr);
3651 if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
3652 else if(mro_changes == 3) {
3653 HV * const stash = GvHV(dstr);
3654 if((stash && HvNAME(stash)) || (old_stash && HvNAME(old_stash)))
3656 stash && HvNAME(stash) ? stash : NULL,
3657 old_stash && HvNAME(old_stash) ? old_stash : NULL,
3661 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3666 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3668 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3670 const int intro = GvINTRO(dstr);
3673 const U32 stype = SvTYPE(sref);
3675 PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3678 GvINTRO_off(dstr); /* one-shot flag */
3679 GvLINE(dstr) = CopLINE(PL_curcop);
3680 GvEGV(dstr) = MUTABLE_GV(dstr);
3685 location = (SV **) &GvCV(dstr);
3686 import_flag = GVf_IMPORTED_CV;
3689 location = (SV **) &GvHV(dstr);
3690 import_flag = GVf_IMPORTED_HV;
3693 location = (SV **) &GvAV(dstr);
3694 import_flag = GVf_IMPORTED_AV;
3697 location = (SV **) &GvIOp(dstr);
3700 location = (SV **) &GvFORM(dstr);
3703 location = &GvSV(dstr);
3704 import_flag = GVf_IMPORTED_SV;
3707 if (stype == SVt_PVCV) {
3708 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3709 if (GvCVGEN(dstr)) {
3710 SvREFCNT_dec(GvCV(dstr));
3712 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3715 SAVEGENERICSV(*location);
3719 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3720 CV* const cv = MUTABLE_CV(*location);
3722 if (!GvCVGEN((const GV *)dstr) &&
3723 (CvROOT(cv) || CvXSUB(cv)))
3725 /* Redefining a sub - warning is mandatory if
3726 it was a const and its value changed. */
3727 if (CvCONST(cv) && CvCONST((const CV *)sref)
3729 == cv_const_sv((const CV *)sref)) {
3731 /* They are 2 constant subroutines generated from
3732 the same constant. This probably means that
3733 they are really the "same" proxy subroutine
3734 instantiated in 2 places. Most likely this is
3735 when a constant is exported twice. Don't warn.
3738 else if (ckWARN(WARN_REDEFINE)
3740 && (!CvCONST((const CV *)sref)
3741 || sv_cmp(cv_const_sv(cv),
3742 cv_const_sv((const CV *)
3744 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3747 ? "Constant subroutine %s::%s redefined"
3748 : "Subroutine %s::%s redefined"),
3749 HvNAME_get(GvSTASH((const GV *)dstr)),
3750 GvENAME(MUTABLE_GV(dstr)));
3754 cv_ckproto_len(cv, (const GV *)dstr,
3755 SvPOK(sref) ? SvPVX_const(sref) : NULL,
3756 SvPOK(sref) ? SvCUR(sref) : 0);
3758 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3759 GvASSUMECV_on(dstr);
3760 if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3763 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3764 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3765 GvFLAGS(dstr) |= import_flag;
3767 if (stype == SVt_PVHV) {
3768 const char * const name = GvNAME((GV*)dstr);
3769 const STRLEN len = GvNAMELEN(dstr);
3771 len > 1 && name[len-2] == ':' && name[len-1] == ':'
3772 && (HvNAME(dref) || HvNAME(sref))
3775 HvNAME(sref) ? (HV *)sref : NULL,
3776 HvNAME(dref) ? (HV *)dref : NULL,
3781 else if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
3782 sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3783 mro_isa_changed_in(GvSTASH(dstr));
3788 if (SvTAINTED(sstr))
3794 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3797 register U32 sflags;
3799 register svtype stype;
3801 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3806 if (SvIS_FREED(dstr)) {
3807 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3808 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3810 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3812 sstr = &PL_sv_undef;
3813 if (SvIS_FREED(sstr)) {
3814 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3815 (void*)sstr, (void*)dstr);
3817 stype = SvTYPE(sstr);
3818 dtype = SvTYPE(dstr);
3820 (void)SvAMAGIC_off(dstr);
3823 /* need to nuke the magic */
3827 /* There's a lot of redundancy below but we're going for speed here */
3832 if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
3833 (void)SvOK_off(dstr);
3841 sv_upgrade(dstr, SVt_IV);
3845 sv_upgrade(dstr, SVt_PVIV);
3849 goto end_of_first_switch;
3851 (void)SvIOK_only(dstr);
3852 SvIV_set(dstr, SvIVX(sstr));
3855 /* SvTAINTED can only be true if the SV has taint magic, which in
3856 turn means that the SV type is PVMG (or greater). This is the
3857 case statement for SVt_IV, so this cannot be true (whatever gcov
3859 assert(!SvTAINTED(sstr));
3864 if (dtype < SVt_PV && dtype != SVt_IV)
3865 sv_upgrade(dstr, SVt_IV);
3873 sv_upgrade(dstr, SVt_NV);
3877 sv_upgrade(dstr, SVt_PVNV);
3881 goto end_of_first_switch;
3883 SvNV_set(dstr, SvNVX(sstr));
3884 (void)SvNOK_only(dstr);
3885 /* SvTAINTED can only be true if the SV has taint magic, which in
3886 turn means that the SV type is PVMG (or greater). This is the
3887 case statement for SVt_NV, so this cannot be true (whatever gcov
3889 assert(!SvTAINTED(sstr));
3895 #ifdef PERL_OLD_COPY_ON_WRITE
3896 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3897 if (dtype < SVt_PVIV)
3898 sv_upgrade(dstr, SVt_PVIV);
3905 sv_upgrade(dstr, SVt_PV);
3908 if (dtype < SVt_PVIV)
3909 sv_upgrade(dstr, SVt_PVIV);
3912 if (dtype < SVt_PVNV)
3913 sv_upgrade(dstr, SVt_PVNV);
3917 const char * const type = sv_reftype(sstr,0);
3919 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
3921 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3926 if (dtype < SVt_REGEXP)
3927 sv_upgrade(dstr, SVt_REGEXP);
3930 /* case SVt_BIND: */
3933 if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
3934 glob_assign_glob(dstr, sstr, dtype);
3937 /* SvVALID means that this PVGV is playing at being an FBM. */
3941 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3943 if (SvTYPE(sstr) != stype)
3944 stype = SvTYPE(sstr);
3945 if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
3946 glob_assign_glob(dstr, sstr, dtype);
3950 if (stype == SVt_PVLV)
3951 SvUPGRADE(dstr, SVt_PVNV);
3953 SvUPGRADE(dstr, (svtype)stype);
3955 end_of_first_switch:
3957 /* dstr may have been upgraded. */
3958 dtype = SvTYPE(dstr);
3959 sflags = SvFLAGS(sstr);
3961 if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
3962 /* Assigning to a subroutine sets the prototype. */
3965 const char *const ptr = SvPV_const(sstr, len);
3967 SvGROW(dstr, len + 1);
3968 Copy(ptr, SvPVX(dstr), len + 1, char);
3969 SvCUR_set(dstr, len);
3971 SvFLAGS(dstr) |= sflags & SVf_UTF8;
3975 } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3976 const char * const type = sv_reftype(dstr,0);
3978 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
3980 Perl_croak(aTHX_ "Cannot copy to %s", type);
3981 } else if (sflags & SVf_ROK) {
3982 if (isGV_with_GP(dstr)
3983 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
3986 if (GvIMPORTED(dstr) != GVf_IMPORTED
3987 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3989 GvIMPORTED_on(dstr);
3994 glob_assign_glob(dstr, sstr, dtype);
3998 if (dtype >= SVt_PV) {
3999 if (isGV_with_GP(dstr)) {
4000 glob_assign_ref(dstr, sstr);
4003 if (SvPVX_const(dstr)) {
4009 (void)SvOK_off(dstr);
4010 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4011 SvFLAGS(dstr) |= sflags & SVf_ROK;
4012 assert(!(sflags & SVp_NOK));
4013 assert(!(sflags & SVp_IOK));
4014 assert(!(sflags & SVf_NOK));
4015 assert(!(sflags & SVf_IOK));
4017 else if (isGV_with_GP(dstr)) {
4018 if (!(sflags & SVf_OK)) {
4019 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4020 "Undefined value assigned to typeglob");
4023 GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
4024 if (dstr != (const SV *)gv) {
4025 const char * const name = GvNAME((const GV *)dstr);
4026 const STRLEN len = GvNAMELEN(dstr);
4027 HV *old_stash = NULL;
4028 bool reset_isa = FALSE;
4029 if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
4030 /* Set aside the old stash, so we can reset isa caches
4031 on its subclasses. */
4032 old_stash = GvHV(dstr);
4037 gp_free(MUTABLE_GV(dstr));
4038 GvGP(dstr) = gp_ref(GvGP(gv));
4041 HV * const stash = GvHV(dstr);
4043 (stash && HvNAME(stash))
4044 || (old_stash && HvNAME(old_stash))
4047 stash && HvNAME(stash) ? stash : NULL,
4048 old_stash && HvNAME(old_stash) ? old_stash : NULL,
4055 else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
4056 reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4058 else if (sflags & SVp_POK) {
4062 * Check to see if we can just swipe the string. If so, it's a
4063 * possible small lose on short strings, but a big win on long ones.
4064 * It might even be a win on short strings if SvPVX_const(dstr)
4065 * has to be allocated and SvPVX_const(sstr) has to be freed.
4066 * Likewise if we can set up COW rather than doing an actual copy, we
4067 * drop to the else clause, as the swipe code and the COW setup code
4068 * have much in common.
4071 /* Whichever path we take through the next code, we want this true,
4072 and doing it now facilitates the COW check. */
4073 (void)SvPOK_only(dstr);
4076 /* If we're already COW then this clause is not true, and if COW
4077 is allowed then we drop down to the else and make dest COW
4078 with us. If caller hasn't said that we're allowed to COW
4079 shared hash keys then we don't do the COW setup, even if the
4080 source scalar is a shared hash key scalar. */
4081 (((flags & SV_COW_SHARED_HASH_KEYS)
4082 ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4083 : 1 /* If making a COW copy is forbidden then the behaviour we
4084 desire is as if the source SV isn't actually already
4085 COW, even if it is. So we act as if the source flags
4086 are not COW, rather than actually testing them. */
4088 #ifndef PERL_OLD_COPY_ON_WRITE
4089 /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4090 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4091 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4092 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4093 but in turn, it's somewhat dead code, never expected to go
4094 live, but more kept as a placeholder on how to do it better
4095 in a newer implementation. */
4096 /* If we are COW and dstr is a suitable target then we drop down
4097 into the else and make dest a COW of us. */
4098 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4103 (sflags & SVs_TEMP) && /* slated for free anyway? */
4104 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4105 (!(flags & SV_NOSTEAL)) &&
4106 /* and we're allowed to steal temps */
4107 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4108 SvLEN(sstr)) /* and really is a string */
4109 #ifdef PERL_OLD_COPY_ON_WRITE
4110 && ((flags & SV_COW_SHARED_HASH_KEYS)
4111 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4112 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4113 && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4117 /* Failed the swipe test, and it's not a shared hash key either.
4118 Have to copy the string. */
4119 STRLEN len = SvCUR(sstr);
4120 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4121 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4122 SvCUR_set(dstr, len);
4123 *SvEND(dstr) = '\0';
4125 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4127 /* Either it's a shared hash key, or it's suitable for
4128 copy-on-write or we can swipe the string. */
4130 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4134 #ifdef PERL_OLD_COPY_ON_WRITE
4136 if ((sflags & (SVf_FAKE | SVf_READONLY))
4137 != (SVf_FAKE | SVf_READONLY)) {
4138 SvREADONLY_on(sstr);
4140 /* Make the source SV into a loop of 1.
4141 (about to become 2) */
4142 SV_COW_NEXT_SV_SET(sstr, sstr);
4146 /* Initial code is common. */
4147 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4152 /* making another shared SV. */
4153 STRLEN cur = SvCUR(sstr);
4154 STRLEN len = SvLEN(sstr);
4155 #ifdef PERL_OLD_COPY_ON_WRITE
4157 assert (SvTYPE(dstr) >= SVt_PVIV);
4158 /* SvIsCOW_normal */
4159 /* splice us in between source and next-after-source. */
4160 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4161 SV_COW_NEXT_SV_SET(sstr, dstr);
4162 SvPV_set(dstr, SvPVX_mutable(sstr));
4166 /* SvIsCOW_shared_hash */
4167 DEBUG_C(PerlIO_printf(Perl_debug_log,
4168 "Copy on write: Sharing hash\n"));
4170 assert (SvTYPE(dstr) >= SVt_PV);
4172 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4174 SvLEN_set(dstr, len);
4175 SvCUR_set(dstr, cur);
4176 SvREADONLY_on(dstr);
4180 { /* Passes the swipe test. */
4181 SvPV_set(dstr, SvPVX_mutable(sstr));
4182 SvLEN_set(dstr, SvLEN(sstr));
4183 SvCUR_set(dstr, SvCUR(sstr));
4186 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4187 SvPV_set(sstr, NULL);
4193 if (sflags & SVp_NOK) {
4194 SvNV_set(dstr, SvNVX(sstr));
4196 if (sflags & SVp_IOK) {
4197 SvIV_set(dstr, SvIVX(sstr));
4198 /* Must do this otherwise some other overloaded use of 0x80000000
4199 gets confused. I guess SVpbm_VALID */
4200 if (sflags & SVf_IVisUV)
4203 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4205 const MAGIC * const smg = SvVSTRING_mg(sstr);
4207 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4208 smg->mg_ptr, smg->mg_len);
4209 SvRMAGICAL_on(dstr);
4213 else if (sflags & (SVp_IOK|SVp_NOK)) {
4214 (void)SvOK_off(dstr);
4215 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4216 if (sflags & SVp_IOK) {
4217 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4218 SvIV_set(dstr, SvIVX(sstr));
4220 if (sflags & SVp_NOK) {
4221 SvNV_set(dstr, SvNVX(sstr));
4225 if (isGV_with_GP(sstr)) {
4226 /* This stringification rule for globs is spread in 3 places.
4227 This feels bad. FIXME. */
4228 const U32 wasfake = sflags & SVf_FAKE;
4230 /* FAKE globs can get coerced, so need to turn this off
4231 temporarily if it is on. */
4233 gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4234 SvFLAGS(sstr) |= wasfake;
4237 (void)SvOK_off(dstr);
4239 if (SvTAINTED(sstr))
4244 =for apidoc sv_setsv_mg
4246 Like C<sv_setsv>, but also handles 'set' magic.
4252 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4254 PERL_ARGS_ASSERT_SV_SETSV_MG;
4256 sv_setsv(dstr,sstr);
4260 #ifdef PERL_OLD_COPY_ON_WRITE
4262 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4264 STRLEN cur = SvCUR(sstr);
4265 STRLEN len = SvLEN(sstr);
4266 register char *new_pv;
4268 PERL_ARGS_ASSERT_SV_SETSV_COW;
4271 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4272 (void*)sstr, (void*)dstr);
4279 if (SvTHINKFIRST(dstr))
4280 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4281 else if (SvPVX_const(dstr))
4282 Safefree(SvPVX_const(dstr));
4286 SvUPGRADE(dstr, SVt_PVIV);
4288 assert (SvPOK(sstr));
4289 assert (SvPOKp(sstr));
4290 assert (!SvIOK(sstr));
4291 assert (!SvIOKp(sstr));
4292 assert (!SvNOK(sstr));
4293 assert (!SvNOKp(sstr));
4295 if (SvIsCOW(sstr)) {
4297 if (SvLEN(sstr) == 0) {
4298 /* source is a COW shared hash key. */
4299 DEBUG_C(PerlIO_printf(Perl_debug_log,
4300 "Fast copy on write: Sharing hash\n"));
4301 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4304 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4306 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4307 SvUPGRADE(sstr, SVt_PVIV);
4308 SvREADONLY_on(sstr);
4310 DEBUG_C(PerlIO_printf(Perl_debug_log,
4311 "Fast copy on write: Converting sstr to COW\n"));
4312 SV_COW_NEXT_SV_SET(dstr, sstr);
4314 SV_COW_NEXT_SV_SET(sstr, dstr);
4315 new_pv = SvPVX_mutable(sstr);
4318 SvPV_set(dstr, new_pv);
4319 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4322 SvLEN_set(dstr, len);
4323 SvCUR_set(dstr, cur);
4332 =for apidoc sv_setpvn
4334 Copies a string into an SV. The C<len> parameter indicates the number of
4335 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4336 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4342 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4345 register char *dptr;
4347 PERL_ARGS_ASSERT_SV_SETPVN;
4349 SV_CHECK_THINKFIRST_COW_DROP(sv);
4355 /* len is STRLEN which is unsigned, need to copy to signed */
4358 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4360 SvUPGRADE(sv, SVt_PV);
4362 dptr = SvGROW(sv, len + 1);
4363 Move(ptr,dptr,len,char);
4366 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4371 =for apidoc sv_setpvn_mg
4373 Like C<sv_setpvn>, but also handles 'set' magic.
4379 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4381 PERL_ARGS_ASSERT_SV_SETPVN_MG;
4383 sv_setpvn(sv,ptr,len);
4388 =for apidoc sv_setpv
4390 Copies a string into an SV. The string must be null-terminated. Does not
4391 handle 'set' magic. See C<sv_setpv_mg>.
4397 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4400 register STRLEN len;
4402 PERL_ARGS_ASSERT_SV_SETPV;
4404 SV_CHECK_THINKFIRST_COW_DROP(sv);
4410 SvUPGRADE(sv, SVt_PV);
4412 SvGROW(sv, len + 1);
4413 Move(ptr,SvPVX(sv),len+1,char);
4415 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4420 =for apidoc sv_setpv_mg
4422 Like C<sv_setpv>, but also handles 'set' magic.
4428 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4430 PERL_ARGS_ASSERT_SV_SETPV_MG;
4437 =for apidoc sv_usepvn_flags
4439 Tells an SV to use C<ptr> to find its string value. Normally the
4440 string is stored inside the SV but sv_usepvn allows the SV to use an
4441 outside string. The C<ptr> should point to memory that was allocated
4442 by C<malloc>. The string length, C<len>, must be supplied. By default
4443 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4444 so that pointer should not be freed or used by the programmer after
4445 giving it to sv_usepvn, and neither should any pointers from "behind"
4446 that pointer (e.g. ptr + 1) be used.
4448 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4449 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4450 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4451 C<len>, and already meets the requirements for storing in C<SvPVX>)
4457 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4462 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4464 SV_CHECK_THINKFIRST_COW_DROP(sv);
4465 SvUPGRADE(sv, SVt_PV);
4468 if (flags & SV_SMAGIC)
4472 if (SvPVX_const(sv))
4476 if (flags & SV_HAS_TRAILING_NUL)
4477 assert(ptr[len] == '\0');
4480 allocate = (flags & SV_HAS_TRAILING_NUL)
4482 #ifdef Perl_safesysmalloc_size
4485 PERL_STRLEN_ROUNDUP(len + 1);
4487 if (flags & SV_HAS_TRAILING_NUL) {
4488 /* It's long enough - do nothing.
4489 Specfically Perl_newCONSTSUB is relying on this. */
4492 /* Force a move to shake out bugs in callers. */
4493 char *new_ptr = (char*)safemalloc(allocate);
4494 Copy(ptr, new_ptr, len, char);
4495 PoisonFree(ptr,len,char);
4499 ptr = (char*) saferealloc (ptr, allocate);
4502 #ifdef Perl_safesysmalloc_size
4503 SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4505 SvLEN_set(sv, allocate);
4509 if (!(flags & SV_HAS_TRAILING_NUL)) {
4512 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4514 if (flags & SV_SMAGIC)
4518 #ifdef PERL_OLD_COPY_ON_WRITE
4519 /* Need to do this *after* making the SV normal, as we need the buffer
4520 pointer to remain valid until after we've copied it. If we let go too early,
4521 another thread could invalidate it by unsharing last of the same hash key
4522 (which it can do by means other than releasing copy-on-write Svs)
4523 or by changing the other copy-on-write SVs in the loop. */
4525 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4527 PERL_ARGS_ASSERT_SV_RELEASE_COW;
4529 { /* this SV was SvIsCOW_normal(sv) */
4530 /* we need to find the SV pointing to us. */
4531 SV *current = SV_COW_NEXT_SV(after);
4533 if (current == sv) {
4534 /* The SV we point to points back to us (there were only two of us
4536 Hence other SV is no longer copy on write either. */
4538 SvREADONLY_off(after);
4540 /* We need to follow the pointers around the loop. */
4542 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4545 /* don't loop forever if the structure is bust, and we have
4546 a pointer into a closed loop. */
4547 assert (current != after);
4548 assert (SvPVX_const(current) == pvx);
4550 /* Make the SV before us point to the SV after us. */
4551 SV_COW_NEXT_SV_SET(current, after);
4557 =for apidoc sv_force_normal_flags
4559 Undo various types of fakery on an SV: if the PV is a shared string, make
4560 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4561 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4562 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4563 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4564 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4565 set to some other value.) In addition, the C<flags> parameter gets passed to
4566 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4567 with flags set to 0.
4573 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4577 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4579 #ifdef PERL_OLD_COPY_ON_WRITE
4580 if (SvREADONLY(sv)) {
4582 const char * const pvx = SvPVX_const(sv);
4583 const STRLEN len = SvLEN(sv);
4584 const STRLEN cur = SvCUR(sv);
4585 /* next COW sv in the loop. If len is 0 then this is a shared-hash
4586 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4587 we'll fail an assertion. */
4588 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4591 PerlIO_printf(Perl_debug_log,
4592 "Copy on write: Force normal %ld\n",
4598 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4601 if (flags & SV_COW_DROP_PV) {
4602 /* OK, so we don't need to copy our buffer. */
4605 SvGROW(sv, cur + 1);
4606 Move(pvx,SvPVX(sv),cur,char);
4611 sv_release_COW(sv, pvx, next);
4613 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4619 else if (IN_PERL_RUNTIME)
4620 Perl_croak_no_modify(aTHX);
4623 if (SvREADONLY(sv)) {
4625 const char * const pvx = SvPVX_const(sv);
4626 const STRLEN len = SvCUR(sv);
4631 SvGROW(sv, len + 1);
4632 Move(pvx,SvPVX(sv),len,char);
4634 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4636 else if (IN_PERL_RUNTIME)
4637 Perl_croak_no_modify(aTHX);
4641 sv_unref_flags(sv, flags);
4642 else if (SvFAKE(sv) && isGV_with_GP(sv))
4644 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
4645 /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous
4646 to sv_unglob. We only need it here, so inline it. */
4647 const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
4648 SV *const temp = newSV_type(new_type);
4649 void *const temp_p = SvANY(sv);
4651 if (new_type == SVt_PVMG) {
4652 SvMAGIC_set(temp, SvMAGIC(sv));
4653 SvMAGIC_set(sv, NULL);
4654 SvSTASH_set(temp, SvSTASH(sv));
4655 SvSTASH_set(sv, NULL);
4657 SvCUR_set(temp, SvCUR(sv));
4658 /* Remember that SvPVX is in the head, not the body. */
4660 SvLEN_set(temp, SvLEN(sv));
4661 /* This signals "buffer is owned by someone else" in sv_clear,
4662 which is the least effort way to stop it freeing the buffer.
4664 SvLEN_set(sv, SvLEN(sv)+1);
4666 /* Their buffer is already owned by someone else. */
4667 SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
4668 SvLEN_set(temp, SvCUR(sv)+1);
4671 /* Now swap the rest of the bodies. */
4673 SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
4674 SvFLAGS(sv) |= new_type;
4675 SvANY(sv) = SvANY(temp);
4677 SvFLAGS(temp) &= ~(SVTYPEMASK);
4678 SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
4679 SvANY(temp) = temp_p;
4688 Efficient removal of characters from the beginning of the string buffer.
4689 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4690 the string buffer. The C<ptr> becomes the first character of the adjusted
4691 string. Uses the "OOK hack".
4692 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4693 refer to the same chunk of data.
4699 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4705 const U8 *real_start;
4709 PERL_ARGS_ASSERT_SV_CHOP;
4711 if (!ptr || !SvPOKp(sv))
4713 delta = ptr - SvPVX_const(sv);
4715 /* Nothing to do. */
4718 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4719 nothing uses the value of ptr any more. */
4720 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4721 if (ptr <= SvPVX_const(sv))
4722 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4723 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4724 SV_CHECK_THINKFIRST(sv);
4725 if (delta > max_delta)
4726 Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4727 SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4728 SvPVX_const(sv) + max_delta);
4731 if (!SvLEN(sv)) { /* make copy of shared string */
4732 const char *pvx = SvPVX_const(sv);
4733 const STRLEN len = SvCUR(sv);
4734 SvGROW(sv, len + 1);
4735 Move(pvx,SvPVX(sv),len,char);
4738 SvFLAGS(sv) |= SVf_OOK;
4741 SvOOK_offset(sv, old_delta);
4743 SvLEN_set(sv, SvLEN(sv) - delta);
4744 SvCUR_set(sv, SvCUR(sv) - delta);
4745 SvPV_set(sv, SvPVX(sv) + delta);
4747 p = (U8 *)SvPVX_const(sv);
4752 real_start = p - delta;
4756 if (delta < 0x100) {
4760 p -= sizeof(STRLEN);
4761 Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4765 /* Fill the preceding buffer with sentinals to verify that no-one is
4767 while (p > real_start) {
4775 =for apidoc sv_catpvn
4777 Concatenates the string onto the end of the string which is in the SV. The
4778 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4779 status set, then the bytes appended should be valid UTF-8.
4780 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4782 =for apidoc sv_catpvn_flags
4784 Concatenates the string onto the end of the string which is in the SV. The
4785 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4786 status set, then the bytes appended should be valid UTF-8.
4787 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4788 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4789 in terms of this function.
4795 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4799 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4801 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4803 SvGROW(dsv, dlen + slen + 1);
4805 sstr = SvPVX_const(dsv);
4806 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4807 SvCUR_set(dsv, SvCUR(dsv) + slen);
4809 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4811 if (flags & SV_SMAGIC)
4816 =for apidoc sv_catsv
4818 Concatenates the string from SV C<ssv> onto the end of the string in
4819 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4820 not 'set' magic. See C<sv_catsv_mg>.
4822 =for apidoc sv_catsv_flags
4824 Concatenates the string from SV C<ssv> onto the end of the string in
4825 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4826 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4827 and C<sv_catsv_nomg> are implemented in terms of this function.
4832 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4836 PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4840 const char *spv = SvPV_flags_const(ssv, slen, flags);
4842 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4843 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4844 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4845 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4846 dsv->sv_flags doesn't have that bit set.
4847 Andy Dougherty 12 Oct 2001
4849 const I32 sutf8 = DO_UTF8(ssv);
4852 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4854 dutf8 = DO_UTF8(dsv);
4856 if (dutf8 != sutf8) {
4858 /* Not modifying source SV, so taking a temporary copy. */
4859 SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4861 sv_utf8_upgrade(csv);
4862 spv = SvPV_const(csv, slen);
4865 /* Leave enough space for the cat that's about to happen */
4866 sv_utf8_upgrade_flags_grow(dsv, 0, slen);
4868 sv_catpvn_nomg(dsv, spv, slen);
4871 if (flags & SV_SMAGIC)
4876 =for apidoc sv_catpv
4878 Concatenates the string onto the end of the string which is in the SV.
4879 If the SV has the UTF-8 status set, then the bytes appended should be
4880 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4885 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4888 register STRLEN len;
4892 PERL_ARGS_ASSERT_SV_CATPV;
4896 junk = SvPV_force(sv, tlen);
4898 SvGROW(sv, tlen + len + 1);
4900 ptr = SvPVX_const(sv);
4901 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4902 SvCUR_set(sv, SvCUR(sv) + len);
4903 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4908 =for apidoc sv_catpv_flags
4910 Concatenates the string onto the end of the string which is in the SV.
4911 If the SV has the UTF-8 status set, then the bytes appended should
4912 be valid UTF-8. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get>
4913 on the SVs if appropriate, else not.
4919 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, I32 flags)
4921 PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
4922 sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
4926 =for apidoc sv_catpv_mg
4928 Like C<sv_catpv>, but also handles 'set' magic.
4934 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4936 PERL_ARGS_ASSERT_SV_CATPV_MG;
4945 Creates a new SV. A non-zero C<len> parameter indicates the number of
4946 bytes of preallocated string space the SV should have. An extra byte for a
4947 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
4948 space is allocated.) The reference count for the new SV is set to 1.
4950 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4951 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4952 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4953 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
4954 modules supporting older perls.
4960 Perl_newSV(pTHX_ const STRLEN len)
4967 sv_upgrade(sv, SVt_PV);
4968 SvGROW(sv, len + 1);
4973 =for apidoc sv_magicext
4975 Adds magic to an SV, upgrading it if necessary. Applies the
4976 supplied vtable and returns a pointer to the magic added.
4978 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4979 In particular, you can add magic to SvREADONLY SVs, and add more than
4980 one instance of the same 'how'.
4982 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4983 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4984 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4985 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4987 (This is now used as a subroutine by C<sv_magic>.)
4992 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
4993 const MGVTBL *const vtable, const char *const name, const I32 namlen)
4998 PERL_ARGS_ASSERT_SV_MAGICEXT;
5000 SvUPGRADE(sv, SVt_PVMG);
5001 Newxz(mg, 1, MAGIC);
5002 mg->mg_moremagic = SvMAGIC(sv);
5003 SvMAGIC_set(sv, mg);
5005 /* Sometimes a magic contains a reference loop, where the sv and
5006 object refer to each other. To prevent a reference loop that
5007 would prevent such objects being freed, we look for such loops
5008 and if we find one we avoid incrementing the object refcount.
5010 Note we cannot do this to avoid self-tie loops as intervening RV must
5011 have its REFCNT incremented to keep it in existence.
5014 if (!obj || obj == sv ||
5015 how == PERL_MAGIC_arylen ||
5016 how == PERL_MAGIC_symtab ||
5017 (SvTYPE(obj) == SVt_PVGV &&
5018 (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5019 || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5020 || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5025 mg->mg_obj = SvREFCNT_inc_simple(obj);
5026 mg->mg_flags |= MGf_REFCOUNTED;
5029 /* Normal self-ties simply pass a null object, and instead of
5030 using mg_obj directly, use the SvTIED_obj macro to produce a
5031 new RV as needed. For glob "self-ties", we are tieing the PVIO
5032 with an RV obj pointing to the glob containing the PVIO. In
5033 this case, to avoid a reference loop, we need to weaken the
5037 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5038 obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5044 mg->mg_len = namlen;
5047 mg->mg_ptr = savepvn(name, namlen);
5048 else if (namlen == HEf_SVKEY) {
5049 /* Yes, this is casting away const. This is only for the case of
5050 HEf_SVKEY. I think we need to document this abberation of the
5051 constness of the API, rather than making name non-const, as
5052 that change propagating outwards a long way. */
5053 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5055 mg->mg_ptr = (char *) name;
5057 mg->mg_virtual = (MGVTBL *) vtable;
5061 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5066 =for apidoc sv_magic
5068 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5069 then adds a new magic item of type C<how> to the head of the magic list.
5071 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5072 handling of the C<name> and C<namlen> arguments.
5074 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5075 to add more than one instance of the same 'how'.
5081 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
5082 const char *const name, const I32 namlen)
5085 const MGVTBL *vtable;
5088 PERL_ARGS_ASSERT_SV_MAGIC;
5090 #ifdef PERL_OLD_COPY_ON_WRITE
5092 sv_force_normal_flags(sv, 0);
5094 if (SvREADONLY(sv)) {
5096 /* its okay to attach magic to shared strings; the subsequent
5097 * upgrade to PVMG will unshare the string */
5098 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
5101 && how != PERL_MAGIC_regex_global
5102 && how != PERL_MAGIC_bm
5103 && how != PERL_MAGIC_fm
5104 && how != PERL_MAGIC_sv
5105 && how != PERL_MAGIC_backref
5108 Perl_croak_no_modify(aTHX);
5111 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5112 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5113 /* sv_magic() refuses to add a magic of the same 'how' as an
5116 if (how == PERL_MAGIC_taint) {
5118 /* Any scalar which already had taint magic on which someone
5119 (erroneously?) did SvIOK_on() or similar will now be
5120 incorrectly sporting public "OK" flags. */
5121 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5129 vtable = &PL_vtbl_sv;
5131 case PERL_MAGIC_overload:
5132 vtable = &PL_vtbl_amagic;
5134 case PERL_MAGIC_overload_elem:
5135 vtable = &PL_vtbl_amagicelem;
5137 case PERL_MAGIC_overload_table:
5138 vtable = &PL_vtbl_ovrld;
5141 vtable = &PL_vtbl_bm;
5143 case PERL_MAGIC_regdata:
5144 vtable = &PL_vtbl_regdata;
5146 case PERL_MAGIC_regdatum:
5147 vtable = &PL_vtbl_regdatum;
5149 case PERL_MAGIC_env:
5150 vtable = &PL_vtbl_env;
5153 vtable = &PL_vtbl_fm;
5155 case PERL_MAGIC_envelem:
5156 vtable = &PL_vtbl_envelem;
5158 case PERL_MAGIC_regex_global:
5159 vtable = &PL_vtbl_mglob;
5161 case PERL_MAGIC_isa:
5162 vtable = &PL_vtbl_isa;
5164 case PERL_MAGIC_isaelem:
5165 vtable = &PL_vtbl_isaelem;
5167 case PERL_MAGIC_nkeys:
5168 vtable = &PL_vtbl_nkeys;
5170 case PERL_MAGIC_dbfile:
5173 case PERL_MAGIC_dbline:
5174 vtable = &PL_vtbl_dbline;
5176 #ifdef USE_LOCALE_COLLATE
5177 case PERL_MAGIC_collxfrm:
5178 vtable = &PL_vtbl_collxfrm;
5180 #endif /* USE_LOCALE_COLLATE */
5181 case PERL_MAGIC_tied:
5182 vtable = &PL_vtbl_pack;
5184 case PERL_MAGIC_tiedelem:
5185 case PERL_MAGIC_tiedscalar:
5186 vtable = &PL_vtbl_packelem;
5189 vtable = &PL_vtbl_regexp;
5191 case PERL_MAGIC_sig:
5192 vtable = &PL_vtbl_sig;
5194 case PERL_MAGIC_sigelem:
5195 vtable = &PL_vtbl_sigelem;
5197 case PERL_MAGIC_taint:
5198 vtable = &PL_vtbl_taint;
5200 case PERL_MAGIC_uvar:
5201 vtable = &PL_vtbl_uvar;
5203 case PERL_MAGIC_vec:
5204 vtable = &PL_vtbl_vec;
5206 case PERL_MAGIC_arylen_p:
5207 case PERL_MAGIC_rhash:
5208 case PERL_MAGIC_symtab:
5209 case PERL_MAGIC_vstring:
5210 case PERL_MAGIC_checkcall:
5213 case PERL_MAGIC_utf8:
5214 vtable = &PL_vtbl_utf8;
5216 case PERL_MAGIC_substr:
5217 vtable = &PL_vtbl_substr;
5219 case PERL_MAGIC_defelem:
5220 vtable = &PL_vtbl_defelem;
5222 case PERL_MAGIC_arylen:
5223 vtable = &PL_vtbl_arylen;
5225 case PERL_MAGIC_pos:
5226 vtable = &PL_vtbl_pos;
5228 case PERL_MAGIC_backref:
5229 vtable = &PL_vtbl_backref;
5231 case PERL_MAGIC_hintselem:
5232 vtable = &PL_vtbl_hintselem;
5234 case PERL_MAGIC_hints:
5235 vtable = &PL_vtbl_hints;
5237 case PERL_MAGIC_ext:
5238 /* Reserved for use by extensions not perl internals. */
5239 /* Useful for attaching extension internal data to perl vars. */
5240 /* Note that multiple extensions may clash if magical scalars */
5241 /* etc holding private data from one are passed to another. */
5245 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5248 /* Rest of work is done else where */
5249 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5252 case PERL_MAGIC_taint:
5255 case PERL_MAGIC_ext:
5256 case PERL_MAGIC_dbfile:
5263 =for apidoc sv_unmagic
5265 Removes all magic of type C<type> from an SV.
5271 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5276 PERL_ARGS_ASSERT_SV_UNMAGIC;
5278 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5280 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5281 for (mg = *mgp; mg; mg = *mgp) {
5282 if (mg->mg_type == type) {
5283 const MGVTBL* const vtbl = mg->mg_virtual;
5284 *mgp = mg->mg_moremagic;
5285 if (vtbl && vtbl->svt_free)
5286 vtbl->svt_free(aTHX_ sv, mg);
5287 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5289 Safefree(mg->mg_ptr);
5290 else if (mg->mg_len == HEf_SVKEY)
5291 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5292 else if (mg->mg_type == PERL_MAGIC_utf8)
5293 Safefree(mg->mg_ptr);
5295 if (mg->mg_flags & MGf_REFCOUNTED)
5296 SvREFCNT_dec(mg->mg_obj);
5300 mgp = &mg->mg_moremagic;
5303 if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
5304 mg_magical(sv); /* else fix the flags now */
5308 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5314 =for apidoc sv_rvweaken
5316 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5317 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5318 push a back-reference to this RV onto the array of backreferences
5319 associated with that magic. If the RV is magical, set magic will be
5320 called after the RV is cleared.
5326 Perl_sv_rvweaken(pTHX_ SV *const sv)
5330 PERL_ARGS_ASSERT_SV_RVWEAKEN;
5332 if (!SvOK(sv)) /* let undefs pass */
5335 Perl_croak(aTHX_ "Can't weaken a nonreference");
5336 else if (SvWEAKREF(sv)) {
5337 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5341 Perl_sv_add_backref(aTHX_ tsv, sv);
5347 /* Give tsv backref magic if it hasn't already got it, then push a
5348 * back-reference to sv onto the array associated with the backref magic.
5350 * As an optimisation, if there's only one backref and it's not an AV,
5351 * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5352 * allocate an AV. (Whether the slot holds an AV tells us whether this is
5355 * If an HV's backref is stored in magic, it is moved back to HvAUX.
5358 /* A discussion about the backreferences array and its refcount:
5360 * The AV holding the backreferences is pointed to either as the mg_obj of
5361 * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
5362 * structure, from the xhv_backreferences field. (A HV without hv_aux will
5363 * have the standard magic instead.) The array is created with a refcount
5364 * of 2. This means that if during global destruction the array gets
5365 * picked on before its parent to have its refcount decremented by the
5366 * random zapper, it won't actually be freed, meaning it's still there for
5367 * when its parent gets freed.
5369 * When the parent SV is freed, the extra ref is killed by
5370 * Perl_sv_kill_backrefs. The other ref is killed, in the case of magic,
5371 * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5373 * When a single backref SV is stored directly, it is not reference
5378 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5385 PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5387 /* find slot to store array or singleton backref */
5389 if (SvTYPE(tsv) == SVt_PVHV) {
5390 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5393 if ((mg = mg_find(tsv, PERL_MAGIC_backref))) {
5394 /* Aha. They've got it stowed in magic instead.
5395 * Move it back to xhv_backreferences */
5397 /* Stop mg_free decreasing the reference count. */
5399 /* Stop mg_free even calling the destructor, given that
5400 there's no AV to free up. */
5402 sv_unmagic(tsv, PERL_MAGIC_backref);
5408 (SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
5410 sv_magic(tsv, NULL, PERL_MAGIC_backref, NULL, 0);
5411 mg = mg_find(tsv, PERL_MAGIC_backref);
5413 svp = &(mg->mg_obj);
5416 /* create or retrieve the array */
5418 if ( (!*svp && SvTYPE(sv) == SVt_PVAV)
5419 || (*svp && SvTYPE(*svp) != SVt_PVAV)
5424 SvREFCNT_inc_simple_void(av);
5425 /* av now has a refcnt of 2; see discussion above */
5427 /* move single existing backref to the array */
5429 AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5433 mg->mg_flags |= MGf_REFCOUNTED;
5436 av = MUTABLE_AV(*svp);
5439 /* optimisation: store single backref directly in HvAUX or mg_obj */
5443 /* push new backref */
5444 assert(SvTYPE(av) == SVt_PVAV);
5445 if (AvFILLp(av) >= AvMAX(av)) {
5446 av_extend(av, AvFILLp(av)+1);
5448 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5451 /* delete a back-reference to ourselves from the backref magic associated
5452 * with the SV we point to.
5456 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5462 PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5464 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5465 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5467 if (!svp || !*svp) {
5469 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5470 svp = mg ? &(mg->mg_obj) : NULL;
5474 Perl_croak(aTHX_ "panic: del_backref");
5476 if (SvTYPE(*svp) == SVt_PVAV) {
5478 AV * const av = (AV*)*svp;
5479 assert(!SvIS_FREED(av));
5481 for (i = AvFILLp(av); i >= 0; i--) {
5483 const SSize_t fill = AvFILLp(av);
5485 /* We weren't the last entry.
5486 An unordered list has this property that you can take the
5487 last element off the end to fill the hole, and it's still
5488 an unordered list :-)
5493 AvFILLp(av) = fill - 1;
5496 break; /* should only be one */
5503 /* optimisation: only a single backref, stored directly */
5505 Perl_croak(aTHX_ "panic: del_backref");
5512 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5518 PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5523 is_array = (SvTYPE(av) == SVt_PVAV);
5525 assert(!SvIS_FREED(av));
5528 last = svp + AvFILLp(av);
5531 /* optimisation: only a single backref, stored directly */
5537 while (svp <= last) {
5539 SV *const referrer = *svp;
5540 if (SvWEAKREF(referrer)) {
5541 /* XXX Should we check that it hasn't changed? */
5542 assert(SvROK(referrer));
5543 SvRV_set(referrer, 0);
5545 SvWEAKREF_off(referrer);
5546 SvSETMAGIC(referrer);
5547 } else if (SvTYPE(referrer) == SVt_PVGV ||
5548 SvTYPE(referrer) == SVt_PVLV) {
5549 assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
5550 /* You lookin' at me? */
5551 assert(GvSTASH(referrer));
5552 assert(GvSTASH(referrer) == (const HV *)sv);
5553 GvSTASH(referrer) = 0;
5554 } else if (SvTYPE(referrer) == SVt_PVCV ||
5555 SvTYPE(referrer) == SVt_PVFM) {
5556 if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
5557 /* You lookin' at me? */
5558 assert(CvSTASH(referrer));
5559 assert(CvSTASH(referrer) == (const HV *)sv);
5560 CvSTASH(referrer) = 0;
5563 assert(SvTYPE(sv) == SVt_PVGV);
5564 /* You lookin' at me? */
5565 assert(CvGV(referrer));
5566 assert(CvGV(referrer) == (const GV *)sv);
5567 anonymise_cv_maybe(MUTABLE_GV(sv),
5568 MUTABLE_CV(referrer));
5573 "panic: magic_killbackrefs (flags=%"UVxf")",
5574 (UV)SvFLAGS(referrer));
5585 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5591 =for apidoc sv_insert
5593 Inserts a string at the specified offset/length within the SV. Similar to
5594 the Perl substr() function. Handles get magic.
5596 =for apidoc sv_insert_flags
5598 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5604 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5609 register char *midend;
5610 register char *bigend;
5614 PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5617 Perl_croak(aTHX_ "Can't modify non-existent substring");
5618 SvPV_force_flags(bigstr, curlen, flags);
5619 (void)SvPOK_only_UTF8(bigstr);
5620 if (offset + len > curlen) {
5621 SvGROW(bigstr, offset+len+1);
5622 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5623 SvCUR_set(bigstr, offset+len);
5627 i = littlelen - len;
5628 if (i > 0) { /* string might grow */
5629 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5630 mid = big + offset + len;
5631 midend = bigend = big + SvCUR(bigstr);
5634 while (midend > mid) /* shove everything down */
5635 *--bigend = *--midend;
5636 Move(little,big+offset,littlelen,char);
5637 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5642 Move(little,SvPVX(bigstr)+offset,len,char);
5647 big = SvPVX(bigstr);
5650 bigend = big + SvCUR(bigstr);
5652 if (midend > bigend)
5653 Perl_croak(aTHX_ "panic: sv_insert");
5655 if (mid - big > bigend - midend) { /* faster to shorten from end */
5657 Move(little, mid, littlelen,char);
5660 i = bigend - midend;
5662 Move(midend, mid, i,char);
5666 SvCUR_set(bigstr, mid - big);
5668 else if ((i = mid - big)) { /* faster from front */
5669 midend -= littlelen;
5671 Move(big, midend - i, i, char);
5672 sv_chop(bigstr,midend-i);
5674 Move(little, mid, littlelen,char);
5676 else if (littlelen) {
5677 midend -= littlelen;
5678 sv_chop(bigstr,midend);
5679 Move(little,midend,littlelen,char);
5682 sv_chop(bigstr,midend);
5688 =for apidoc sv_replace
5690 Make the first argument a copy of the second, then delete the original.
5691 The target SV physically takes over ownership of the body of the source SV
5692 and inherits its flags; however, the target keeps any magic it owns,
5693 and any magic in the source is discarded.
5694 Note that this is a rather specialist SV copying operation; most of the
5695 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5701 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5704 const U32 refcnt = SvREFCNT(sv);
5706 PERL_ARGS_ASSERT_SV_REPLACE;
5708 SV_CHECK_THINKFIRST_COW_DROP(sv);
5709 if (SvREFCNT(nsv) != 1) {
5710 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
5711 " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
5713 if (SvMAGICAL(sv)) {
5717 sv_upgrade(nsv, SVt_PVMG);
5718 SvMAGIC_set(nsv, SvMAGIC(sv));
5719 SvFLAGS(nsv) |= SvMAGICAL(sv);
5721 SvMAGIC_set(sv, NULL);
5725 assert(!SvREFCNT(sv));
5726 #ifdef DEBUG_LEAKING_SCALARS
5727 sv->sv_flags = nsv->sv_flags;
5728 sv->sv_any = nsv->sv_any;
5729 sv->sv_refcnt = nsv->sv_refcnt;
5730 sv->sv_u = nsv->sv_u;
5732 StructCopy(nsv,sv,SV);
5734 if(SvTYPE(sv) == SVt_IV) {
5736 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5740 #ifdef PERL_OLD_COPY_ON_WRITE
5741 if (SvIsCOW_normal(nsv)) {
5742 /* We need to follow the pointers around the loop to make the
5743 previous SV point to sv, rather than nsv. */
5746 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5749 assert(SvPVX_const(current) == SvPVX_const(nsv));
5751 /* Make the SV before us point to the SV after us. */
5753 PerlIO_printf(Perl_debug_log, "previous is\n");
5755 PerlIO_printf(Perl_debug_log,
5756 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5757 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5759 SV_COW_NEXT_SV_SET(current, sv);
5762 SvREFCNT(sv) = refcnt;
5763 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5768 /* We're about to free a GV which has a CV that refers back to us.
5769 * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
5773 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
5779 PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
5782 assert(SvREFCNT(gv) == 0);
5783 assert(isGV(gv) && isGV_with_GP(gv));
5785 assert(!CvANON(cv));
5786 assert(CvGV(cv) == gv);
5788 /* will the CV shortly be freed by gp_free() ? */
5789 if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
5790 SvANY(cv)->xcv_gv = NULL;
5794 /* if not, anonymise: */
5795 stash = GvSTASH(gv) ? HvNAME(GvSTASH(gv)) : NULL;
5796 gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
5797 stash ? stash : "__ANON__");
5798 anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
5799 SvREFCNT_dec(gvname);
5803 SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
5808 =for apidoc sv_clear
5810 Clear an SV: call any destructors, free up any memory used by the body,
5811 and free the body itself. The SV's head is I<not> freed, although
5812 its type is set to all 1's so that it won't inadvertently be assumed
5813 to be live during global destruction etc.
5814 This function should only be called when REFCNT is zero. Most of the time
5815 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5822 Perl_sv_clear(pTHX_ SV *const orig_sv)
5827 const struct body_details *sv_type_details;
5830 register SV *sv = orig_sv;
5832 PERL_ARGS_ASSERT_SV_CLEAR;
5834 /* within this loop, sv is the SV currently being freed, and
5835 * iter_sv is the most recent AV or whatever that's being iterated
5836 * over to provide more SVs */
5842 assert(SvREFCNT(sv) == 0);
5843 assert(SvTYPE(sv) != SVTYPEMASK);
5845 if (type <= SVt_IV) {
5846 /* See the comment in sv.h about the collusion between this
5847 * early return and the overloading of the NULL slots in the
5851 SvFLAGS(sv) &= SVf_BREAK;
5852 SvFLAGS(sv) |= SVTYPEMASK;
5857 if (PL_defstash && /* Still have a symbol table? */
5864 stash = SvSTASH(sv);
5865 destructor = StashHANDLER(stash,DESTROY);
5867 /* A constant subroutine can have no side effects, so
5868 don't bother calling it. */
5869 && !CvCONST(destructor)
5870 /* Don't bother calling an empty destructor */
5871 && (CvISXSUB(destructor)
5872 || (CvSTART(destructor)
5873 && (CvSTART(destructor)->op_next->op_type
5876 SV* const tmpref = newRV(sv);
5877 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5879 PUSHSTACKi(PERLSI_DESTROY);
5884 call_sv(MUTABLE_SV(destructor),
5885 G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5889 if(SvREFCNT(tmpref) < 2) {
5890 /* tmpref is not kept alive! */
5892 SvRV_set(tmpref, NULL);
5895 SvREFCNT_dec(tmpref);
5897 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5901 if (PL_in_clean_objs)
5903 "DESTROY created new reference to dead object '%s'",
5905 /* DESTROY gave object new lease on life */
5911 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5912 SvOBJECT_off(sv); /* Curse the object. */
5913 if (type != SVt_PVIO)
5914 --PL_sv_objcount;/* XXX Might want something more general */
5917 if (type >= SVt_PVMG) {
5918 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
5919 SvREFCNT_dec(SvOURSTASH(sv));
5920 } else if (SvMAGIC(sv))
5922 if (type == SVt_PVMG && SvPAD_TYPED(sv))
5923 SvREFCNT_dec(SvSTASH(sv));
5926 /* case SVt_BIND: */
5929 IoIFP(sv) != PerlIO_stdin() &&
5930 IoIFP(sv) != PerlIO_stdout() &&
5931 IoIFP(sv) != PerlIO_stderr() &&
5932 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5934 io_close(MUTABLE_IO(sv), FALSE);
5936 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5937 PerlDir_close(IoDIRP(sv));
5938 IoDIRP(sv) = (DIR*)NULL;
5939 Safefree(IoTOP_NAME(sv));
5940 Safefree(IoFMT_NAME(sv));
5941 Safefree(IoBOTTOM_NAME(sv));
5944 /* FIXME for plugins */
5945 pregfree2((REGEXP*) sv);
5949 cv_undef(MUTABLE_CV(sv));
5950 /* If we're in a stash, we don't own a reference to it.
5951 * However it does have a back reference to us, which needs to
5953 if ((stash = CvSTASH(sv)))
5954 sv_del_backref(MUTABLE_SV(stash), sv);
5957 if (PL_last_swash_hv == (const HV *)sv) {
5958 PL_last_swash_hv = NULL;
5960 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
5961 hv_undef(MUTABLE_HV(sv));
5965 AV* av = MUTABLE_AV(sv);
5966 if (PL_comppad == av) {
5970 if (AvREAL(av) && AvFILLp(av) > -1) {
5971 next_sv = AvARRAY(av)[AvFILLp(av)--];
5972 /* save old iter_sv in top-most slot of AV,
5973 * and pray that it doesn't get wiped in the meantime */
5974 AvARRAY(av)[AvMAX(av)] = iter_sv;
5976 goto get_next_sv; /* process this new sv */
5978 Safefree(AvALLOC(av));
5983 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5984 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5985 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5986 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5988 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5989 SvREFCNT_dec(LvTARG(sv));
5991 if (isGV_with_GP(sv)) {
5992 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
5993 && HvNAME_get(stash))
5994 mro_method_changed_in(stash);
5995 gp_free(MUTABLE_GV(sv));
5997 unshare_hek(GvNAME_HEK(sv));
5998 /* If we're in a stash, we don't own a reference to it.
5999 * However it does have a back reference to us, which
6000 * needs to be cleared. */
6001 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
6002 sv_del_backref(MUTABLE_SV(stash), sv);
6004 /* FIXME. There are probably more unreferenced pointers to SVs
6005 * in the interpreter struct that we should check and tidy in
6006 * a similar fashion to this: */
6007 if ((const GV *)sv == PL_last_in_gv)
6008 PL_last_in_gv = NULL;
6014 /* Don't bother with SvOOK_off(sv); as we're only going to
6018 SvOOK_offset(sv, offset);
6019 SvPV_set(sv, SvPVX_mutable(sv) - offset);
6020 /* Don't even bother with turning off the OOK flag. */
6025 SV * const target = SvRV(sv);
6027 sv_del_backref(target, sv);
6032 #ifdef PERL_OLD_COPY_ON_WRITE
6033 else if (SvPVX_const(sv)
6034 && !(SvTYPE(sv) == SVt_PVIO
6035 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6039 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6043 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
6045 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6049 } else if (SvLEN(sv)) {
6050 Safefree(SvPVX_const(sv));
6054 else if (SvPVX_const(sv) && SvLEN(sv)
6055 && !(SvTYPE(sv) == SVt_PVIO
6056 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6057 Safefree(SvPVX_mutable(sv));
6058 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
6059 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6070 SvFLAGS(sv) &= SVf_BREAK;
6071 SvFLAGS(sv) |= SVTYPEMASK;
6073 sv_type_details = bodies_by_type + type;
6074 if (sv_type_details->arena) {
6075 del_body(((char *)SvANY(sv) + sv_type_details->offset),
6076 &PL_body_roots[type]);
6078 else if (sv_type_details->body_size) {
6079 safefree(SvANY(sv));
6083 /* caller is responsible for freeing the head of the original sv */
6084 if (sv != orig_sv && !SvREFCNT(sv))
6087 /* grab and free next sv, if any */
6095 else if (!iter_sv) {
6097 } else if (SvTYPE(iter_sv) == SVt_PVAV) {
6098 AV *const av = (AV*)iter_sv;
6099 if (AvFILLp(av) > -1) {
6100 sv = AvARRAY(av)[AvFILLp(av)--];
6102 else { /* no more elements of current AV to free */
6105 /* restore previous value, squirrelled away */
6106 iter_sv = AvARRAY(av)[AvMAX(av)];
6107 Safefree(AvALLOC(av));
6112 /* unrolled SvREFCNT_dec and sv_free2 follows: */
6116 if (!SvREFCNT(sv)) {
6120 if (--(SvREFCNT(sv)))
6124 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6125 "Attempt to free temp prematurely: SV 0x%"UVxf
6126 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6130 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6131 /* make sure SvREFCNT(sv)==0 happens very seldom */
6132 SvREFCNT(sv) = (~(U32)0)/2;
6142 =for apidoc sv_newref
6144 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6151 Perl_sv_newref(pTHX_ SV *const sv)
6153 PERL_UNUSED_CONTEXT;
6162 Decrement an SV's reference count, and if it drops to zero, call
6163 C<sv_clear> to invoke destructors and free up any memory used by
6164 the body; finally, deallocate the SV's head itself.
6165 Normally called via a wrapper macro C<SvREFCNT_dec>.
6171 Perl_sv_free(pTHX_ SV *const sv)
6176 if (SvREFCNT(sv) == 0) {
6177 if (SvFLAGS(sv) & SVf_BREAK)
6178 /* this SV's refcnt has been artificially decremented to
6179 * trigger cleanup */
6181 if (PL_in_clean_all) /* All is fair */
6183 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6184 /* make sure SvREFCNT(sv)==0 happens very seldom */
6185 SvREFCNT(sv) = (~(U32)0)/2;
6188 if (ckWARN_d(WARN_INTERNAL)) {
6189 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
6190 Perl_dump_sv_child(aTHX_ sv);
6192 #ifdef DEBUG_LEAKING_SCALARS
6195 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6196 if (PL_warnhook == PERL_WARNHOOK_FATAL
6197 || ckDEAD(packWARN(WARN_INTERNAL))) {
6198 /* Don't let Perl_warner cause us to escape our fate: */
6202 /* This may not return: */
6203 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6204 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6205 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6208 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6213 if (--(SvREFCNT(sv)) > 0)
6215 Perl_sv_free2(aTHX_ sv);
6219 Perl_sv_free2(pTHX_ SV *const sv)
6223 PERL_ARGS_ASSERT_SV_FREE2;
6227 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6228 "Attempt to free temp prematurely: SV 0x%"UVxf
6229 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6233 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6234 /* make sure SvREFCNT(sv)==0 happens very seldom */
6235 SvREFCNT(sv) = (~(U32)0)/2;
6246 Returns the length of the string in the SV. Handles magic and type
6247 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6253 Perl_sv_len(pTHX_ register SV *const sv)
6261 len = mg_length(sv);
6263 (void)SvPV_const(sv, len);
6268 =for apidoc sv_len_utf8
6270 Returns the number of characters in the string in an SV, counting wide
6271 UTF-8 bytes as a single character. Handles magic and type coercion.
6277 * The length is cached in PERL_MAGIC_utf8, in the mg_len field. Also the
6278 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6279 * (Note that the mg_len is not the length of the mg_ptr field.
6280 * This allows the cache to store the character length of the string without
6281 * needing to malloc() extra storage to attach to the mg_ptr.)
6286 Perl_sv_len_utf8(pTHX_ register SV *const sv)
6292 return mg_length(sv);
6296 const U8 *s = (U8*)SvPV_const(sv, len);
6300 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6302 if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
6303 if (mg->mg_len != -1)
6306 /* We can use the offset cache for a headstart.
6307 The longer value is stored in the first pair. */
6308 STRLEN *cache = (STRLEN *) mg->mg_ptr;
6310 ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
6314 if (PL_utf8cache < 0) {
6315 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6316 assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
6320 ulen = Perl_utf8_length(aTHX_ s, s + len);
6321 utf8_mg_len_cache_update(sv, &mg, ulen);
6325 return Perl_utf8_length(aTHX_ s, s + len);
6329 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6332 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6333 STRLEN *const uoffset_p, bool *const at_end)
6335 const U8 *s = start;
6336 STRLEN uoffset = *uoffset_p;
6338 PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6340 while (s < send && uoffset) {
6347 else if (s > send) {
6349 /* This is the existing behaviour. Possibly it should be a croak, as
6350 it's actually a bounds error */
6353 *uoffset_p -= uoffset;
6357 /* Given the length of the string in both bytes and UTF-8 characters, decide
6358 whether to walk forwards or backwards to find the byte corresponding to
6359 the passed in UTF-8 offset. */
6361 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6362 STRLEN uoffset, const STRLEN uend)
6364 STRLEN backw = uend - uoffset;
6366 PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6368 if (uoffset < 2 * backw) {
6369 /* The assumption is that going forwards is twice the speed of going
6370 forward (that's where the 2 * backw comes from).
6371 (The real figure of course depends on the UTF-8 data.) */
6372 const U8 *s = start;
6374 while (s < send && uoffset--)
6384 while (UTF8_IS_CONTINUATION(*send))
6387 return send - start;
6390 /* For the string representation of the given scalar, find the byte
6391 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
6392 give another position in the string, *before* the sought offset, which
6393 (which is always true, as 0, 0 is a valid pair of positions), which should
6394 help reduce the amount of linear searching.
6395 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6396 will be used to reduce the amount of linear searching. The cache will be
6397 created if necessary, and the found value offered to it for update. */
6399 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6400 const U8 *const send, STRLEN uoffset,
6401 STRLEN uoffset0, STRLEN boffset0)
6403 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
6405 bool at_end = FALSE;
6407 PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6409 assert (uoffset >= uoffset0);
6416 && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
6417 (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
6418 if ((*mgp)->mg_ptr) {
6419 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6420 if (cache[0] == uoffset) {
6421 /* An exact match. */
6424 if (cache[2] == uoffset) {
6425 /* An exact match. */
6429 if (cache[0] < uoffset) {
6430 /* The cache already knows part of the way. */
6431 if (cache[0] > uoffset0) {
6432 /* The cache knows more than the passed in pair */
6433 uoffset0 = cache[0];
6434 boffset0 = cache[1];
6436 if ((*mgp)->mg_len != -1) {
6437 /* And we know the end too. */
6439 + sv_pos_u2b_midway(start + boffset0, send,
6441 (*mgp)->mg_len - uoffset0);
6443 uoffset -= uoffset0;
6445 + sv_pos_u2b_forwards(start + boffset0,
6446 send, &uoffset, &at_end);
6447 uoffset += uoffset0;
6450 else if (cache[2] < uoffset) {
6451 /* We're between the two cache entries. */
6452 if (cache[2] > uoffset0) {
6453 /* and the cache knows more than the passed in pair */
6454 uoffset0 = cache[2];
6455 boffset0 = cache[3];
6459 + sv_pos_u2b_midway(start + boffset0,
6462 cache[0] - uoffset0);
6465 + sv_pos_u2b_midway(start + boffset0,
6468 cache[2] - uoffset0);
6472 else if ((*mgp)->mg_len != -1) {
6473 /* If we can take advantage of a passed in offset, do so. */
6474 /* In fact, offset0 is either 0, or less than offset, so don't
6475 need to worry about the other possibility. */
6477 + sv_pos_u2b_midway(start + boffset0, send,
6479 (*mgp)->mg_len - uoffset0);
6484 if (!found || PL_utf8cache < 0) {
6485 STRLEN real_boffset;
6486 uoffset -= uoffset0;
6487 real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6488 send, &uoffset, &at_end);
6489 uoffset += uoffset0;
6491 if (found && PL_utf8cache < 0)
6492 assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
6494 boffset = real_boffset;
6499 utf8_mg_len_cache_update(sv, mgp, uoffset);
6501 utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6508 =for apidoc sv_pos_u2b_flags
6510 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6511 the start of the string, to a count of the equivalent number of bytes; if
6512 lenp is non-zero, it does the same to lenp, but this time starting from
6513 the offset, rather than from the start of the string. Handles type coercion.
6514 I<flags> is passed to C<SvPV_flags>, and usually should be
6515 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
6521 * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
6522 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6523 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6528 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
6535 PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
6537 start = (U8*)SvPV_flags(sv, len, flags);
6539 const U8 * const send = start + len;
6541 boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
6544 && *lenp /* don't bother doing work for 0, as its bytes equivalent
6545 is 0, and *lenp is already set to that. */) {
6546 /* Convert the relative offset to absolute. */
6547 const STRLEN uoffset2 = uoffset + *lenp;
6548 const STRLEN boffset2
6549 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6550 uoffset, boffset) - boffset;
6564 =for apidoc sv_pos_u2b
6566 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6567 the start of the string, to a count of the equivalent number of bytes; if
6568 lenp is non-zero, it does the same to lenp, but this time starting from
6569 the offset, rather than from the start of the string. Handles magic and
6572 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
6579 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6580 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6581 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6585 /* This function is subject to size and sign problems */
6588 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6590 PERL_ARGS_ASSERT_SV_POS_U2B;
6593 STRLEN ulen = (STRLEN)*lenp;
6594 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
6595 SV_GMAGIC|SV_CONST_RETURN);
6598 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
6599 SV_GMAGIC|SV_CONST_RETURN);
6604 S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
6607 PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
6611 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6612 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6613 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
6617 (*mgp)->mg_len = ulen;
6618 /* For now, treat "overflowed" as "still unknown". See RT #72924. */
6619 if (ulen != (STRLEN) (*mgp)->mg_len)
6620 (*mgp)->mg_len = -1;
6623 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6624 byte length pairing. The (byte) length of the total SV is passed in too,
6625 as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6626 may not have updated SvCUR, so we can't rely on reading it directly.
6628 The proffered utf8/byte length pairing isn't used if the cache already has
6629 two pairs, and swapping either for the proffered pair would increase the
6630 RMS of the intervals between known byte offsets.
6632 The cache itself consists of 4 STRLEN values
6633 0: larger UTF-8 offset
6634 1: corresponding byte offset
6635 2: smaller UTF-8 offset
6636 3: corresponding byte offset
6638 Unused cache pairs have the value 0, 0.
6639 Keeping the cache "backwards" means that the invariant of
6640 cache[0] >= cache[2] is maintained even with empty slots, which means that
6641 the code that uses it doesn't need to worry if only 1 entry has actually
6642 been set to non-zero. It also makes the "position beyond the end of the
6643 cache" logic much simpler, as the first slot is always the one to start
6647 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6648 const STRLEN utf8, const STRLEN blen)
6652 PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6657 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6658 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6659 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6661 (*mgp)->mg_len = -1;
6665 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6666 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6667 (*mgp)->mg_ptr = (char *) cache;
6671 if (PL_utf8cache < 0 && SvPOKp(sv)) {
6672 /* SvPOKp() because it's possible that sv has string overloading, and
6673 therefore is a reference, hence SvPVX() is actually a pointer.
6674 This cures the (very real) symptoms of RT 69422, but I'm not actually
6675 sure whether we should even be caching the results of UTF-8
6676 operations on overloading, given that nothing stops overloading
6677 returning a different value every time it's called. */
6678 const U8 *start = (const U8 *) SvPVX_const(sv);
6679 const STRLEN realutf8 = utf8_length(start, start + byte);
6681 assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
6685 /* Cache is held with the later position first, to simplify the code
6686 that deals with unbounded ends. */
6688 ASSERT_UTF8_CACHE(cache);
6689 if (cache[1] == 0) {
6690 /* Cache is totally empty */
6693 } else if (cache[3] == 0) {
6694 if (byte > cache[1]) {
6695 /* New one is larger, so goes first. */
6696 cache[2] = cache[0];
6697 cache[3] = cache[1];
6705 #define THREEWAY_SQUARE(a,b,c,d) \
6706 ((float)((d) - (c))) * ((float)((d) - (c))) \
6707 + ((float)((c) - (b))) * ((float)((c) - (b))) \
6708 + ((float)((b) - (a))) * ((float)((b) - (a)))
6710 /* Cache has 2 slots in use, and we know three potential pairs.
6711 Keep the two that give the lowest RMS distance. Do the
6712 calcualation in bytes simply because we always know the byte
6713 length. squareroot has the same ordering as the positive value,
6714 so don't bother with the actual square root. */
6715 const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6716 if (byte > cache[1]) {
6717 /* New position is after the existing pair of pairs. */
6718 const float keep_earlier
6719 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6720 const float keep_later
6721 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6723 if (keep_later < keep_earlier) {
6724 if (keep_later < existing) {
6725 cache[2] = cache[0];
6726 cache[3] = cache[1];
6732 if (keep_earlier < existing) {
6738 else if (byte > cache[3]) {
6739 /* New position is between the existing pair of pairs. */
6740 const float keep_earlier
6741 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6742 const float keep_later
6743 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6745 if (keep_later < keep_earlier) {
6746 if (keep_later < existing) {
6752 if (keep_earlier < existing) {
6759 /* New position is before the existing pair of pairs. */
6760 const float keep_earlier
6761 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6762 const float keep_later
6763 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6765 if (keep_later < keep_earlier) {
6766 if (keep_later < existing) {
6772 if (keep_earlier < existing) {
6773 cache[0] = cache[2];
6774 cache[1] = cache[3];
6781 ASSERT_UTF8_CACHE(cache);
6784 /* We already know all of the way, now we may be able to walk back. The same
6785 assumption is made as in S_sv_pos_u2b_midway(), namely that walking
6786 backward is half the speed of walking forward. */
6788 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
6789 const U8 *end, STRLEN endu)
6791 const STRLEN forw = target - s;
6792 STRLEN backw = end - target;
6794 PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
6796 if (forw < 2 * backw) {
6797 return utf8_length(s, target);
6800 while (end > target) {
6802 while (UTF8_IS_CONTINUATION(*end)) {
6811 =for apidoc sv_pos_b2u
6813 Converts the value pointed to by offsetp from a count of bytes from the
6814 start of the string, to a count of the equivalent number of UTF-8 chars.
6815 Handles magic and type coercion.
6821 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6822 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6827 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
6830 const STRLEN byte = *offsetp;
6831 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
6837 PERL_ARGS_ASSERT_SV_POS_B2U;
6842 s = (const U8*)SvPV_const(sv, blen);
6845 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6851 && SvTYPE(sv) >= SVt_PVMG
6852 && (mg = mg_find(sv, PERL_MAGIC_utf8)))
6855 STRLEN * const cache = (STRLEN *) mg->mg_ptr;
6856 if (cache[1] == byte) {
6857 /* An exact match. */
6858 *offsetp = cache[0];
6861 if (cache[3] == byte) {
6862 /* An exact match. */
6863 *offsetp = cache[2];
6867 if (cache[1] < byte) {
6868 /* We already know part of the way. */
6869 if (mg->mg_len != -1) {
6870 /* Actually, we know the end too. */
6872 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
6873 s + blen, mg->mg_len - cache[0]);
6875 len = cache[0] + utf8_length(s + cache[1], send);
6878 else if (cache[3] < byte) {
6879 /* We're between the two cached pairs, so we do the calculation
6880 offset by the byte/utf-8 positions for the earlier pair,
6881 then add the utf-8 characters from the string start to
6883 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
6884 s + cache[1], cache[0] - cache[2])
6888 else { /* cache[3] > byte */
6889 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
6893 ASSERT_UTF8_CACHE(cache);
6895 } else if (mg->mg_len != -1) {
6896 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
6900 if (!found || PL_utf8cache < 0) {
6901 const STRLEN real_len = utf8_length(s, send);
6903 if (found && PL_utf8cache < 0)
6904 assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
6911 utf8_mg_len_cache_update(sv, &mg, len);
6913 utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
6918 S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
6919 STRLEN real, SV *const sv)
6921 PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
6923 /* As this is debugging only code, save space by keeping this test here,
6924 rather than inlining it in all the callers. */
6925 if (from_cache == real)
6928 /* Need to turn the assertions off otherwise we may recurse infinitely
6929 while printing error messages. */
6930 SAVEI8(PL_utf8cache);
6932 Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
6933 func, (UV) from_cache, (UV) real, SVfARG(sv));
6939 Returns a boolean indicating whether the strings in the two SVs are
6940 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6941 coerce its args to strings if necessary.
6943 =for apidoc sv_eq_flags
6945 Returns a boolean indicating whether the strings in the two SVs are
6946 identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings
6947 if necessary. If the flags include SV_GMAGIC, it handles get-magic, too.
6953 Perl_sv_eq_flags(pTHX_ register SV *sv1, register SV *sv2, const I32 flags)
6962 SV* svrecode = NULL;
6969 /* if pv1 and pv2 are the same, second SvPV_const call may
6970 * invalidate pv1 (if we are handling magic), so we may need to
6972 if (sv1 == sv2 && flags & SV_GMAGIC
6973 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
6974 pv1 = SvPV_const(sv1, cur1);
6975 sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
6977 pv1 = SvPV_flags_const(sv1, cur1, flags);
6985 pv2 = SvPV_flags_const(sv2, cur2, flags);
6987 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6988 /* Differing utf8ness.
6989 * Do not UTF8size the comparands as a side-effect. */
6992 svrecode = newSVpvn(pv2, cur2);
6993 sv_recode_to_utf8(svrecode, PL_encoding);
6994 pv2 = SvPV_const(svrecode, cur2);
6997 svrecode = newSVpvn(pv1, cur1);
6998 sv_recode_to_utf8(svrecode, PL_encoding);
6999 pv1 = SvPV_const(svrecode, cur1);
7001 /* Now both are in UTF-8. */
7003 SvREFCNT_dec(svrecode);
7008 bool is_utf8 = TRUE;
7011 /* sv1 is the UTF-8 one,
7012 * if is equal it must be downgrade-able */
7013 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
7019 /* sv2 is the UTF-8 one,
7020 * if is equal it must be downgrade-able */
7021 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
7027 /* Downgrade not possible - cannot be eq */
7035 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
7037 SvREFCNT_dec(svrecode);
7047 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7048 string in C<sv1> is less than, equal to, or greater than the string in
7049 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7050 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
7052 =for apidoc sv_cmp_flags
7054 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7055 string in C<sv1> is less than, equal to, or greater than the string in
7056 C<sv2>. Is UTF-8 and 'use bytes' aware and will coerce its args to strings
7057 if necessary. If the flags include SV_GMAGIC, it handles get magic. See
7058 also C<sv_cmp_locale_flags>.
7064 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
7066 return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
7070 Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2, const I32 flags)
7074 const char *pv1, *pv2;
7077 SV *svrecode = NULL;
7084 pv1 = SvPV_flags_const(sv1, cur1, flags);
7091 pv2 = SvPV_flags_const(sv2, cur2, flags);
7093 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7094 /* Differing utf8ness.
7095 * Do not UTF8size the comparands as a side-effect. */
7098 svrecode = newSVpvn(pv2, cur2);
7099 sv_recode_to_utf8(svrecode, PL_encoding);
7100 pv2 = SvPV_const(svrecode, cur2);
7103 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
7108 svrecode = newSVpvn(pv1, cur1);
7109 sv_recode_to_utf8(svrecode, PL_encoding);
7110 pv1 = SvPV_const(svrecode, cur1);
7113 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
7119 cmp = cur2 ? -1 : 0;
7123 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
7126 cmp = retval < 0 ? -1 : 1;
7127 } else if (cur1 == cur2) {
7130 cmp = cur1 < cur2 ? -1 : 1;
7134 SvREFCNT_dec(svrecode);
7142 =for apidoc sv_cmp_locale
7144 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7145 'use bytes' aware, handles get magic, and will coerce its args to strings
7146 if necessary. See also C<sv_cmp>.
7148 =for apidoc sv_cmp_locale_flags
7150 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7151 'use bytes' aware and will coerce its args to strings if necessary. If the
7152 flags contain SV_GMAGIC, it handles get magic. See also C<sv_cmp_flags>.
7158 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
7160 return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
7164 Perl_sv_cmp_locale_flags(pTHX_ register SV *const sv1, register SV *const sv2, const I32 flags)
7167 #ifdef USE_LOCALE_COLLATE
7173 if (PL_collation_standard)
7177 pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
7179 pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
7181 if (!pv1 || !len1) {
7192 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
7195 return retval < 0 ? -1 : 1;
7198 * When the result of collation is equality, that doesn't mean
7199 * that there are no differences -- some locales exclude some
7200 * characters from consideration. So to avoid false equalities,
7201 * we use the raw string as a tiebreaker.
7207 #endif /* USE_LOCALE_COLLATE */
7209 return sv_cmp(sv1, sv2);
7213 #ifdef USE_LOCALE_COLLATE
7216 =for apidoc sv_collxfrm
7218 This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag. See
7219 C<sv_collxfrm_flags>.
7221 =for apidoc sv_collxfrm_flags
7223 Add Collate Transform magic to an SV if it doesn't already have it. If the
7224 flags contain SV_GMAGIC, it handles get-magic.
7226 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
7227 scalar data of the variable, but transformed to such a format that a normal
7228 memory comparison can be used to compare the data according to the locale
7235 Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
7240 PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
7242 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
7243 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
7249 Safefree(mg->mg_ptr);
7250 s = SvPV_flags_const(sv, len, flags);
7251 if ((xf = mem_collxfrm(s, len, &xlen))) {
7253 #ifdef PERL_OLD_COPY_ON_WRITE
7255 sv_force_normal_flags(sv, 0);
7257 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
7271 if (mg && mg->mg_ptr) {
7273 return mg->mg_ptr + sizeof(PL_collation_ix);
7281 #endif /* USE_LOCALE_COLLATE */
7286 Get a line from the filehandle and store it into the SV, optionally
7287 appending to the currently-stored string.
7293 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
7298 register STDCHAR rslast;
7299 register STDCHAR *bp;
7304 PERL_ARGS_ASSERT_SV_GETS;
7306 if (SvTHINKFIRST(sv))
7307 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
7308 /* XXX. If you make this PVIV, then copy on write can copy scalars read
7310 However, perlbench says it's slower, because the existing swipe code
7311 is faster than copy on write.
7312 Swings and roundabouts. */
7313 SvUPGRADE(sv, SVt_PV);
7318 if (PerlIO_isutf8(fp)) {
7320 sv_utf8_upgrade_nomg(sv);
7321 sv_pos_u2b(sv,&append,0);
7323 } else if (SvUTF8(sv)) {
7324 SV * const tsv = newSV(0);
7325 sv_gets(tsv, fp, 0);
7326 sv_utf8_upgrade_nomg(tsv);
7327 SvCUR_set(sv,append);
7330 goto return_string_or_null;
7338 if (PerlIO_isutf8(fp))
7341 if (IN_PERL_COMPILETIME) {
7342 /* we always read code in line mode */
7346 else if (RsSNARF(PL_rs)) {
7347 /* If it is a regular disk file use size from stat() as estimate
7348 of amount we are going to read -- may result in mallocing
7349 more memory than we really need if the layers below reduce
7350 the size we read (e.g. CRLF or a gzip layer).
7353 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
7354 const Off_t offset = PerlIO_tell(fp);
7355 if (offset != (Off_t) -1 && st.st_size + append > offset) {
7356 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7362 else if (RsRECORD(PL_rs)) {
7370 /* Grab the size of the record we're getting */
7371 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7372 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7375 /* VMS wants read instead of fread, because fread doesn't respect */
7376 /* RMS record boundaries. This is not necessarily a good thing to be */
7377 /* doing, but we've got no other real choice - except avoid stdio
7378 as implementation - perhaps write a :vms layer ?
7380 fd = PerlIO_fileno(fp);
7381 if (fd == -1) { /* in-memory file from PerlIO::Scalar */
7382 bytesread = PerlIO_read(fp, buffer, recsize);
7385 bytesread = PerlLIO_read(fd, buffer, recsize);
7388 bytesread = PerlIO_read(fp, buffer, recsize);
7392 SvCUR_set(sv, bytesread + append);
7393 buffer[bytesread] = '\0';
7394 goto return_string_or_null;
7396 else if (RsPARA(PL_rs)) {
7402 /* Get $/ i.e. PL_rs into same encoding as stream wants */
7403 if (PerlIO_isutf8(fp)) {
7404 rsptr = SvPVutf8(PL_rs, rslen);
7407 if (SvUTF8(PL_rs)) {
7408 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7409 Perl_croak(aTHX_ "Wide character in $/");
7412 rsptr = SvPV_const(PL_rs, rslen);
7416 rslast = rslen ? rsptr[rslen - 1] : '\0';
7418 if (rspara) { /* have to do this both before and after */
7419 do { /* to make sure file boundaries work right */
7422 i = PerlIO_getc(fp);
7426 PerlIO_ungetc(fp,i);
7432 /* See if we know enough about I/O mechanism to cheat it ! */
7434 /* This used to be #ifdef test - it is made run-time test for ease
7435 of abstracting out stdio interface. One call should be cheap
7436 enough here - and may even be a macro allowing compile
7440 if (PerlIO_fast_gets(fp)) {
7443 * We're going to steal some values from the stdio struct
7444 * and put EVERYTHING in the innermost loop into registers.
7446 register STDCHAR *ptr;
7450 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7451 /* An ungetc()d char is handled separately from the regular
7452 * buffer, so we getc() it back out and stuff it in the buffer.
7454 i = PerlIO_getc(fp);
7455 if (i == EOF) return 0;
7456 *(--((*fp)->_ptr)) = (unsigned char) i;
7460 /* Here is some breathtakingly efficient cheating */
7462 cnt = PerlIO_get_cnt(fp); /* get count into register */
7463 /* make sure we have the room */
7464 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7465 /* Not room for all of it
7466 if we are looking for a separator and room for some
7468 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7469 /* just process what we have room for */
7470 shortbuffered = cnt - SvLEN(sv) + append + 1;
7471 cnt -= shortbuffered;
7475 /* remember that cnt can be negative */
7476 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7481 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
7482 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7483 DEBUG_P(PerlIO_printf(Perl_debug_log,
7484 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7485 DEBUG_P(PerlIO_printf(Perl_debug_log,
7486 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7487 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7488 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7493 while (cnt > 0) { /* this | eat */
7495 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7496 goto thats_all_folks; /* screams | sed :-) */
7500 Copy(ptr, bp, cnt, char); /* this | eat */
7501 bp += cnt; /* screams | dust */
7502 ptr += cnt; /* louder | sed :-) */
7507 if (shortbuffered) { /* oh well, must extend */
7508 cnt = shortbuffered;
7510 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7512 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7513 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7517 DEBUG_P(PerlIO_printf(Perl_debug_log,
7518 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7519 PTR2UV(ptr),(long)cnt));
7520 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7522 DEBUG_P(PerlIO_printf(Perl_debug_log,
7523 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7524 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7525 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7527 /* This used to call 'filbuf' in stdio form, but as that behaves like
7528 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7529 another abstraction. */
7530 i = PerlIO_getc(fp); /* get more characters */
7532 DEBUG_P(PerlIO_printf(Perl_debug_log,
7533 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7534 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7535 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7537 cnt = PerlIO_get_cnt(fp);
7538 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7539 DEBUG_P(PerlIO_printf(Perl_debug_log,
7540 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7542 if (i == EOF) /* all done for ever? */
7543 goto thats_really_all_folks;
7545 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7547 SvGROW(sv, bpx + cnt + 2);
7548 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7550 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7552 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7553 goto thats_all_folks;
7557 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7558 memNE((char*)bp - rslen, rsptr, rslen))
7559 goto screamer; /* go back to the fray */
7560 thats_really_all_folks:
7562 cnt += shortbuffered;
7563 DEBUG_P(PerlIO_printf(Perl_debug_log,
7564 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7565 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7566 DEBUG_P(PerlIO_printf(Perl_debug_log,
7567 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7568 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7569 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7571 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
7572 DEBUG_P(PerlIO_printf(Perl_debug_log,
7573 "Screamer: done, len=%ld, string=|%.*s|\n",
7574 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7578 /*The big, slow, and stupid way. */
7579 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
7580 STDCHAR *buf = NULL;
7581 Newx(buf, 8192, STDCHAR);
7589 register const STDCHAR * const bpe = buf + sizeof(buf);
7591 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7592 ; /* keep reading */
7596 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7597 /* Accomodate broken VAXC compiler, which applies U8 cast to
7598 * both args of ?: operator, causing EOF to change into 255
7601 i = (U8)buf[cnt - 1];
7607 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7609 sv_catpvn(sv, (char *) buf, cnt);
7611 sv_setpvn(sv, (char *) buf, cnt);
7613 if (i != EOF && /* joy */
7615 SvCUR(sv) < rslen ||
7616 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7620 * If we're reading from a TTY and we get a short read,
7621 * indicating that the user hit his EOF character, we need
7622 * to notice it now, because if we try to read from the TTY
7623 * again, the EOF condition will disappear.
7625 * The comparison of cnt to sizeof(buf) is an optimization
7626 * that prevents unnecessary calls to feof().
7630 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7634 #ifdef USE_HEAP_INSTEAD_OF_STACK
7639 if (rspara) { /* have to do this both before and after */
7640 while (i != EOF) { /* to make sure file boundaries work right */
7641 i = PerlIO_getc(fp);
7643 PerlIO_ungetc(fp,i);
7649 return_string_or_null:
7650 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7656 Auto-increment of the value in the SV, doing string to numeric conversion
7657 if necessary. Handles 'get' magic and operator overloading.
7663 Perl_sv_inc(pTHX_ register SV *const sv)
7672 =for apidoc sv_inc_nomg
7674 Auto-increment of the value in the SV, doing string to numeric conversion
7675 if necessary. Handles operator overloading. Skips handling 'get' magic.
7681 Perl_sv_inc_nomg(pTHX_ register SV *const sv)
7689 if (SvTHINKFIRST(sv)) {
7691 sv_force_normal_flags(sv, 0);
7692 if (SvREADONLY(sv)) {
7693 if (IN_PERL_RUNTIME)
7694 Perl_croak_no_modify(aTHX);
7698 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7700 i = PTR2IV(SvRV(sv));
7705 flags = SvFLAGS(sv);
7706 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7707 /* It's (privately or publicly) a float, but not tested as an
7708 integer, so test it to see. */
7710 flags = SvFLAGS(sv);
7712 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7713 /* It's publicly an integer, or privately an integer-not-float */
7714 #ifdef PERL_PRESERVE_IVUV
7718 if (SvUVX(sv) == UV_MAX)
7719 sv_setnv(sv, UV_MAX_P1);
7721 (void)SvIOK_only_UV(sv);
7722 SvUV_set(sv, SvUVX(sv) + 1);
7724 if (SvIVX(sv) == IV_MAX)
7725 sv_setuv(sv, (UV)IV_MAX + 1);
7727 (void)SvIOK_only(sv);
7728 SvIV_set(sv, SvIVX(sv) + 1);
7733 if (flags & SVp_NOK) {
7734 const NV was = SvNVX(sv);
7735 if (NV_OVERFLOWS_INTEGERS_AT &&
7736 was >= NV_OVERFLOWS_INTEGERS_AT) {
7737 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7738 "Lost precision when incrementing %" NVff " by 1",
7741 (void)SvNOK_only(sv);
7742 SvNV_set(sv, was + 1.0);
7746 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7747 if ((flags & SVTYPEMASK) < SVt_PVIV)
7748 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
7749 (void)SvIOK_only(sv);
7754 while (isALPHA(*d)) d++;
7755 while (isDIGIT(*d)) d++;
7756 if (d < SvEND(sv)) {
7757 #ifdef PERL_PRESERVE_IVUV
7758 /* Got to punt this as an integer if needs be, but we don't issue
7759 warnings. Probably ought to make the sv_iv_please() that does
7760 the conversion if possible, and silently. */
7761 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7762 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7763 /* Need to try really hard to see if it's an integer.
7764 9.22337203685478e+18 is an integer.
7765 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7766 so $a="9.22337203685478e+18"; $a+0; $a++
7767 needs to be the same as $a="9.22337203685478e+18"; $a++
7774 /* sv_2iv *should* have made this an NV */
7775 if (flags & SVp_NOK) {
7776 (void)SvNOK_only(sv);
7777 SvNV_set(sv, SvNVX(sv) + 1.0);
7780 /* I don't think we can get here. Maybe I should assert this
7781 And if we do get here I suspect that sv_setnv will croak. NWC
7783 #if defined(USE_LONG_DOUBLE)
7784 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",
7785 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7787 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7788 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7791 #endif /* PERL_PRESERVE_IVUV */
7792 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7796 while (d >= SvPVX_const(sv)) {
7804 /* MKS: The original code here died if letters weren't consecutive.
7805 * at least it didn't have to worry about non-C locales. The
7806 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7807 * arranged in order (although not consecutively) and that only
7808 * [A-Za-z] are accepted by isALPHA in the C locale.
7810 if (*d != 'z' && *d != 'Z') {
7811 do { ++*d; } while (!isALPHA(*d));
7814 *(d--) -= 'z' - 'a';
7819 *(d--) -= 'z' - 'a' + 1;
7823 /* oh,oh, the number grew */
7824 SvGROW(sv, SvCUR(sv) + 2);
7825 SvCUR_set(sv, SvCUR(sv) + 1);
7826 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7837 Auto-decrement of the value in the SV, doing string to numeric conversion
7838 if necessary. Handles 'get' magic and operator overloading.
7844 Perl_sv_dec(pTHX_ register SV *const sv)
7854 =for apidoc sv_dec_nomg
7856 Auto-decrement of the value in the SV, doing string to numeric conversion
7857 if necessary. Handles operator overloading. Skips handling 'get' magic.
7863 Perl_sv_dec_nomg(pTHX_ register SV *const sv)
7870 if (SvTHINKFIRST(sv)) {
7872 sv_force_normal_flags(sv, 0);
7873 if (SvREADONLY(sv)) {
7874 if (IN_PERL_RUNTIME)
7875 Perl_croak_no_modify(aTHX);
7879 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7881 i = PTR2IV(SvRV(sv));
7886 /* Unlike sv_inc we don't have to worry about string-never-numbers
7887 and keeping them magic. But we mustn't warn on punting */
7888 flags = SvFLAGS(sv);
7889 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7890 /* It's publicly an integer, or privately an integer-not-float */
7891 #ifdef PERL_PRESERVE_IVUV
7895 if (SvUVX(sv) == 0) {
7896 (void)SvIOK_only(sv);
7900 (void)SvIOK_only_UV(sv);
7901 SvUV_set(sv, SvUVX(sv) - 1);
7904 if (SvIVX(sv) == IV_MIN) {
7905 sv_setnv(sv, (NV)IV_MIN);
7909 (void)SvIOK_only(sv);
7910 SvIV_set(sv, SvIVX(sv) - 1);
7915 if (flags & SVp_NOK) {
7918 const NV was = SvNVX(sv);
7919 if (NV_OVERFLOWS_INTEGERS_AT &&
7920 was <= -NV_OVERFLOWS_INTEGERS_AT) {
7921 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7922 "Lost precision when decrementing %" NVff " by 1",
7925 (void)SvNOK_only(sv);
7926 SvNV_set(sv, was - 1.0);
7930 if (!(flags & SVp_POK)) {
7931 if ((flags & SVTYPEMASK) < SVt_PVIV)
7932 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
7934 (void)SvIOK_only(sv);
7937 #ifdef PERL_PRESERVE_IVUV
7939 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7940 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7941 /* Need to try really hard to see if it's an integer.
7942 9.22337203685478e+18 is an integer.
7943 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7944 so $a="9.22337203685478e+18"; $a+0; $a--
7945 needs to be the same as $a="9.22337203685478e+18"; $a--
7952 /* sv_2iv *should* have made this an NV */
7953 if (flags & SVp_NOK) {
7954 (void)SvNOK_only(sv);
7955 SvNV_set(sv, SvNVX(sv) - 1.0);
7958 /* I don't think we can get here. Maybe I should assert this
7959 And if we do get here I suspect that sv_setnv will croak. NWC
7961 #if defined(USE_LONG_DOUBLE)
7962 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",
7963 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7965 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7966 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7970 #endif /* PERL_PRESERVE_IVUV */
7971 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
7974 /* this define is used to eliminate a chunk of duplicated but shared logic
7975 * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
7976 * used anywhere but here - yves
7978 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
7981 PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
7985 =for apidoc sv_mortalcopy
7987 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7988 The new SV is marked as mortal. It will be destroyed "soon", either by an
7989 explicit call to FREETMPS, or by an implicit call at places such as
7990 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7995 /* Make a string that will exist for the duration of the expression
7996 * evaluation. Actually, it may have to last longer than that, but
7997 * hopefully we won't free it until it has been assigned to a
7998 * permanent location. */
8001 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
8007 sv_setsv(sv,oldstr);
8008 PUSH_EXTEND_MORTAL__SV_C(sv);
8014 =for apidoc sv_newmortal
8016 Creates a new null SV which is mortal. The reference count of the SV is
8017 set to 1. It will be destroyed "soon", either by an explicit call to
8018 FREETMPS, or by an implicit call at places such as statement boundaries.
8019 See also C<sv_mortalcopy> and C<sv_2mortal>.
8025 Perl_sv_newmortal(pTHX)
8031 SvFLAGS(sv) = SVs_TEMP;
8032 PUSH_EXTEND_MORTAL__SV_C(sv);
8038 =for apidoc newSVpvn_flags
8040 Creates a new SV and copies a string into it. The reference count for the
8041 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
8042 string. You are responsible for ensuring that the source string is at least
8043 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
8044 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
8045 If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before
8046 returning. If C<SVf_UTF8> is set, C<s> is considered to be in UTF-8 and the
8047 C<SVf_UTF8> flag will be set on the new SV.
8048 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
8050 #define newSVpvn_utf8(s, len, u) \
8051 newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
8057 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
8062 /* All the flags we don't support must be zero.
8063 And we're new code so I'm going to assert this from the start. */
8064 assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
8066 sv_setpvn(sv,s,len);
8068 /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal()
8069 * and do what it does outselves here.
8070 * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags
8071 * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which
8072 * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we
8073 * eleminate quite a few steps than it looks - Yves (explaining patch by gfx)
8076 SvFLAGS(sv) |= flags;
8078 if(flags & SVs_TEMP){
8079 PUSH_EXTEND_MORTAL__SV_C(sv);
8086 =for apidoc sv_2mortal
8088 Marks an existing SV as mortal. The SV will be destroyed "soon", either
8089 by an explicit call to FREETMPS, or by an implicit call at places such as
8090 statement boundaries. SvTEMP() is turned on which means that the SV's
8091 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
8092 and C<sv_mortalcopy>.
8098 Perl_sv_2mortal(pTHX_ register SV *const sv)
8103 if (SvREADONLY(sv) && SvIMMORTAL(sv))
8105 PUSH_EXTEND_MORTAL__SV_C(sv);
8113 Creates a new SV and copies a string into it. The reference count for the
8114 SV is set to 1. If C<len> is zero, Perl will compute the length using
8115 strlen(). For efficiency, consider using C<newSVpvn> instead.
8121 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
8127 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
8132 =for apidoc newSVpvn
8134 Creates a new SV and copies a string into it. The reference count for the
8135 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
8136 string. You are responsible for ensuring that the source string is at least
8137 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
8143 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
8149 sv_setpvn(sv,s,len);
8154 =for apidoc newSVhek
8156 Creates a new SV from the hash key structure. It will generate scalars that
8157 point to the shared string table where possible. Returns a new (undefined)
8158 SV if the hek is NULL.
8164 Perl_newSVhek(pTHX_ const HEK *const hek)
8174 if (HEK_LEN(hek) == HEf_SVKEY) {
8175 return newSVsv(*(SV**)HEK_KEY(hek));
8177 const int flags = HEK_FLAGS(hek);
8178 if (flags & HVhek_WASUTF8) {
8180 Andreas would like keys he put in as utf8 to come back as utf8
8182 STRLEN utf8_len = HEK_LEN(hek);
8183 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
8184 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
8187 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
8189 } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
8190 /* We don't have a pointer to the hv, so we have to replicate the
8191 flag into every HEK. This hv is using custom a hasing
8192 algorithm. Hence we can't return a shared string scalar, as
8193 that would contain the (wrong) hash value, and might get passed
8194 into an hv routine with a regular hash.
8195 Similarly, a hash that isn't using shared hash keys has to have
8196 the flag in every key so that we know not to try to call
8197 share_hek_kek on it. */
8199 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
8204 /* This will be overwhelminly the most common case. */
8206 /* Inline most of newSVpvn_share(), because share_hek_hek() is far
8207 more efficient than sharepvn(). */
8211 sv_upgrade(sv, SVt_PV);
8212 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
8213 SvCUR_set(sv, HEK_LEN(hek));
8226 =for apidoc newSVpvn_share
8228 Creates a new SV with its SvPVX_const pointing to a shared string in the string
8229 table. If the string does not already exist in the table, it is created
8230 first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
8231 value is used; otherwise the hash is computed. The string's hash can be later
8232 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
8233 that as the string table is used for shared hash keys these strings will have
8234 SvPVX_const == HeKEY and hash lookup will avoid string compare.
8240 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
8244 bool is_utf8 = FALSE;
8245 const char *const orig_src = src;
8248 STRLEN tmplen = -len;
8250 /* See the note in hv.c:hv_fetch() --jhi */
8251 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
8255 PERL_HASH(hash, src, len);
8257 /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
8258 changes here, update it there too. */
8259 sv_upgrade(sv, SVt_PV);
8260 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
8268 if (src != orig_src)
8274 =for apidoc newSVpv_share
8276 Like C<newSVpvn_share>, but takes a nul-terminated string instead of a
8283 Perl_newSVpv_share(pTHX_ const char *src, U32 hash)
8285 return newSVpvn_share(src, strlen(src), hash);
8288 #if defined(PERL_IMPLICIT_CONTEXT)
8290 /* pTHX_ magic can't cope with varargs, so this is a no-context
8291 * version of the main function, (which may itself be aliased to us).
8292 * Don't access this version directly.
8296 Perl_newSVpvf_nocontext(const char *const pat, ...)
8302 PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
8304 va_start(args, pat);
8305 sv = vnewSVpvf(pat, &args);
8312 =for apidoc newSVpvf
8314 Creates a new SV and initializes it with the string formatted like
8321 Perl_newSVpvf(pTHX_ const char *const pat, ...)
8326 PERL_ARGS_ASSERT_NEWSVPVF;
8328 va_start(args, pat);
8329 sv = vnewSVpvf(pat, &args);
8334 /* backend for newSVpvf() and newSVpvf_nocontext() */
8337 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
8342 PERL_ARGS_ASSERT_VNEWSVPVF;
8345 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8352 Creates a new SV and copies a floating point value into it.
8353 The reference count for the SV is set to 1.
8359 Perl_newSVnv(pTHX_ const NV n)
8372 Creates a new SV and copies an integer into it. The reference count for the
8379 Perl_newSViv(pTHX_ const IV i)
8392 Creates a new SV and copies an unsigned integer into it.
8393 The reference count for the SV is set to 1.
8399 Perl_newSVuv(pTHX_ const UV u)
8410 =for apidoc newSV_type
8412 Creates a new SV, of the type specified. The reference count for the new SV
8419 Perl_newSV_type(pTHX_ const svtype type)
8424 sv_upgrade(sv, type);
8429 =for apidoc newRV_noinc
8431 Creates an RV wrapper for an SV. The reference count for the original
8432 SV is B<not> incremented.
8438 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
8441 register SV *sv = newSV_type(SVt_IV);
8443 PERL_ARGS_ASSERT_NEWRV_NOINC;
8446 SvRV_set(sv, tmpRef);
8451 /* newRV_inc is the official function name to use now.
8452 * newRV_inc is in fact #defined to newRV in sv.h
8456 Perl_newRV(pTHX_ SV *const sv)
8460 PERL_ARGS_ASSERT_NEWRV;
8462 return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
8468 Creates a new SV which is an exact duplicate of the original SV.
8475 Perl_newSVsv(pTHX_ register SV *const old)
8482 if (SvTYPE(old) == SVTYPEMASK) {
8483 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
8487 /* SV_GMAGIC is the default for sv_setv()
8488 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
8489 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
8490 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
8495 =for apidoc sv_reset
8497 Underlying implementation for the C<reset> Perl function.
8498 Note that the perl-level function is vaguely deprecated.
8504 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
8507 char todo[PERL_UCHAR_MAX+1];
8509 PERL_ARGS_ASSERT_SV_RESET;
8514 if (!*s) { /* reset ?? searches */
8515 MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
8517 const U32 count = mg->mg_len / sizeof(PMOP**);
8518 PMOP **pmp = (PMOP**) mg->mg_ptr;
8519 PMOP *const *const end = pmp + count;
8523 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
8525 (*pmp)->op_pmflags &= ~PMf_USED;
8533 /* reset variables */
8535 if (!HvARRAY(stash))
8538 Zero(todo, 256, char);
8541 I32 i = (unsigned char)*s;
8545 max = (unsigned char)*s++;
8546 for ( ; i <= max; i++) {
8549 for (i = 0; i <= (I32) HvMAX(stash); i++) {
8551 for (entry = HvARRAY(stash)[i];
8553 entry = HeNEXT(entry))
8558 if (!todo[(U8)*HeKEY(entry)])
8560 gv = MUTABLE_GV(HeVAL(entry));
8563 if (SvTHINKFIRST(sv)) {
8564 if (!SvREADONLY(sv) && SvROK(sv))
8566 /* XXX Is this continue a bug? Why should THINKFIRST
8567 exempt us from resetting arrays and hashes? */
8571 if (SvTYPE(sv) >= SVt_PV) {
8573 if (SvPVX_const(sv) != NULL)
8581 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8583 Perl_die(aTHX_ "Can't reset %%ENV on this system");
8586 # if defined(USE_ENVIRON_ARRAY)
8589 # endif /* USE_ENVIRON_ARRAY */
8600 Using various gambits, try to get an IO from an SV: the IO slot if its a
8601 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8602 named after the PV if we're a string.
8608 Perl_sv_2io(pTHX_ SV *const sv)
8613 PERL_ARGS_ASSERT_SV_2IO;
8615 switch (SvTYPE(sv)) {
8617 io = MUTABLE_IO(sv);
8621 if (isGV_with_GP(sv)) {
8622 gv = MUTABLE_GV(sv);
8625 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8631 Perl_croak(aTHX_ PL_no_usym, "filehandle");
8633 return sv_2io(SvRV(sv));
8634 gv = gv_fetchsv(sv, 0, SVt_PVIO);
8640 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
8649 Using various gambits, try to get a CV from an SV; in addition, try if
8650 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8651 The flags in C<lref> are passed to gv_fetchsv.
8657 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8663 PERL_ARGS_ASSERT_SV_2CV;
8670 switch (SvTYPE(sv)) {
8674 return MUTABLE_CV(sv);
8681 if (isGV_with_GP(sv)) {
8682 gv = MUTABLE_GV(sv);
8691 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
8693 tryAMAGICunDEREF(to_cv);
8696 if (SvTYPE(sv) == SVt_PVCV) {
8697 cv = MUTABLE_CV(sv);
8702 else if(isGV_with_GP(sv))
8703 gv = MUTABLE_GV(sv);
8705 Perl_croak(aTHX_ "Not a subroutine reference");
8707 else if (isGV_with_GP(sv)) {
8709 gv = MUTABLE_GV(sv);
8712 gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
8718 /* Some flags to gv_fetchsv mean don't really create the GV */
8719 if (!isGV_with_GP(gv)) {
8725 if (lref && !GvCVu(gv)) {
8729 gv_efullname3(tmpsv, gv, NULL);
8730 /* XXX this is probably not what they think they're getting.
8731 * It has the same effect as "sub name;", i.e. just a forward
8733 newSUB(start_subparse(FALSE, 0),
8734 newSVOP(OP_CONST, 0, tmpsv),
8738 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8739 SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8748 Returns true if the SV has a true value by Perl's rules.
8749 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8750 instead use an in-line version.
8756 Perl_sv_true(pTHX_ register SV *const sv)
8761 register const XPV* const tXpv = (XPV*)SvANY(sv);
8763 (tXpv->xpv_cur > 1 ||
8764 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
8771 return SvIVX(sv) != 0;
8774 return SvNVX(sv) != 0.0;
8776 return sv_2bool(sv);
8782 =for apidoc sv_pvn_force
8784 Get a sensible string out of the SV somehow.
8785 A private implementation of the C<SvPV_force> macro for compilers which
8786 can't cope with complex macro expressions. Always use the macro instead.
8788 =for apidoc sv_pvn_force_flags
8790 Get a sensible string out of the SV somehow.
8791 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8792 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8793 implemented in terms of this function.
8794 You normally want to use the various wrapper macros instead: see
8795 C<SvPV_force> and C<SvPV_force_nomg>
8801 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
8805 PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
8807 if (SvTHINKFIRST(sv) && !SvROK(sv))
8808 sv_force_normal_flags(sv, 0);
8818 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8819 const char * const ref = sv_reftype(sv,0);
8821 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8822 ref, OP_DESC(PL_op));
8824 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
8826 if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
8827 || isGV_with_GP(sv))
8828 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8830 s = sv_2pv_flags(sv, &len, flags);
8834 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
8837 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8838 SvGROW(sv, len + 1);
8839 Move(s,SvPVX(sv),len,char);
8841 SvPVX(sv)[len] = '\0';
8844 SvPOK_on(sv); /* validate pointer */
8846 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8847 PTR2UV(sv),SvPVX_const(sv)));
8850 return SvPVX_mutable(sv);
8854 =for apidoc sv_pvbyten_force
8856 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
8862 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
8864 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
8866 sv_pvn_force(sv,lp);
8867 sv_utf8_downgrade(sv,0);
8873 =for apidoc sv_pvutf8n_force
8875 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
8881 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
8883 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
8885 sv_pvn_force(sv,lp);
8886 sv_utf8_upgrade(sv);
8892 =for apidoc sv_reftype
8894 Returns a string describing what the SV is a reference to.
8900 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
8902 PERL_ARGS_ASSERT_SV_REFTYPE;
8904 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8905 inside return suggests a const propagation bug in g++. */
8906 if (ob && SvOBJECT(sv)) {
8907 char * const name = HvNAME_get(SvSTASH(sv));
8908 return name ? name : (char *) "__ANON__";
8911 switch (SvTYPE(sv)) {
8926 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
8927 /* tied lvalues should appear to be
8928 * scalars for backwards compatitbility */
8929 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8930 ? "SCALAR" : "LVALUE");
8931 case SVt_PVAV: return "ARRAY";
8932 case SVt_PVHV: return "HASH";
8933 case SVt_PVCV: return "CODE";
8934 case SVt_PVGV: return (char *) (isGV_with_GP(sv)
8935 ? "GLOB" : "SCALAR");
8936 case SVt_PVFM: return "FORMAT";
8937 case SVt_PVIO: return "IO";
8938 case SVt_BIND: return "BIND";
8939 case SVt_REGEXP: return "REGEXP";
8940 default: return "UNKNOWN";
8946 =for apidoc sv_isobject
8948 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8949 object. If the SV is not an RV, or if the object is not blessed, then this
8956 Perl_sv_isobject(pTHX_ SV *sv)
8972 Returns a boolean indicating whether the SV is blessed into the specified
8973 class. This does not check for subtypes; use C<sv_derived_from> to verify
8974 an inheritance relationship.
8980 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
8984 PERL_ARGS_ASSERT_SV_ISA;
8994 hvname = HvNAME_get(SvSTASH(sv));
8998 return strEQ(hvname, name);
9004 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
9005 it will be upgraded to one. If C<classname> is non-null then the new SV will
9006 be blessed in the specified package. The new SV is returned and its
9007 reference count is 1.
9013 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
9018 PERL_ARGS_ASSERT_NEWSVRV;
9022 SV_CHECK_THINKFIRST_COW_DROP(rv);
9023 (void)SvAMAGIC_off(rv);
9025 if (SvTYPE(rv) >= SVt_PVMG) {
9026 const U32 refcnt = SvREFCNT(rv);
9030 SvREFCNT(rv) = refcnt;
9032 sv_upgrade(rv, SVt_IV);
9033 } else if (SvROK(rv)) {
9034 SvREFCNT_dec(SvRV(rv));
9036 prepare_SV_for_RV(rv);
9044 HV* const stash = gv_stashpv(classname, GV_ADD);
9045 (void)sv_bless(rv, stash);
9051 =for apidoc sv_setref_pv
9053 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
9054 argument will be upgraded to an RV. That RV will be modified to point to
9055 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
9056 into the SV. The C<classname> argument indicates the package for the
9057 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9058 will have a reference count of 1, and the RV will be returned.
9060 Do not use with other Perl types such as HV, AV, SV, CV, because those
9061 objects will become corrupted by the pointer copy process.
9063 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
9069 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
9073 PERL_ARGS_ASSERT_SV_SETREF_PV;
9076 sv_setsv(rv, &PL_sv_undef);
9080 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
9085 =for apidoc sv_setref_iv
9087 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
9088 argument will be upgraded to an RV. That RV will be modified to point to
9089 the new SV. The C<classname> argument indicates the package for the
9090 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9091 will have a reference count of 1, and the RV will be returned.
9097 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
9099 PERL_ARGS_ASSERT_SV_SETREF_IV;
9101 sv_setiv(newSVrv(rv,classname), iv);
9106 =for apidoc sv_setref_uv
9108 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
9109 argument will be upgraded to an RV. That RV will be modified to point to
9110 the new SV. The C<classname> argument indicates the package for the
9111 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9112 will have a reference count of 1, and the RV will be returned.
9118 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
9120 PERL_ARGS_ASSERT_SV_SETREF_UV;
9122 sv_setuv(newSVrv(rv,classname), uv);
9127 =for apidoc sv_setref_nv
9129 Copies a double into a new SV, optionally blessing the SV. The C<rv>
9130 argument will be upgraded to an RV. That RV will be modified to point to
9131 the new SV. The C<classname> argument indicates the package for the
9132 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9133 will have a reference count of 1, and the RV will be returned.
9139 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
9141 PERL_ARGS_ASSERT_SV_SETREF_NV;
9143 sv_setnv(newSVrv(rv,classname), nv);
9148 =for apidoc sv_setref_pvn
9150 Copies a string into a new SV, optionally blessing the SV. The length of the
9151 string must be specified with C<n>. The C<rv> argument will be upgraded to
9152 an RV. That RV will be modified to point to the new SV. The C<classname>
9153 argument indicates the package for the blessing. Set C<classname> to
9154 C<NULL> to avoid the blessing. The new SV will have a reference count
9155 of 1, and the RV will be returned.
9157 Note that C<sv_setref_pv> copies the pointer while this copies the string.
9163 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
9164 const char *const pv, const STRLEN n)
9166 PERL_ARGS_ASSERT_SV_SETREF_PVN;
9168 sv_setpvn(newSVrv(rv,classname), pv, n);
9173 =for apidoc sv_bless
9175 Blesses an SV into a specified package. The SV must be an RV. The package
9176 must be designated by its stash (see C<gv_stashpv()>). The reference count
9177 of the SV is unaffected.
9183 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
9188 PERL_ARGS_ASSERT_SV_BLESS;
9191 Perl_croak(aTHX_ "Can't bless non-reference value");
9193 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
9194 if (SvIsCOW(tmpRef))
9195 sv_force_normal_flags(tmpRef, 0);
9196 if (SvREADONLY(tmpRef))
9197 Perl_croak_no_modify(aTHX);
9198 if (SvOBJECT(tmpRef)) {
9199 if (SvTYPE(tmpRef) != SVt_PVIO)
9201 SvREFCNT_dec(SvSTASH(tmpRef));
9204 SvOBJECT_on(tmpRef);
9205 if (SvTYPE(tmpRef) != SVt_PVIO)
9207 SvUPGRADE(tmpRef, SVt_PVMG);
9208 SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
9213 (void)SvAMAGIC_off(sv);
9215 if(SvSMAGICAL(tmpRef))
9216 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
9224 /* Downgrades a PVGV to a PVMG. If it’s actually a PVLV, we leave the type
9225 * as it is after unglobbing it.
9229 S_sv_unglob(pTHX_ SV *const sv)
9234 SV * const temp = sv_newmortal();
9236 PERL_ARGS_ASSERT_SV_UNGLOB;
9238 assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
9240 gv_efullname3(temp, MUTABLE_GV(sv), "*");
9243 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
9244 && HvNAME_get(stash))
9245 mro_method_changed_in(stash);
9246 gp_free(MUTABLE_GV(sv));
9249 sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
9253 if (GvNAME_HEK(sv)) {
9254 unshare_hek(GvNAME_HEK(sv));
9256 isGV_with_GP_off(sv);
9258 if(SvTYPE(sv) == SVt_PVGV) {
9259 /* need to keep SvANY(sv) in the right arena */
9260 xpvmg = new_XPVMG();
9261 StructCopy(SvANY(sv), xpvmg, XPVMG);
9262 del_XPVGV(SvANY(sv));
9265 SvFLAGS(sv) &= ~SVTYPEMASK;
9266 SvFLAGS(sv) |= SVt_PVMG;
9269 /* Intentionally not calling any local SET magic, as this isn't so much a
9270 set operation as merely an internal storage change. */
9271 sv_setsv_flags(sv, temp, 0);
9275 =for apidoc sv_unref_flags
9277 Unsets the RV status of the SV, and decrements the reference count of
9278 whatever was being referenced by the RV. This can almost be thought of
9279 as a reversal of C<newSVrv>. The C<cflags> argument can contain
9280 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
9281 (otherwise the decrementing is conditional on the reference count being
9282 different from one or the reference being a readonly SV).
9289 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
9291 SV* const target = SvRV(ref);
9293 PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
9295 if (SvWEAKREF(ref)) {
9296 sv_del_backref(target, ref);
9298 SvRV_set(ref, NULL);
9301 SvRV_set(ref, NULL);
9303 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
9304 assigned to as BEGIN {$a = \"Foo"} will fail. */
9305 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
9306 SvREFCNT_dec(target);
9307 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
9308 sv_2mortal(target); /* Schedule for freeing later */
9312 =for apidoc sv_untaint
9314 Untaint an SV. Use C<SvTAINTED_off> instead.
9319 Perl_sv_untaint(pTHX_ SV *const sv)
9321 PERL_ARGS_ASSERT_SV_UNTAINT;
9323 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9324 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9331 =for apidoc sv_tainted
9333 Test an SV for taintedness. Use C<SvTAINTED> instead.
9338 Perl_sv_tainted(pTHX_ SV *const sv)
9340 PERL_ARGS_ASSERT_SV_TAINTED;
9342 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9343 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9344 if (mg && (mg->mg_len & 1) )
9351 =for apidoc sv_setpviv
9353 Copies an integer into the given SV, also updating its string value.
9354 Does not handle 'set' magic. See C<sv_setpviv_mg>.
9360 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
9362 char buf[TYPE_CHARS(UV)];
9364 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
9366 PERL_ARGS_ASSERT_SV_SETPVIV;
9368 sv_setpvn(sv, ptr, ebuf - ptr);
9372 =for apidoc sv_setpviv_mg
9374 Like C<sv_setpviv>, but also handles 'set' magic.
9380 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
9382 PERL_ARGS_ASSERT_SV_SETPVIV_MG;
9388 #if defined(PERL_IMPLICIT_CONTEXT)
9390 /* pTHX_ magic can't cope with varargs, so this is a no-context
9391 * version of the main function, (which may itself be aliased to us).
9392 * Don't access this version directly.
9396 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
9401 PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
9403 va_start(args, pat);
9404 sv_vsetpvf(sv, pat, &args);
9408 /* pTHX_ magic can't cope with varargs, so this is a no-context
9409 * version of the main function, (which may itself be aliased to us).
9410 * Don't access this version directly.
9414 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9419 PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
9421 va_start(args, pat);
9422 sv_vsetpvf_mg(sv, pat, &args);
9428 =for apidoc sv_setpvf
9430 Works like C<sv_catpvf> but copies the text into the SV instead of
9431 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
9437 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
9441 PERL_ARGS_ASSERT_SV_SETPVF;
9443 va_start(args, pat);
9444 sv_vsetpvf(sv, pat, &args);
9449 =for apidoc sv_vsetpvf
9451 Works like C<sv_vcatpvf> but copies the text into the SV instead of
9452 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
9454 Usually used via its frontend C<sv_setpvf>.
9460 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9462 PERL_ARGS_ASSERT_SV_VSETPVF;
9464 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9468 =for apidoc sv_setpvf_mg
9470 Like C<sv_setpvf>, but also handles 'set' magic.
9476 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9480 PERL_ARGS_ASSERT_SV_SETPVF_MG;
9482 va_start(args, pat);
9483 sv_vsetpvf_mg(sv, pat, &args);
9488 =for apidoc sv_vsetpvf_mg
9490 Like C<sv_vsetpvf>, but also handles 'set' magic.
9492 Usually used via its frontend C<sv_setpvf_mg>.
9498 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9500 PERL_ARGS_ASSERT_SV_VSETPVF_MG;
9502 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9506 #if defined(PERL_IMPLICIT_CONTEXT)
9508 /* pTHX_ magic can't cope with varargs, so this is a no-context
9509 * version of the main function, (which may itself be aliased to us).
9510 * Don't access this version directly.
9514 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
9519 PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
9521 va_start(args, pat);
9522 sv_vcatpvf(sv, pat, &args);
9526 /* pTHX_ magic can't cope with varargs, so this is a no-context
9527 * version of the main function, (which may itself be aliased to us).
9528 * Don't access this version directly.
9532 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9537 PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9539 va_start(args, pat);
9540 sv_vcatpvf_mg(sv, pat, &args);
9546 =for apidoc sv_catpvf
9548 Processes its arguments like C<sprintf> and appends the formatted
9549 output to an SV. If the appended data contains "wide" characters
9550 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9551 and characters >255 formatted with %c), the original SV might get
9552 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
9553 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9554 valid UTF-8; if the original SV was bytes, the pattern should be too.
9559 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9563 PERL_ARGS_ASSERT_SV_CATPVF;
9565 va_start(args, pat);
9566 sv_vcatpvf(sv, pat, &args);
9571 =for apidoc sv_vcatpvf
9573 Processes its arguments like C<vsprintf> and appends the formatted output
9574 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
9576 Usually used via its frontend C<sv_catpvf>.
9582 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9584 PERL_ARGS_ASSERT_SV_VCATPVF;
9586 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9590 =for apidoc sv_catpvf_mg
9592 Like C<sv_catpvf>, but also handles 'set' magic.
9598 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9602 PERL_ARGS_ASSERT_SV_CATPVF_MG;
9604 va_start(args, pat);
9605 sv_vcatpvf_mg(sv, pat, &args);
9610 =for apidoc sv_vcatpvf_mg
9612 Like C<sv_vcatpvf>, but also handles 'set' magic.
9614 Usually used via its frontend C<sv_catpvf_mg>.
9620 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9622 PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9624 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9629 =for apidoc sv_vsetpvfn
9631 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9634 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9640 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9641 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9643 PERL_ARGS_ASSERT_SV_VSETPVFN;
9646 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9651 * Warn of missing argument to sprintf, and then return a defined value
9652 * to avoid inappropriate "use of uninit" warnings [perl #71000].
9654 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
9656 S_vcatpvfn_missing_argument(pTHX) {
9657 if (ckWARN(WARN_MISSING)) {
9658 Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
9659 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
9666 S_expect_number(pTHX_ char **const pattern)
9671 PERL_ARGS_ASSERT_EXPECT_NUMBER;
9673 switch (**pattern) {
9674 case '1': case '2': case '3':
9675 case '4': case '5': case '6':
9676 case '7': case '8': case '9':
9677 var = *(*pattern)++ - '0';
9678 while (isDIGIT(**pattern)) {
9679 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
9681 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
9689 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
9691 const int neg = nv < 0;
9694 PERL_ARGS_ASSERT_F0CONVERT;
9702 if (uv & 1 && uv == nv)
9703 uv--; /* Round to even */
9705 const unsigned dig = uv % 10;
9718 =for apidoc sv_vcatpvfn
9720 Processes its arguments like C<vsprintf> and appends the formatted output
9721 to an SV. Uses an array of SVs if the C style variable argument list is
9722 missing (NULL). When running with taint checks enabled, indicates via
9723 C<maybe_tainted> if results are untrustworthy (often due to the use of
9726 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9732 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
9733 vecstr = (U8*)SvPV_const(vecsv,veclen);\
9734 vec_utf8 = DO_UTF8(vecsv);
9736 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9739 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9740 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9748 static const char nullstr[] = "(null)";
9750 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
9751 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9753 /* Times 4: a decimal digit takes more than 3 binary digits.
9754 * NV_DIG: mantissa takes than many decimal digits.
9755 * Plus 32: Playing safe. */
9756 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9757 /* large enough for "%#.#f" --chip */
9758 /* what about long double NVs? --jhi */
9760 PERL_ARGS_ASSERT_SV_VCATPVFN;
9761 PERL_UNUSED_ARG(maybe_tainted);
9763 /* no matter what, this is a string now */
9764 (void)SvPV_force(sv, origlen);
9766 /* special-case "", "%s", and "%-p" (SVf - see below) */
9769 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9771 const char * const s = va_arg(*args, char*);
9772 sv_catpv(sv, s ? s : nullstr);
9774 else if (svix < svmax) {
9775 sv_catsv(sv, *svargs);
9778 S_vcatpvfn_missing_argument(aTHX);
9781 if (args && patlen == 3 && pat[0] == '%' &&
9782 pat[1] == '-' && pat[2] == 'p') {
9783 argsv = MUTABLE_SV(va_arg(*args, void*));
9784 sv_catsv(sv, argsv);
9788 #ifndef USE_LONG_DOUBLE
9789 /* special-case "%.<number>[gf]" */
9790 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9791 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9792 unsigned digits = 0;
9796 while (*pp >= '0' && *pp <= '9')
9797 digits = 10 * digits + (*pp++ - '0');
9798 if (pp - pat == (int)patlen - 1 && svix < svmax) {
9799 const NV nv = SvNV(*svargs);
9801 /* Add check for digits != 0 because it seems that some
9802 gconverts are buggy in this case, and we don't yet have
9803 a Configure test for this. */
9804 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9805 /* 0, point, slack */
9806 Gconvert(nv, (int)digits, 0, ebuf);
9808 if (*ebuf) /* May return an empty string for digits==0 */
9811 } else if (!digits) {
9814 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9815 sv_catpvn(sv, p, l);
9821 #endif /* !USE_LONG_DOUBLE */
9823 if (!args && svix < svmax && DO_UTF8(*svargs))
9826 patend = (char*)pat + patlen;
9827 for (p = (char*)pat; p < patend; p = q) {
9830 bool vectorize = FALSE;
9831 bool vectorarg = FALSE;
9832 bool vec_utf8 = FALSE;
9838 bool has_precis = FALSE;
9840 const I32 osvix = svix;
9841 bool is_utf8 = FALSE; /* is this item utf8? */
9842 #ifdef HAS_LDBL_SPRINTF_BUG
9843 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9844 with sfio - Allen <allens@cpan.org> */
9845 bool fix_ldbl_sprintf_bug = FALSE;
9849 U8 utf8buf[UTF8_MAXBYTES+1];
9850 STRLEN esignlen = 0;
9852 const char *eptr = NULL;
9853 const char *fmtstart;
9856 const U8 *vecstr = NULL;
9863 /* we need a long double target in case HAS_LONG_DOUBLE but
9866 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9874 const char *dotstr = ".";
9875 STRLEN dotstrlen = 1;
9876 I32 efix = 0; /* explicit format parameter index */
9877 I32 ewix = 0; /* explicit width index */
9878 I32 epix = 0; /* explicit precision index */
9879 I32 evix = 0; /* explicit vector index */
9880 bool asterisk = FALSE;
9882 /* echo everything up to the next format specification */
9883 for (q = p; q < patend && *q != '%'; ++q) ;
9885 if (has_utf8 && !pat_utf8)
9886 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9888 sv_catpvn(sv, p, q - p);
9897 We allow format specification elements in this order:
9898 \d+\$ explicit format parameter index
9900 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9901 0 flag (as above): repeated to allow "v02"
9902 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9903 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9905 [%bcdefginopsuxDFOUX] format (mandatory)
9910 As of perl5.9.3, printf format checking is on by default.
9911 Internally, perl uses %p formats to provide an escape to
9912 some extended formatting. This block deals with those
9913 extensions: if it does not match, (char*)q is reset and
9914 the normal format processing code is used.
9916 Currently defined extensions are:
9917 %p include pointer address (standard)
9918 %-p (SVf) include an SV (previously %_)
9919 %-<num>p include an SV with precision <num>
9920 %<num>p reserved for future extensions
9922 Robin Barker 2005-07-14
9924 %1p (VDf) removed. RMB 2007-10-19
9931 n = expect_number(&q);
9938 argsv = MUTABLE_SV(va_arg(*args, void*));
9939 eptr = SvPV_const(argsv, elen);
9945 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
9946 "internal %%<num>p might conflict with future printf extensions");
9952 if ( (width = expect_number(&q)) ) {
9967 if (plus == '+' && *q == ' ') /* '+' over ' ' */
9996 if ( (ewix = expect_number(&q)) )
10005 if ((vectorarg = asterisk)) {
10018 width = expect_number(&q);
10024 vecsv = va_arg(*args, SV*);
10026 vecsv = (evix > 0 && evix <= svmax)
10027 ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
10029 vecsv = svix < svmax
10030 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10032 dotstr = SvPV_const(vecsv, dotstrlen);
10033 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
10034 bad with tied or overloaded values that return UTF8. */
10035 if (DO_UTF8(vecsv))
10037 else if (has_utf8) {
10038 vecsv = sv_mortalcopy(vecsv);
10039 sv_utf8_upgrade(vecsv);
10040 dotstr = SvPV_const(vecsv, dotstrlen);
10047 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
10048 vecsv = svargs[efix ? efix-1 : svix++];
10049 vecstr = (U8*)SvPV_const(vecsv,veclen);
10050 vec_utf8 = DO_UTF8(vecsv);
10052 /* if this is a version object, we need to convert
10053 * back into v-string notation and then let the
10054 * vectorize happen normally
10056 if (sv_derived_from(vecsv, "version")) {
10057 char *version = savesvpv(vecsv);
10058 if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
10059 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
10060 "vector argument not supported with alpha versions");
10063 vecsv = sv_newmortal();
10064 scan_vstring(version, version + veclen, vecsv);
10065 vecstr = (U8*)SvPV_const(vecsv, veclen);
10066 vec_utf8 = DO_UTF8(vecsv);
10078 i = va_arg(*args, int);
10080 i = (ewix ? ewix <= svmax : svix < svmax) ?
10081 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10083 width = (i < 0) ? -i : i;
10093 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
10095 /* XXX: todo, support specified precision parameter */
10099 i = va_arg(*args, int);
10101 i = (ewix ? ewix <= svmax : svix < svmax)
10102 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10104 has_precis = !(i < 0);
10108 while (isDIGIT(*q))
10109 precis = precis * 10 + (*q++ - '0');
10118 case 'I': /* Ix, I32x, and I64x */
10120 if (q[1] == '6' && q[2] == '4') {
10126 if (q[1] == '3' && q[2] == '2') {
10136 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10147 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10148 if (*(q + 1) == 'l') { /* lld, llf */
10174 if (!vectorize && !args) {
10176 const I32 i = efix-1;
10177 argsv = (i >= 0 && i < svmax)
10178 ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
10180 argsv = (svix >= 0 && svix < svmax)
10181 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10185 switch (c = *q++) {
10192 uv = (args) ? va_arg(*args, int) : SvIV(argsv);
10194 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
10196 eptr = (char*)utf8buf;
10197 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
10211 eptr = va_arg(*args, char*);
10213 elen = strlen(eptr);
10215 eptr = (char *)nullstr;
10216 elen = sizeof nullstr - 1;
10220 eptr = SvPV_const(argsv, elen);
10221 if (DO_UTF8(argsv)) {
10222 STRLEN old_precis = precis;
10223 if (has_precis && precis < elen) {
10224 STRLEN ulen = sv_len_utf8(argsv);
10225 I32 p = precis > ulen ? ulen : precis;
10226 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
10229 if (width) { /* fudge width (can't fudge elen) */
10230 if (has_precis && precis < elen)
10231 width += precis - old_precis;
10233 width += elen - sv_len_utf8(argsv);
10240 if (has_precis && precis < elen)
10247 if (alt || vectorize)
10249 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
10270 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10279 esignbuf[esignlen++] = plus;
10283 case 'h': iv = (short)va_arg(*args, int); break;
10284 case 'l': iv = va_arg(*args, long); break;
10285 case 'V': iv = va_arg(*args, IV); break;
10286 default: iv = va_arg(*args, int); break;
10289 iv = va_arg(*args, Quad_t); break;
10296 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
10298 case 'h': iv = (short)tiv; break;
10299 case 'l': iv = (long)tiv; break;
10301 default: iv = tiv; break;
10304 iv = (Quad_t)tiv; break;
10310 if ( !vectorize ) /* we already set uv above */
10315 esignbuf[esignlen++] = plus;
10319 esignbuf[esignlen++] = '-';
10363 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10374 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
10375 case 'l': uv = va_arg(*args, unsigned long); break;
10376 case 'V': uv = va_arg(*args, UV); break;
10377 default: uv = va_arg(*args, unsigned); break;
10380 uv = va_arg(*args, Uquad_t); break;
10387 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
10389 case 'h': uv = (unsigned short)tuv; break;
10390 case 'l': uv = (unsigned long)tuv; break;
10392 default: uv = tuv; break;
10395 uv = (Uquad_t)tuv; break;
10404 char *ptr = ebuf + sizeof ebuf;
10405 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
10411 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
10415 } while (uv >>= 4);
10417 esignbuf[esignlen++] = '0';
10418 esignbuf[esignlen++] = c; /* 'x' or 'X' */
10424 *--ptr = '0' + dig;
10425 } while (uv >>= 3);
10426 if (alt && *ptr != '0')
10432 *--ptr = '0' + dig;
10433 } while (uv >>= 1);
10435 esignbuf[esignlen++] = '0';
10436 esignbuf[esignlen++] = c;
10439 default: /* it had better be ten or less */
10442 *--ptr = '0' + dig;
10443 } while (uv /= base);
10446 elen = (ebuf + sizeof ebuf) - ptr;
10450 zeros = precis - elen;
10451 else if (precis == 0 && elen == 1 && *eptr == '0'
10452 && !(base == 8 && alt)) /* "%#.0o" prints "0" */
10455 /* a precision nullifies the 0 flag. */
10462 /* FLOATING POINT */
10465 c = 'f'; /* maybe %F isn't supported here */
10467 case 'e': case 'E':
10469 case 'g': case 'G':
10473 /* This is evil, but floating point is even more evil */
10475 /* for SV-style calling, we can only get NV
10476 for C-style calling, we assume %f is double;
10477 for simplicity we allow any of %Lf, %llf, %qf for long double
10481 #if defined(USE_LONG_DOUBLE)
10485 /* [perl #20339] - we should accept and ignore %lf rather than die */
10489 #if defined(USE_LONG_DOUBLE)
10490 intsize = args ? 0 : 'q';
10494 #if defined(HAS_LONG_DOUBLE)
10503 /* now we need (long double) if intsize == 'q', else (double) */
10505 #if LONG_DOUBLESIZE > DOUBLESIZE
10507 va_arg(*args, long double) :
10508 va_arg(*args, double)
10510 va_arg(*args, double)
10515 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
10516 else. frexp() has some unspecified behaviour for those three */
10517 if (c != 'e' && c != 'E' && (nv * 0) == 0) {
10519 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
10520 will cast our (long double) to (double) */
10521 (void)Perl_frexp(nv, &i);
10522 if (i == PERL_INT_MIN)
10523 Perl_die(aTHX_ "panic: frexp");
10525 need = BIT_DIGITS(i);
10527 need += has_precis ? precis : 6; /* known default */
10532 #ifdef HAS_LDBL_SPRINTF_BUG
10533 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10534 with sfio - Allen <allens@cpan.org> */
10537 # define MY_DBL_MAX DBL_MAX
10538 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
10539 # if DOUBLESIZE >= 8
10540 # define MY_DBL_MAX 1.7976931348623157E+308L
10542 # define MY_DBL_MAX 3.40282347E+38L
10546 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10547 # define MY_DBL_MAX_BUG 1L
10549 # define MY_DBL_MAX_BUG MY_DBL_MAX
10553 # define MY_DBL_MIN DBL_MIN
10554 # else /* XXX guessing! -Allen */
10555 # if DOUBLESIZE >= 8
10556 # define MY_DBL_MIN 2.2250738585072014E-308L
10558 # define MY_DBL_MIN 1.17549435E-38L
10562 if ((intsize == 'q') && (c == 'f') &&
10563 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10564 (need < DBL_DIG)) {
10565 /* it's going to be short enough that
10566 * long double precision is not needed */
10568 if ((nv <= 0L) && (nv >= -0L))
10569 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10571 /* would use Perl_fp_class as a double-check but not
10572 * functional on IRIX - see perl.h comments */
10574 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10575 /* It's within the range that a double can represent */
10576 #if defined(DBL_MAX) && !defined(DBL_MIN)
10577 if ((nv >= ((long double)1/DBL_MAX)) ||
10578 (nv <= (-(long double)1/DBL_MAX)))
10580 fix_ldbl_sprintf_bug = TRUE;
10583 if (fix_ldbl_sprintf_bug == TRUE) {
10593 # undef MY_DBL_MAX_BUG
10596 #endif /* HAS_LDBL_SPRINTF_BUG */
10598 need += 20; /* fudge factor */
10599 if (PL_efloatsize < need) {
10600 Safefree(PL_efloatbuf);
10601 PL_efloatsize = need + 20; /* more fudge */
10602 Newx(PL_efloatbuf, PL_efloatsize, char);
10603 PL_efloatbuf[0] = '\0';
10606 if ( !(width || left || plus || alt) && fill != '0'
10607 && has_precis && intsize != 'q' ) { /* Shortcuts */
10608 /* See earlier comment about buggy Gconvert when digits,
10610 if ( c == 'g' && precis) {
10611 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10612 /* May return an empty string for digits==0 */
10613 if (*PL_efloatbuf) {
10614 elen = strlen(PL_efloatbuf);
10615 goto float_converted;
10617 } else if ( c == 'f' && !precis) {
10618 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10623 char *ptr = ebuf + sizeof ebuf;
10626 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10627 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10628 if (intsize == 'q') {
10629 /* Copy the one or more characters in a long double
10630 * format before the 'base' ([efgEFG]) character to
10631 * the format string. */
10632 static char const prifldbl[] = PERL_PRIfldbl;
10633 char const *p = prifldbl + sizeof(prifldbl) - 3;
10634 while (p >= prifldbl) { *--ptr = *p--; }
10639 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10644 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10656 /* No taint. Otherwise we are in the strange situation
10657 * where printf() taints but print($float) doesn't.
10659 #if defined(HAS_LONG_DOUBLE)
10660 elen = ((intsize == 'q')
10661 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
10662 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
10664 elen = my_sprintf(PL_efloatbuf, ptr, nv);
10668 eptr = PL_efloatbuf;
10676 i = SvCUR(sv) - origlen;
10679 case 'h': *(va_arg(*args, short*)) = i; break;
10680 default: *(va_arg(*args, int*)) = i; break;
10681 case 'l': *(va_arg(*args, long*)) = i; break;
10682 case 'V': *(va_arg(*args, IV*)) = i; break;
10685 *(va_arg(*args, Quad_t*)) = i; break;
10692 sv_setuv_mg(argsv, (UV)i);
10693 continue; /* not "break" */
10700 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
10701 && ckWARN(WARN_PRINTF))
10703 SV * const msg = sv_newmortal();
10704 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10705 (PL_op->op_type == OP_PRTF) ? "" : "s");
10706 if (fmtstart < patend) {
10707 const char * const fmtend = q < patend ? q : patend;
10709 sv_catpvs(msg, "\"%");
10710 for (f = fmtstart; f < fmtend; f++) {
10712 sv_catpvn(msg, f, 1);
10714 Perl_sv_catpvf(aTHX_ msg,
10715 "\\%03"UVof, (UV)*f & 0xFF);
10718 sv_catpvs(msg, "\"");
10720 sv_catpvs(msg, "end of string");
10722 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
10725 /* output mangled stuff ... */
10731 /* ... right here, because formatting flags should not apply */
10732 SvGROW(sv, SvCUR(sv) + elen + 1);
10734 Copy(eptr, p, elen, char);
10737 SvCUR_set(sv, p - SvPVX_const(sv));
10739 continue; /* not "break" */
10742 if (is_utf8 != has_utf8) {
10745 sv_utf8_upgrade(sv);
10748 const STRLEN old_elen = elen;
10749 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
10750 sv_utf8_upgrade(nsv);
10751 eptr = SvPVX_const(nsv);
10754 if (width) { /* fudge width (can't fudge elen) */
10755 width += elen - old_elen;
10761 have = esignlen + zeros + elen;
10763 Perl_croak_nocontext("%s", PL_memory_wrap);
10765 need = (have > width ? have : width);
10768 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
10769 Perl_croak_nocontext("%s", PL_memory_wrap);
10770 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10772 if (esignlen && fill == '0') {
10774 for (i = 0; i < (int)esignlen; i++)
10775 *p++ = esignbuf[i];
10777 if (gap && !left) {
10778 memset(p, fill, gap);
10781 if (esignlen && fill != '0') {
10783 for (i = 0; i < (int)esignlen; i++)
10784 *p++ = esignbuf[i];
10788 for (i = zeros; i; i--)
10792 Copy(eptr, p, elen, char);
10796 memset(p, ' ', gap);
10801 Copy(dotstr, p, dotstrlen, char);
10805 vectorize = FALSE; /* done iterating over vecstr */
10812 SvCUR_set(sv, p - SvPVX_const(sv));
10821 /* =========================================================================
10823 =head1 Cloning an interpreter
10825 All the macros and functions in this section are for the private use of
10826 the main function, perl_clone().
10828 The foo_dup() functions make an exact copy of an existing foo thingy.
10829 During the course of a cloning, a hash table is used to map old addresses
10830 to new addresses. The table is created and manipulated with the
10831 ptr_table_* functions.
10835 * =========================================================================*/
10838 #if defined(USE_ITHREADS)
10840 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
10841 #ifndef GpREFCNT_inc
10842 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10846 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
10847 that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
10848 If this changes, please unmerge ss_dup.
10849 Likewise, sv_dup_inc_multiple() relies on this fact. */
10850 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup_inc(s,t))
10851 #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
10852 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
10853 #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
10854 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
10855 #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
10856 #define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t))
10857 #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
10858 #define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t))
10859 #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
10860 #define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t))
10861 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
10862 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
10864 /* clone a parser */
10867 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
10871 PERL_ARGS_ASSERT_PARSER_DUP;
10876 /* look for it in the table first */
10877 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
10881 /* create anew and remember what it is */
10882 Newxz(parser, 1, yy_parser);
10883 ptr_table_store(PL_ptr_table, proto, parser);
10885 /* XXX these not yet duped */
10886 parser->old_parser = NULL;
10887 parser->stack = NULL;
10889 parser->stack_size = 0;
10890 /* XXX parser->stack->state = 0; */
10892 /* XXX eventually, just Copy() most of the parser struct ? */
10894 parser->lex_brackets = proto->lex_brackets;
10895 parser->lex_casemods = proto->lex_casemods;
10896 parser->lex_brackstack = savepvn(proto->lex_brackstack,
10897 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
10898 parser->lex_casestack = savepvn(proto->lex_casestack,
10899 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
10900 parser->lex_defer = proto->lex_defer;
10901 parser->lex_dojoin = proto->lex_dojoin;
10902 parser->lex_expect = proto->lex_expect;
10903 parser->lex_formbrack = proto->lex_formbrack;
10904 parser->lex_inpat = proto->lex_inpat;
10905 parser->lex_inwhat = proto->lex_inwhat;
10906 parser->lex_op = proto->lex_op;
10907 parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
10908 parser->lex_starts = proto->lex_starts;
10909 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
10910 parser->multi_close = proto->multi_close;
10911 parser->multi_open = proto->multi_open;
10912 parser->multi_start = proto->multi_start;
10913 parser->multi_end = proto->multi_end;
10914 parser->pending_ident = proto->pending_ident;
10915 parser->preambled = proto->preambled;
10916 parser->sublex_info = proto->sublex_info; /* XXX not quite right */
10917 parser->linestr = sv_dup_inc(proto->linestr, param);
10918 parser->expect = proto->expect;
10919 parser->copline = proto->copline;
10920 parser->last_lop_op = proto->last_lop_op;
10921 parser->lex_state = proto->lex_state;
10922 parser->rsfp = fp_dup(proto->rsfp, '<', param);
10923 /* rsfp_filters entries have fake IoDIRP() */
10924 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
10925 parser->in_my = proto->in_my;
10926 parser->in_my_stash = hv_dup(proto->in_my_stash, param);
10927 parser->error_count = proto->error_count;
10930 parser->linestr = sv_dup_inc(proto->linestr, param);
10933 char * const ols = SvPVX(proto->linestr);
10934 char * const ls = SvPVX(parser->linestr);
10936 parser->bufptr = ls + (proto->bufptr >= ols ?
10937 proto->bufptr - ols : 0);
10938 parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
10939 proto->oldbufptr - ols : 0);
10940 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
10941 proto->oldoldbufptr - ols : 0);
10942 parser->linestart = ls + (proto->linestart >= ols ?
10943 proto->linestart - ols : 0);
10944 parser->last_uni = ls + (proto->last_uni >= ols ?
10945 proto->last_uni - ols : 0);
10946 parser->last_lop = ls + (proto->last_lop >= ols ?
10947 proto->last_lop - ols : 0);
10949 parser->bufend = ls + SvCUR(parser->linestr);
10952 Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
10956 parser->endwhite = proto->endwhite;
10957 parser->faketokens = proto->faketokens;
10958 parser->lasttoke = proto->lasttoke;
10959 parser->nextwhite = proto->nextwhite;
10960 parser->realtokenstart = proto->realtokenstart;
10961 parser->skipwhite = proto->skipwhite;
10962 parser->thisclose = proto->thisclose;
10963 parser->thismad = proto->thismad;
10964 parser->thisopen = proto->thisopen;
10965 parser->thisstuff = proto->thisstuff;
10966 parser->thistoken = proto->thistoken;
10967 parser->thiswhite = proto->thiswhite;
10969 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
10970 parser->curforce = proto->curforce;
10972 Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
10973 Copy(proto->nexttype, parser->nexttype, 5, I32);
10974 parser->nexttoke = proto->nexttoke;
10977 /* XXX should clone saved_curcop here, but we aren't passed
10978 * proto_perl; so do it in perl_clone_using instead */
10984 /* duplicate a file handle */
10987 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
10991 PERL_ARGS_ASSERT_FP_DUP;
10992 PERL_UNUSED_ARG(type);
10995 return (PerlIO*)NULL;
10997 /* look for it in the table first */
10998 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
11002 /* create anew and remember what it is */
11003 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
11004 ptr_table_store(PL_ptr_table, fp, ret);
11008 /* duplicate a directory handle */
11011 Perl_dirp_dup(pTHX_ DIR *const dp)
11016 register const Direntry_t *dirent;
11017 char smallbuf[256];
11023 PERL_UNUSED_CONTEXT;
11028 /* look for it in the table first */
11029 ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
11035 /* open the current directory (so we can switch back) */
11036 if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
11038 /* chdir to our dir handle and open the present working directory */
11039 if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
11040 PerlDir_close(pwd);
11041 return (DIR *)NULL;
11043 /* Now we should have two dir handles pointing to the same dir. */
11045 /* Be nice to the calling code and chdir back to where we were. */
11046 fchdir(my_dirfd(pwd)); /* If this fails, then what? */
11048 /* We have no need of the pwd handle any more. */
11049 PerlDir_close(pwd);
11052 # define d_namlen(d) (d)->d_namlen
11054 # define d_namlen(d) strlen((d)->d_name)
11056 /* Iterate once through dp, to get the file name at the current posi-
11057 tion. Then step back. */
11058 pos = PerlDir_tell(dp);
11059 if ((dirent = PerlDir_read(dp))) {
11060 len = d_namlen(dirent);
11061 if (len <= sizeof smallbuf) name = smallbuf;
11062 else Newx(name, len, char);
11063 Move(dirent->d_name, name, len, char);
11065 PerlDir_seek(dp, pos);
11067 /* Iterate through the new dir handle, till we find a file with the
11069 if (!dirent) /* just before the end */
11071 pos = PerlDir_tell(ret);
11072 if (PerlDir_read(ret)) continue; /* not there yet */
11073 PerlDir_seek(ret, pos); /* step back */
11077 const long pos0 = PerlDir_tell(ret);
11079 pos = PerlDir_tell(ret);
11080 if ((dirent = PerlDir_read(ret))) {
11081 if (len == d_namlen(dirent)
11082 && memEQ(name, dirent->d_name, len)) {
11084 PerlDir_seek(ret, pos); /* step back */
11087 /* else we are not there yet; keep iterating */
11089 else { /* This is not meant to happen. The best we can do is
11090 reset the iterator to the beginning. */
11091 PerlDir_seek(ret, pos0);
11098 if (name && name != smallbuf)
11101 /* pop it in the pointer table */
11102 ptr_table_store(PL_ptr_table, dp, ret);
11110 /* duplicate a typeglob */
11113 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
11117 PERL_ARGS_ASSERT_GP_DUP;
11121 /* look for it in the table first */
11122 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
11126 /* create anew and remember what it is */
11128 ptr_table_store(PL_ptr_table, gp, ret);
11131 /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
11132 on Newxz() to do this for us. */
11133 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
11134 ret->gp_io = io_dup_inc(gp->gp_io, param);
11135 ret->gp_form = cv_dup_inc(gp->gp_form, param);
11136 ret->gp_av = av_dup_inc(gp->gp_av, param);
11137 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
11138 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
11139 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
11140 ret->gp_cvgen = gp->gp_cvgen;
11141 ret->gp_line = gp->gp_line;
11142 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
11146 /* duplicate a chain of magic */
11149 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
11151 MAGIC *mgret = NULL;
11152 MAGIC **mgprev_p = &mgret;
11154 PERL_ARGS_ASSERT_MG_DUP;
11156 for (; mg; mg = mg->mg_moremagic) {
11159 if ((param->flags & CLONEf_JOIN_IN)
11160 && mg->mg_type == PERL_MAGIC_backref)
11161 /* when joining, we let the individual SVs add themselves to
11162 * backref as needed. */
11165 Newx(nmg, 1, MAGIC);
11167 mgprev_p = &(nmg->mg_moremagic);
11169 /* There was a comment "XXX copy dynamic vtable?" but as we don't have
11170 dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
11171 from the original commit adding Perl_mg_dup() - revision 4538.
11172 Similarly there is the annotation "XXX random ptr?" next to the
11173 assignment to nmg->mg_ptr. */
11176 /* FIXME for plugins
11177 if (nmg->mg_type == PERL_MAGIC_qr) {
11178 nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
11182 nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
11183 ? nmg->mg_type == PERL_MAGIC_backref
11184 /* The backref AV has its reference
11185 * count deliberately bumped by 1 */
11186 ? SvREFCNT_inc(av_dup_inc((const AV *)
11187 nmg->mg_obj, param))
11188 : sv_dup_inc(nmg->mg_obj, param)
11189 : sv_dup(nmg->mg_obj, param);
11191 if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
11192 if (nmg->mg_len > 0) {
11193 nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
11194 if (nmg->mg_type == PERL_MAGIC_overload_table &&
11195 AMT_AMAGIC((AMT*)nmg->mg_ptr))
11197 AMT * const namtp = (AMT*)nmg->mg_ptr;
11198 sv_dup_inc_multiple((SV**)(namtp->table),
11199 (SV**)(namtp->table), NofAMmeth, param);
11202 else if (nmg->mg_len == HEf_SVKEY)
11203 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
11205 if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
11206 nmg->mg_virtual->svt_dup(aTHX_ nmg, param);
11212 #endif /* USE_ITHREADS */
11214 struct ptr_tbl_arena {
11215 struct ptr_tbl_arena *next;
11216 struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */
11219 /* create a new pointer-mapping table */
11222 Perl_ptr_table_new(pTHX)
11225 PERL_UNUSED_CONTEXT;
11227 Newx(tbl, 1, PTR_TBL_t);
11228 tbl->tbl_max = 511;
11229 tbl->tbl_items = 0;
11230 tbl->tbl_arena = NULL;
11231 tbl->tbl_arena_next = NULL;
11232 tbl->tbl_arena_end = NULL;
11233 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
11237 #define PTR_TABLE_HASH(ptr) \
11238 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
11240 /* map an existing pointer using a table */
11242 STATIC PTR_TBL_ENT_t *
11243 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
11245 PTR_TBL_ENT_t *tblent;
11246 const UV hash = PTR_TABLE_HASH(sv);
11248 PERL_ARGS_ASSERT_PTR_TABLE_FIND;
11250 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
11251 for (; tblent; tblent = tblent->next) {
11252 if (tblent->oldval == sv)
11259 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
11261 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
11263 PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
11264 PERL_UNUSED_CONTEXT;
11266 return tblent ? tblent->newval : NULL;
11269 /* add a new entry to a pointer-mapping table */
11272 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
11274 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
11276 PERL_ARGS_ASSERT_PTR_TABLE_STORE;
11277 PERL_UNUSED_CONTEXT;
11280 tblent->newval = newsv;
11282 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
11284 if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
11285 struct ptr_tbl_arena *new_arena;
11287 Newx(new_arena, 1, struct ptr_tbl_arena);
11288 new_arena->next = tbl->tbl_arena;
11289 tbl->tbl_arena = new_arena;
11290 tbl->tbl_arena_next = new_arena->array;
11291 tbl->tbl_arena_end = new_arena->array
11292 + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
11295 tblent = tbl->tbl_arena_next++;
11297 tblent->oldval = oldsv;
11298 tblent->newval = newsv;
11299 tblent->next = tbl->tbl_ary[entry];
11300 tbl->tbl_ary[entry] = tblent;
11302 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
11303 ptr_table_split(tbl);
11307 /* double the hash bucket size of an existing ptr table */
11310 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
11312 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
11313 const UV oldsize = tbl->tbl_max + 1;
11314 UV newsize = oldsize * 2;
11317 PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
11318 PERL_UNUSED_CONTEXT;
11320 Renew(ary, newsize, PTR_TBL_ENT_t*);
11321 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
11322 tbl->tbl_max = --newsize;
11323 tbl->tbl_ary = ary;
11324 for (i=0; i < oldsize; i++, ary++) {
11325 PTR_TBL_ENT_t **entp = ary;
11326 PTR_TBL_ENT_t *ent = *ary;
11327 PTR_TBL_ENT_t **curentp;
11330 curentp = ary + oldsize;
11332 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
11334 ent->next = *curentp;
11344 /* remove all the entries from a ptr table */
11345 /* Deprecated - will be removed post 5.14 */
11348 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
11350 if (tbl && tbl->tbl_items) {
11351 struct ptr_tbl_arena *arena = tbl->tbl_arena;
11353 Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
11356 struct ptr_tbl_arena *next = arena->next;
11362 tbl->tbl_items = 0;
11363 tbl->tbl_arena = NULL;
11364 tbl->tbl_arena_next = NULL;
11365 tbl->tbl_arena_end = NULL;
11369 /* clear and free a ptr table */
11372 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
11374 struct ptr_tbl_arena *arena;
11380 arena = tbl->tbl_arena;
11383 struct ptr_tbl_arena *next = arena->next;
11389 Safefree(tbl->tbl_ary);
11393 #if defined(USE_ITHREADS)
11396 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
11398 PERL_ARGS_ASSERT_RVPV_DUP;
11401 if (SvWEAKREF(sstr)) {
11402 SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
11403 if (param->flags & CLONEf_JOIN_IN) {
11404 /* if joining, we add any back references individually rather
11405 * than copying the whole backref array */
11406 Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
11410 SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
11412 else if (SvPVX_const(sstr)) {
11413 /* Has something there */
11415 /* Normal PV - clone whole allocated space */
11416 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
11417 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
11418 /* Not that normal - actually sstr is copy on write.
11419 But we are a true, independant SV, so: */
11420 SvREADONLY_off(dstr);
11425 /* Special case - not normally malloced for some reason */
11426 if (isGV_with_GP(sstr)) {
11427 /* Don't need to do anything here. */
11429 else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
11430 /* A "shared" PV - clone it as "shared" PV */
11432 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
11436 /* Some other special case - random pointer */
11437 SvPV_set(dstr, (char *) SvPVX_const(sstr));
11442 /* Copy the NULL */
11443 SvPV_set(dstr, NULL);
11447 /* duplicate a list of SVs. source and dest may point to the same memory. */
11449 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
11450 SSize_t items, CLONE_PARAMS *const param)
11452 PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
11454 while (items-- > 0) {
11455 *dest++ = sv_dup_inc(*source++, param);
11461 /* duplicate an SV of any type (including AV, HV etc) */
11464 S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11469 PERL_ARGS_ASSERT_SV_DUP_COMMON;
11471 if (SvTYPE(sstr) == SVTYPEMASK) {
11472 #ifdef DEBUG_LEAKING_SCALARS_ABORT
11477 /* look for it in the table first */
11478 dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
11482 if(param->flags & CLONEf_JOIN_IN) {
11483 /** We are joining here so we don't want do clone
11484 something that is bad **/
11485 if (SvTYPE(sstr) == SVt_PVHV) {
11486 const HEK * const hvname = HvNAME_HEK(sstr);
11488 /** don't clone stashes if they already exist **/
11489 dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
11490 ptr_table_store(PL_ptr_table, sstr, dstr);
11496 /* create anew and remember what it is */
11499 #ifdef DEBUG_LEAKING_SCALARS
11500 dstr->sv_debug_optype = sstr->sv_debug_optype;
11501 dstr->sv_debug_line = sstr->sv_debug_line;
11502 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
11503 dstr->sv_debug_parent = (SV*)sstr;
11504 FREE_SV_DEBUG_FILE(dstr);
11505 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
11508 ptr_table_store(PL_ptr_table, sstr, dstr);
11511 SvFLAGS(dstr) = SvFLAGS(sstr);
11512 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
11513 SvREFCNT(dstr) = 0; /* must be before any other dups! */
11516 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
11517 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
11518 (void*)PL_watch_pvx, SvPVX_const(sstr));
11521 /* don't clone objects whose class has asked us not to */
11522 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
11527 switch (SvTYPE(sstr)) {
11529 SvANY(dstr) = NULL;
11532 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
11534 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11536 SvIV_set(dstr, SvIVX(sstr));
11540 SvANY(dstr) = new_XNV();
11541 SvNV_set(dstr, SvNVX(sstr));
11543 /* case SVt_BIND: */
11546 /* These are all the types that need complex bodies allocating. */
11548 const svtype sv_type = SvTYPE(sstr);
11549 const struct body_details *const sv_type_details
11550 = bodies_by_type + sv_type;
11554 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11569 assert(sv_type_details->body_size);
11570 if (sv_type_details->arena) {
11571 new_body_inline(new_body, sv_type);
11573 = (void*)((char*)new_body - sv_type_details->offset);
11575 new_body = new_NOARENA(sv_type_details);
11579 SvANY(dstr) = new_body;
11582 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
11583 ((char*)SvANY(dstr)) + sv_type_details->offset,
11584 sv_type_details->copy, char);
11586 Copy(((char*)SvANY(sstr)),
11587 ((char*)SvANY(dstr)),
11588 sv_type_details->body_size + sv_type_details->offset, char);
11591 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
11592 && !isGV_with_GP(dstr)
11593 && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
11594 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11596 /* The Copy above means that all the source (unduplicated) pointers
11597 are now in the destination. We can check the flags and the
11598 pointers in either, but it's possible that there's less cache
11599 missing by always going for the destination.
11600 FIXME - instrument and check that assumption */
11601 if (sv_type >= SVt_PVMG) {
11602 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
11603 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
11604 } else if (SvMAGIC(dstr))
11605 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
11607 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
11610 /* The cast silences a GCC warning about unhandled types. */
11611 switch ((int)sv_type) {
11621 /* FIXME for plugins */
11622 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
11625 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
11626 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
11627 LvTARG(dstr) = dstr;
11628 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
11629 LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
11631 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
11633 /* non-GP case already handled above */
11634 if(isGV_with_GP(sstr)) {
11635 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
11636 /* Don't call sv_add_backref here as it's going to be
11637 created as part of the magic cloning of the symbol
11638 table--unless this is during a join and the stash
11639 is not actually being cloned. */
11640 /* Danger Will Robinson - GvGP(dstr) isn't initialised
11641 at the point of this comment. */
11642 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
11643 if (param->flags & CLONEf_JOIN_IN)
11644 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
11645 GvGP(dstr) = gp_dup(GvGP(sstr), param);
11646 (void)GpREFCNT_inc(GvGP(dstr));
11650 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
11651 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
11652 /* I have no idea why fake dirp (rsfps)
11653 should be treated differently but otherwise
11654 we end up with leaks -- sky*/
11655 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
11656 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
11657 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
11659 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
11660 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
11661 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
11662 if (IoDIRP(dstr)) {
11663 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
11666 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
11668 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param);
11670 if (IoOFP(dstr) == IoIFP(sstr))
11671 IoOFP(dstr) = IoIFP(dstr);
11673 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
11674 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
11675 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
11676 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
11679 /* avoid cloning an empty array */
11680 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
11681 SV **dst_ary, **src_ary;
11682 SSize_t items = AvFILLp((const AV *)sstr) + 1;
11684 src_ary = AvARRAY((const AV *)sstr);
11685 Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
11686 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
11687 AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
11688 AvALLOC((const AV *)dstr) = dst_ary;
11689 if (AvREAL((const AV *)sstr)) {
11690 dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
11694 while (items-- > 0)
11695 *dst_ary++ = sv_dup(*src_ary++, param);
11697 items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
11698 while (items-- > 0) {
11699 *dst_ary++ = &PL_sv_undef;
11703 AvARRAY(MUTABLE_AV(dstr)) = NULL;
11704 AvALLOC((const AV *)dstr) = (SV**)NULL;
11705 AvMAX( (const AV *)dstr) = -1;
11706 AvFILLp((const AV *)dstr) = -1;
11710 if (HvARRAY((const HV *)sstr)) {
11712 const bool sharekeys = !!HvSHAREKEYS(sstr);
11713 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
11714 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
11716 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
11717 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
11719 HvARRAY(dstr) = (HE**)darray;
11720 while (i <= sxhv->xhv_max) {
11721 const HE * const source = HvARRAY(sstr)[i];
11722 HvARRAY(dstr)[i] = source
11723 ? he_dup(source, sharekeys, param) : 0;
11728 const struct xpvhv_aux * const saux = HvAUX(sstr);
11729 struct xpvhv_aux * const daux = HvAUX(dstr);
11730 /* This flag isn't copied. */
11731 /* SvOOK_on(hv) attacks the IV flags. */
11732 SvFLAGS(dstr) |= SVf_OOK;
11734 hvname = saux->xhv_name;
11735 daux->xhv_name = hek_dup(hvname, param);
11737 daux->xhv_riter = saux->xhv_riter;
11738 daux->xhv_eiter = saux->xhv_eiter
11739 ? he_dup(saux->xhv_eiter,
11740 cBOOL(HvSHAREKEYS(sstr)), param) : 0;
11741 /* backref array needs refcnt=2; see sv_add_backref */
11742 daux->xhv_backreferences =
11743 (param->flags & CLONEf_JOIN_IN)
11744 /* when joining, we let the individual GVs and
11745 * CVs add themselves to backref as
11746 * needed. This avoids pulling in stuff
11747 * that isn't required, and simplifies the
11748 * case where stashes aren't cloned back
11749 * if they already exist in the parent
11752 : saux->xhv_backreferences
11753 ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
11754 ? MUTABLE_AV(SvREFCNT_inc(
11755 sv_dup_inc((const SV *)
11756 saux->xhv_backreferences, param)))
11757 : MUTABLE_AV(sv_dup((const SV *)
11758 saux->xhv_backreferences, param))
11761 daux->xhv_mro_meta = saux->xhv_mro_meta
11762 ? mro_meta_dup(saux->xhv_mro_meta, param)
11765 /* Record stashes for possible cloning in Perl_clone(). */
11767 av_push(param->stashes, dstr);
11771 HvARRAY(MUTABLE_HV(dstr)) = NULL;
11774 if (!(param->flags & CLONEf_COPY_STACKS)) {
11779 /* NOTE: not refcounted */
11780 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
11781 if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
11782 Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
11784 if (!CvISXSUB(dstr))
11785 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
11787 if (CvCONST(dstr) && CvISXSUB(dstr)) {
11788 CvXSUBANY(dstr).any_ptr =
11789 sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
11791 /* don't dup if copying back - CvGV isn't refcounted, so the
11792 * duped GV may never be freed. A bit of a hack! DAPM */
11793 SvANY(MUTABLE_CV(dstr))->xcv_gv =
11795 ? gv_dup_inc(CvGV(sstr), param)
11796 : (param->flags & CLONEf_JOIN_IN)
11798 : gv_dup(CvGV(sstr), param);
11800 CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
11802 CvWEAKOUTSIDE(sstr)
11803 ? cv_dup( CvOUTSIDE(dstr), param)
11804 : cv_dup_inc(CvOUTSIDE(dstr), param);
11805 if (!CvISXSUB(dstr))
11806 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
11812 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11819 Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11821 PERL_ARGS_ASSERT_SV_DUP_INC;
11822 return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
11826 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11828 SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
11829 PERL_ARGS_ASSERT_SV_DUP;
11831 /* Track every SV that (at least initially) had a reference count of 0.
11832 We need to do this by holding an actual reference to it in this array.
11833 If we attempt to cheat, turn AvREAL_off(), and store only pointers
11834 (akin to the stashes hash, and the perl stack), we come unstuck if
11835 a weak reference (or other SV legitimately SvREFCNT() == 0 for this
11836 thread) is manipulated in a CLONE method, because CLONE runs before the
11837 unreferenced array is walked to find SVs still with SvREFCNT() == 0
11838 (and fix things up by giving each a reference via the temps stack).
11839 Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
11840 then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
11841 before the walk of unreferenced happens and a reference to that is SV
11842 added to the temps stack. At which point we have the same SV considered
11843 to be in use, and free to be re-used. Not good.
11845 if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
11846 assert(param->unreferenced);
11847 av_push(param->unreferenced, SvREFCNT_inc(dstr));
11853 /* duplicate a context */
11856 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11858 PERL_CONTEXT *ncxs;
11860 PERL_ARGS_ASSERT_CX_DUP;
11863 return (PERL_CONTEXT*)NULL;
11865 /* look for it in the table first */
11866 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11870 /* create anew and remember what it is */
11871 Newx(ncxs, max + 1, PERL_CONTEXT);
11872 ptr_table_store(PL_ptr_table, cxs, ncxs);
11873 Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
11876 PERL_CONTEXT * const ncx = &ncxs[ix];
11877 if (CxTYPE(ncx) == CXt_SUBST) {
11878 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11881 switch (CxTYPE(ncx)) {
11883 ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
11884 ? cv_dup_inc(ncx->blk_sub.cv, param)
11885 : cv_dup(ncx->blk_sub.cv,param));
11886 ncx->blk_sub.argarray = (CxHASARGS(ncx)
11887 ? av_dup_inc(ncx->blk_sub.argarray,
11890 ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
11892 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
11893 ncx->blk_sub.oldcomppad);
11896 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
11898 ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
11900 case CXt_LOOP_LAZYSV:
11901 ncx->blk_loop.state_u.lazysv.end
11902 = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
11903 /* We are taking advantage of av_dup_inc and sv_dup_inc
11904 actually being the same function, and order equivalance of
11906 We can assert the later [but only at run time :-(] */
11907 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
11908 (void *) &ncx->blk_loop.state_u.lazysv.cur);
11910 ncx->blk_loop.state_u.ary.ary
11911 = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
11912 case CXt_LOOP_LAZYIV:
11913 case CXt_LOOP_PLAIN:
11914 if (CxPADLOOP(ncx)) {
11915 ncx->blk_loop.itervar_u.oldcomppad
11916 = (PAD*)ptr_table_fetch(PL_ptr_table,
11917 ncx->blk_loop.itervar_u.oldcomppad);
11919 ncx->blk_loop.itervar_u.gv
11920 = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
11925 ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
11926 ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
11927 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
11940 /* duplicate a stack info structure */
11943 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11947 PERL_ARGS_ASSERT_SI_DUP;
11950 return (PERL_SI*)NULL;
11952 /* look for it in the table first */
11953 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11957 /* create anew and remember what it is */
11958 Newxz(nsi, 1, PERL_SI);
11959 ptr_table_store(PL_ptr_table, si, nsi);
11961 nsi->si_stack = av_dup_inc(si->si_stack, param);
11962 nsi->si_cxix = si->si_cxix;
11963 nsi->si_cxmax = si->si_cxmax;
11964 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11965 nsi->si_type = si->si_type;
11966 nsi->si_prev = si_dup(si->si_prev, param);
11967 nsi->si_next = si_dup(si->si_next, param);
11968 nsi->si_markoff = si->si_markoff;
11973 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
11974 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
11975 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
11976 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
11977 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
11978 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
11979 #define POPUV(ss,ix) ((ss)[--(ix)].any_uv)
11980 #define TOPUV(ss,ix) ((ss)[ix].any_uv)
11981 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
11982 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
11983 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
11984 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
11985 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
11986 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
11987 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11988 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11991 #define pv_dup_inc(p) SAVEPV(p)
11992 #define pv_dup(p) SAVEPV(p)
11993 #define svp_dup_inc(p,pp) any_dup(p,pp)
11995 /* map any object to the new equivent - either something in the
11996 * ptr table, or something in the interpreter structure
12000 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
12004 PERL_ARGS_ASSERT_ANY_DUP;
12007 return (void*)NULL;
12009 /* look for it in the table first */
12010 ret = ptr_table_fetch(PL_ptr_table, v);
12014 /* see if it is part of the interpreter structure */
12015 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
12016 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
12024 /* duplicate the save stack */
12027 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
12030 ANY * const ss = proto_perl->Isavestack;
12031 const I32 max = proto_perl->Isavestack_max;
12032 I32 ix = proto_perl->Isavestack_ix;
12045 void (*dptr) (void*);
12046 void (*dxptr) (pTHX_ void*);
12048 PERL_ARGS_ASSERT_SS_DUP;
12050 Newxz(nss, max, ANY);
12053 const UV uv = POPUV(ss,ix);
12054 const U8 type = (U8)uv & SAVE_MASK;
12056 TOPUV(nss,ix) = uv;
12058 case SAVEt_CLEARSV:
12060 case SAVEt_HELEM: /* hash element */
12061 sv = (const SV *)POPPTR(ss,ix);
12062 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12064 case SAVEt_ITEM: /* normal string */
12065 case SAVEt_GVSV: /* scalar slot in GV */
12066 case SAVEt_SV: /* scalar reference */
12067 sv = (const SV *)POPPTR(ss,ix);
12068 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12071 case SAVEt_MORTALIZESV:
12072 sv = (const SV *)POPPTR(ss,ix);
12073 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12075 case SAVEt_SHARED_PVREF: /* char* in shared space */
12076 c = (char*)POPPTR(ss,ix);
12077 TOPPTR(nss,ix) = savesharedpv(c);
12078 ptr = POPPTR(ss,ix);
12079 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12081 case SAVEt_GENERIC_SVREF: /* generic sv */
12082 case SAVEt_SVREF: /* scalar reference */
12083 sv = (const SV *)POPPTR(ss,ix);
12084 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12085 ptr = POPPTR(ss,ix);
12086 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
12088 case SAVEt_HV: /* hash reference */
12089 case SAVEt_AV: /* array reference */
12090 sv = (const SV *) POPPTR(ss,ix);
12091 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12093 case SAVEt_COMPPAD:
12095 sv = (const SV *) POPPTR(ss,ix);
12096 TOPPTR(nss,ix) = sv_dup(sv, param);
12098 case SAVEt_INT: /* int reference */
12099 ptr = POPPTR(ss,ix);
12100 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12101 intval = (int)POPINT(ss,ix);
12102 TOPINT(nss,ix) = intval;
12104 case SAVEt_LONG: /* long reference */
12105 ptr = POPPTR(ss,ix);
12106 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12107 longval = (long)POPLONG(ss,ix);
12108 TOPLONG(nss,ix) = longval;
12110 case SAVEt_I32: /* I32 reference */
12111 case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
12112 ptr = POPPTR(ss,ix);
12113 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12115 TOPINT(nss,ix) = i;
12117 case SAVEt_IV: /* IV reference */
12118 ptr = POPPTR(ss,ix);
12119 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12121 TOPIV(nss,ix) = iv;
12123 case SAVEt_HPTR: /* HV* reference */
12124 case SAVEt_APTR: /* AV* reference */
12125 case SAVEt_SPTR: /* SV* reference */
12126 ptr = POPPTR(ss,ix);
12127 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12128 sv = (const SV *)POPPTR(ss,ix);
12129 TOPPTR(nss,ix) = sv_dup(sv, param);
12131 case SAVEt_VPTR: /* random* reference */
12132 ptr = POPPTR(ss,ix);
12133 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12135 case SAVEt_INT_SMALL:
12136 case SAVEt_I32_SMALL:
12137 case SAVEt_I16: /* I16 reference */
12138 case SAVEt_I8: /* I8 reference */
12140 ptr = POPPTR(ss,ix);
12141 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12143 case SAVEt_GENERIC_PVREF: /* generic char* */
12144 case SAVEt_PPTR: /* char* reference */
12145 ptr = POPPTR(ss,ix);
12146 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12147 c = (char*)POPPTR(ss,ix);
12148 TOPPTR(nss,ix) = pv_dup(c);
12150 case SAVEt_GP: /* scalar reference */
12151 gv = (const GV *)POPPTR(ss,ix);
12152 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
12153 gp = (GP*)POPPTR(ss,ix);
12154 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
12155 (void)GpREFCNT_inc(gp);
12157 TOPINT(nss,ix) = i;
12160 ptr = POPPTR(ss,ix);
12161 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
12162 /* these are assumed to be refcounted properly */
12164 switch (((OP*)ptr)->op_type) {
12166 case OP_LEAVESUBLV:
12170 case OP_LEAVEWRITE:
12171 TOPPTR(nss,ix) = ptr;
12174 (void) OpREFCNT_inc(o);
12178 TOPPTR(nss,ix) = NULL;
12183 TOPPTR(nss,ix) = NULL;
12186 hv = (const HV *)POPPTR(ss,ix);
12187 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12189 TOPINT(nss,ix) = i;
12192 c = (char*)POPPTR(ss,ix);
12193 TOPPTR(nss,ix) = pv_dup_inc(c);
12195 case SAVEt_STACK_POS: /* Position on Perl stack */
12197 TOPINT(nss,ix) = i;
12199 case SAVEt_DESTRUCTOR:
12200 ptr = POPPTR(ss,ix);
12201 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
12202 dptr = POPDPTR(ss,ix);
12203 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
12204 any_dup(FPTR2DPTR(void *, dptr),
12207 case SAVEt_DESTRUCTOR_X:
12208 ptr = POPPTR(ss,ix);
12209 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
12210 dxptr = POPDXPTR(ss,ix);
12211 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
12212 any_dup(FPTR2DPTR(void *, dxptr),
12215 case SAVEt_REGCONTEXT:
12217 ix -= uv >> SAVE_TIGHT_SHIFT;
12219 case SAVEt_AELEM: /* array element */
12220 sv = (const SV *)POPPTR(ss,ix);
12221 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12223 TOPINT(nss,ix) = i;
12224 av = (const AV *)POPPTR(ss,ix);
12225 TOPPTR(nss,ix) = av_dup_inc(av, param);
12228 ptr = POPPTR(ss,ix);
12229 TOPPTR(nss,ix) = ptr;
12232 ptr = POPPTR(ss,ix);
12235 ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
12236 HINTS_REFCNT_UNLOCK;
12238 TOPPTR(nss,ix) = ptr;
12240 TOPINT(nss,ix) = i;
12241 if (i & HINT_LOCALIZE_HH) {
12242 hv = (const HV *)POPPTR(ss,ix);
12243 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12246 case SAVEt_PADSV_AND_MORTALIZE:
12247 longval = (long)POPLONG(ss,ix);
12248 TOPLONG(nss,ix) = longval;
12249 ptr = POPPTR(ss,ix);
12250 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12251 sv = (const SV *)POPPTR(ss,ix);
12252 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12254 case SAVEt_SET_SVFLAGS:
12256 TOPINT(nss,ix) = i;
12258 TOPINT(nss,ix) = i;
12259 sv = (const SV *)POPPTR(ss,ix);
12260 TOPPTR(nss,ix) = sv_dup(sv, param);
12262 case SAVEt_RE_STATE:
12264 const struct re_save_state *const old_state
12265 = (struct re_save_state *)
12266 (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12267 struct re_save_state *const new_state
12268 = (struct re_save_state *)
12269 (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12271 Copy(old_state, new_state, 1, struct re_save_state);
12272 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
12274 new_state->re_state_bostr
12275 = pv_dup(old_state->re_state_bostr);
12276 new_state->re_state_reginput
12277 = pv_dup(old_state->re_state_reginput);
12278 new_state->re_state_regeol
12279 = pv_dup(old_state->re_state_regeol);
12280 new_state->re_state_regoffs
12281 = (regexp_paren_pair*)
12282 any_dup(old_state->re_state_regoffs, proto_perl);
12283 new_state->re_state_reglastparen
12284 = (U32*) any_dup(old_state->re_state_reglastparen,
12286 new_state->re_state_reglastcloseparen
12287 = (U32*)any_dup(old_state->re_state_reglastcloseparen,
12289 /* XXX This just has to be broken. The old save_re_context
12290 code did SAVEGENERICPV(PL_reg_start_tmp);
12291 PL_reg_start_tmp is char **.
12292 Look above to what the dup code does for
12293 SAVEt_GENERIC_PVREF
12294 It can never have worked.
12295 So this is merely a faithful copy of the exiting bug: */
12296 new_state->re_state_reg_start_tmp
12297 = (char **) pv_dup((char *)
12298 old_state->re_state_reg_start_tmp);
12299 /* I assume that it only ever "worked" because no-one called
12300 (pseudo)fork while the regexp engine had re-entered itself.
12302 #ifdef PERL_OLD_COPY_ON_WRITE
12303 new_state->re_state_nrs
12304 = sv_dup(old_state->re_state_nrs, param);
12306 new_state->re_state_reg_magic
12307 = (MAGIC*) any_dup(old_state->re_state_reg_magic,
12309 new_state->re_state_reg_oldcurpm
12310 = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
12312 new_state->re_state_reg_curpm
12313 = (PMOP*) any_dup(old_state->re_state_reg_curpm,
12315 new_state->re_state_reg_oldsaved
12316 = pv_dup(old_state->re_state_reg_oldsaved);
12317 new_state->re_state_reg_poscache
12318 = pv_dup(old_state->re_state_reg_poscache);
12319 new_state->re_state_reg_starttry
12320 = pv_dup(old_state->re_state_reg_starttry);
12323 case SAVEt_COMPILE_WARNINGS:
12324 ptr = POPPTR(ss,ix);
12325 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
12328 ptr = POPPTR(ss,ix);
12329 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
12333 "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
12341 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
12342 * flag to the result. This is done for each stash before cloning starts,
12343 * so we know which stashes want their objects cloned */
12346 do_mark_cloneable_stash(pTHX_ SV *const sv)
12348 const HEK * const hvname = HvNAME_HEK((const HV *)sv);
12350 GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
12351 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
12352 if (cloner && GvCV(cloner)) {
12359 mXPUSHs(newSVhek(hvname));
12361 call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
12368 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
12376 =for apidoc perl_clone
12378 Create and return a new interpreter by cloning the current one.
12380 perl_clone takes these flags as parameters:
12382 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
12383 without it we only clone the data and zero the stacks,
12384 with it we copy the stacks and the new perl interpreter is
12385 ready to run at the exact same point as the previous one.
12386 The pseudo-fork code uses COPY_STACKS while the
12387 threads->create doesn't.
12389 CLONEf_KEEP_PTR_TABLE
12390 perl_clone keeps a ptr_table with the pointer of the old
12391 variable as a key and the new variable as a value,
12392 this allows it to check if something has been cloned and not
12393 clone it again but rather just use the value and increase the
12394 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
12395 the ptr_table using the function
12396 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
12397 reason to keep it around is if you want to dup some of your own
12398 variable who are outside the graph perl scans, example of this
12399 code is in threads.xs create
12402 This is a win32 thing, it is ignored on unix, it tells perls
12403 win32host code (which is c++) to clone itself, this is needed on
12404 win32 if you want to run two threads at the same time,
12405 if you just want to do some stuff in a separate perl interpreter
12406 and then throw it away and return to the original one,
12407 you don't need to do anything.
12412 /* XXX the above needs expanding by someone who actually understands it ! */
12413 EXTERN_C PerlInterpreter *
12414 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
12417 perl_clone(PerlInterpreter *proto_perl, UV flags)
12420 #ifdef PERL_IMPLICIT_SYS
12422 PERL_ARGS_ASSERT_PERL_CLONE;
12424 /* perlhost.h so we need to call into it
12425 to clone the host, CPerlHost should have a c interface, sky */
12427 if (flags & CLONEf_CLONE_HOST) {
12428 return perl_clone_host(proto_perl,flags);
12430 return perl_clone_using(proto_perl, flags,
12432 proto_perl->IMemShared,
12433 proto_perl->IMemParse,
12435 proto_perl->IStdIO,
12439 proto_perl->IProc);
12443 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
12444 struct IPerlMem* ipM, struct IPerlMem* ipMS,
12445 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
12446 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
12447 struct IPerlDir* ipD, struct IPerlSock* ipS,
12448 struct IPerlProc* ipP)
12450 /* XXX many of the string copies here can be optimized if they're
12451 * constants; they need to be allocated as common memory and just
12452 * their pointers copied. */
12455 CLONE_PARAMS clone_params;
12456 CLONE_PARAMS* const param = &clone_params;
12458 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
12460 PERL_ARGS_ASSERT_PERL_CLONE_USING;
12461 #else /* !PERL_IMPLICIT_SYS */
12463 CLONE_PARAMS clone_params;
12464 CLONE_PARAMS* param = &clone_params;
12465 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
12467 PERL_ARGS_ASSERT_PERL_CLONE;
12468 #endif /* PERL_IMPLICIT_SYS */
12470 /* for each stash, determine whether its objects should be cloned */
12471 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
12472 PERL_SET_THX(my_perl);
12475 PoisonNew(my_perl, 1, PerlInterpreter);
12480 PL_scopestack_name = 0;
12482 PL_savestack_ix = 0;
12483 PL_savestack_max = -1;
12484 PL_sig_pending = 0;
12486 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
12487 # ifdef DEBUG_LEAKING_SCALARS
12488 PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
12490 #else /* !DEBUGGING */
12491 Zero(my_perl, 1, PerlInterpreter);
12492 #endif /* DEBUGGING */
12494 #ifdef PERL_IMPLICIT_SYS
12495 /* host pointers */
12497 PL_MemShared = ipMS;
12498 PL_MemParse = ipMP;
12505 #endif /* PERL_IMPLICIT_SYS */
12507 param->flags = flags;
12508 /* Nothing in the core code uses this, but we make it available to
12509 extensions (using mg_dup). */
12510 param->proto_perl = proto_perl;
12511 /* Likely nothing will use this, but it is initialised to be consistent
12512 with Perl_clone_params_new(). */
12513 param->proto_perl = my_perl;
12514 param->unreferenced = NULL;
12516 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
12518 PL_body_arenas = NULL;
12519 Zero(&PL_body_roots, 1, PL_body_roots);
12522 PL_sv_objcount = 0;
12524 PL_sv_arenaroot = NULL;
12526 PL_debug = proto_perl->Idebug;
12528 PL_hash_seed = proto_perl->Ihash_seed;
12529 PL_rehash_seed = proto_perl->Irehash_seed;
12531 #ifdef USE_REENTRANT_API
12532 /* XXX: things like -Dm will segfault here in perlio, but doing
12533 * PERL_SET_CONTEXT(proto_perl);
12534 * breaks too many other things
12536 Perl_reentrant_init(aTHX);
12539 /* create SV map for pointer relocation */
12540 PL_ptr_table = ptr_table_new();
12542 /* initialize these special pointers as early as possible */
12543 SvANY(&PL_sv_undef) = NULL;
12544 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
12545 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
12546 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
12548 SvANY(&PL_sv_no) = new_XPVNV();
12549 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
12550 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12551 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12552 SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
12553 SvCUR_set(&PL_sv_no, 0);
12554 SvLEN_set(&PL_sv_no, 1);
12555 SvIV_set(&PL_sv_no, 0);
12556 SvNV_set(&PL_sv_no, 0);
12557 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
12559 SvANY(&PL_sv_yes) = new_XPVNV();
12560 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
12561 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12562 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12563 SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
12564 SvCUR_set(&PL_sv_yes, 1);
12565 SvLEN_set(&PL_sv_yes, 2);
12566 SvIV_set(&PL_sv_yes, 1);
12567 SvNV_set(&PL_sv_yes, 1);
12568 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
12570 /* dbargs array probably holds garbage */
12573 /* create (a non-shared!) shared string table */
12574 PL_strtab = newHV();
12575 HvSHAREKEYS_off(PL_strtab);
12576 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
12577 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
12579 PL_compiling = proto_perl->Icompiling;
12581 /* These two PVs will be free'd special way so must set them same way op.c does */
12582 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
12583 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
12585 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
12586 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
12588 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
12589 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
12590 if (PL_compiling.cop_hints_hash) {
12592 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
12593 HINTS_REFCNT_UNLOCK;
12595 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
12596 #ifdef PERL_DEBUG_READONLY_OPS
12601 /* pseudo environmental stuff */
12602 PL_origargc = proto_perl->Iorigargc;
12603 PL_origargv = proto_perl->Iorigargv;
12605 param->stashes = newAV(); /* Setup array of objects to call clone on */
12606 /* This makes no difference to the implementation, as it always pushes
12607 and shifts pointers to other SVs without changing their reference
12608 count, with the array becoming empty before it is freed. However, it
12609 makes it conceptually clear what is going on, and will avoid some
12610 work inside av.c, filling slots between AvFILL() and AvMAX() with
12611 &PL_sv_undef, and SvREFCNT_dec()ing those. */
12612 AvREAL_off(param->stashes);
12614 if (!(flags & CLONEf_COPY_STACKS)) {
12615 param->unreferenced = newAV();
12618 /* Set tainting stuff before PerlIO_debug can possibly get called */
12619 PL_tainting = proto_perl->Itainting;
12620 PL_taint_warn = proto_perl->Itaint_warn;
12622 #ifdef PERLIO_LAYERS
12623 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
12624 PerlIO_clone(aTHX_ proto_perl, param);
12627 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
12628 PL_incgv = gv_dup(proto_perl->Iincgv, param);
12629 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
12630 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
12631 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
12632 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
12635 PL_minus_c = proto_perl->Iminus_c;
12636 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
12637 PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
12638 PL_localpatches = proto_perl->Ilocalpatches;
12639 PL_splitstr = proto_perl->Isplitstr;
12640 PL_minus_n = proto_perl->Iminus_n;
12641 PL_minus_p = proto_perl->Iminus_p;
12642 PL_minus_l = proto_perl->Iminus_l;
12643 PL_minus_a = proto_perl->Iminus_a;
12644 PL_minus_E = proto_perl->Iminus_E;
12645 PL_minus_F = proto_perl->Iminus_F;
12646 PL_doswitches = proto_perl->Idoswitches;
12647 PL_dowarn = proto_perl->Idowarn;
12648 PL_doextract = proto_perl->Idoextract;
12649 PL_sawampersand = proto_perl->Isawampersand;
12650 PL_unsafe = proto_perl->Iunsafe;
12651 PL_inplace = SAVEPV(proto_perl->Iinplace);
12652 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
12653 PL_perldb = proto_perl->Iperldb;
12654 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
12655 PL_exit_flags = proto_perl->Iexit_flags;
12657 /* magical thingies */
12658 /* XXX time(&PL_basetime) when asked for? */
12659 PL_basetime = proto_perl->Ibasetime;
12660 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
12662 PL_maxsysfd = proto_perl->Imaxsysfd;
12663 PL_statusvalue = proto_perl->Istatusvalue;
12665 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
12667 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
12669 PL_encoding = sv_dup(proto_perl->Iencoding, param);
12671 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
12672 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
12673 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
12676 /* RE engine related */
12677 Zero(&PL_reg_state, 1, struct re_save_state);
12678 PL_reginterp_cnt = 0;
12679 PL_regmatch_slab = NULL;
12681 /* Clone the regex array */
12682 /* ORANGE FIXME for plugins, probably in the SV dup code.
12683 newSViv(PTR2IV(CALLREGDUPE(
12684 INT2PTR(REGEXP *, SvIVX(regex)), param))))
12686 PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
12687 PL_regex_pad = AvARRAY(PL_regex_padav);
12689 /* shortcuts to various I/O objects */
12690 PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param);
12691 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
12692 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
12693 PL_defgv = gv_dup(proto_perl->Idefgv, param);
12694 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
12695 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
12696 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
12698 /* shortcuts to regexp stuff */
12699 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
12701 /* shortcuts to misc objects */
12702 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
12704 /* shortcuts to debugging objects */
12705 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
12706 PL_DBline = gv_dup(proto_perl->IDBline, param);
12707 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
12708 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
12709 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
12710 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
12712 /* symbol tables */
12713 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
12714 PL_curstash = hv_dup(proto_perl->Icurstash, param);
12715 PL_debstash = hv_dup(proto_perl->Idebstash, param);
12716 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
12717 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
12719 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
12720 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
12721 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
12722 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
12723 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
12724 PL_endav = av_dup_inc(proto_perl->Iendav, param);
12725 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
12726 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
12728 PL_sub_generation = proto_perl->Isub_generation;
12729 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
12731 /* funky return mechanisms */
12732 PL_forkprocess = proto_perl->Iforkprocess;
12734 /* subprocess state */
12735 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
12737 /* internal state */
12738 PL_maxo = proto_perl->Imaxo;
12739 if (proto_perl->Iop_mask)
12740 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
12743 /* PL_asserting = proto_perl->Iasserting; */
12745 /* current interpreter roots */
12746 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
12748 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
12750 PL_main_start = proto_perl->Imain_start;
12751 PL_eval_root = proto_perl->Ieval_root;
12752 PL_eval_start = proto_perl->Ieval_start;
12754 /* runtime control stuff */
12755 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
12757 PL_filemode = proto_perl->Ifilemode;
12758 PL_lastfd = proto_perl->Ilastfd;
12759 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
12762 PL_gensym = proto_perl->Igensym;
12763 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
12764 PL_laststatval = proto_perl->Ilaststatval;
12765 PL_laststype = proto_perl->Ilaststype;
12768 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
12770 /* interpreter atexit processing */
12771 PL_exitlistlen = proto_perl->Iexitlistlen;
12772 if (PL_exitlistlen) {
12773 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12774 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12777 PL_exitlist = (PerlExitListEntry*)NULL;
12779 PL_my_cxt_size = proto_perl->Imy_cxt_size;
12780 if (PL_my_cxt_size) {
12781 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
12782 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
12783 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12784 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
12785 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
12789 PL_my_cxt_list = (void**)NULL;
12790 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12791 PL_my_cxt_keys = (const char**)NULL;
12794 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
12795 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
12796 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
12798 PL_profiledata = NULL;
12800 PL_compcv = cv_dup(proto_perl->Icompcv, param);
12802 PAD_CLONE_VARS(proto_perl, param);
12804 #ifdef HAVE_INTERP_INTERN
12805 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
12808 /* more statics moved here */
12809 PL_generation = proto_perl->Igeneration;
12810 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
12812 PL_in_clean_objs = proto_perl->Iin_clean_objs;
12813 PL_in_clean_all = proto_perl->Iin_clean_all;
12815 PL_uid = proto_perl->Iuid;
12816 PL_euid = proto_perl->Ieuid;
12817 PL_gid = proto_perl->Igid;
12818 PL_egid = proto_perl->Iegid;
12819 PL_nomemok = proto_perl->Inomemok;
12820 PL_an = proto_perl->Ian;
12821 PL_evalseq = proto_perl->Ievalseq;
12822 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
12823 PL_origalen = proto_perl->Iorigalen;
12824 #ifdef PERL_USES_PL_PIDSTATUS
12825 PL_pidstatus = newHV(); /* XXX flag for cloning? */
12827 PL_osname = SAVEPV(proto_perl->Iosname);
12828 PL_sighandlerp = proto_perl->Isighandlerp;
12830 PL_runops = proto_perl->Irunops;
12832 PL_parser = parser_dup(proto_perl->Iparser, param);
12834 /* XXX this only works if the saved cop has already been cloned */
12835 if (proto_perl->Iparser) {
12836 PL_parser->saved_curcop = (COP*)any_dup(
12837 proto_perl->Iparser->saved_curcop,
12841 PL_subline = proto_perl->Isubline;
12842 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
12845 PL_cryptseen = proto_perl->Icryptseen;
12848 PL_hints = proto_perl->Ihints;
12850 PL_amagic_generation = proto_perl->Iamagic_generation;
12852 #ifdef USE_LOCALE_COLLATE
12853 PL_collation_ix = proto_perl->Icollation_ix;
12854 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
12855 PL_collation_standard = proto_perl->Icollation_standard;
12856 PL_collxfrm_base = proto_perl->Icollxfrm_base;
12857 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
12858 #endif /* USE_LOCALE_COLLATE */
12860 #ifdef USE_LOCALE_NUMERIC
12861 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
12862 PL_numeric_standard = proto_perl->Inumeric_standard;
12863 PL_numeric_local = proto_perl->Inumeric_local;
12864 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12865 #endif /* !USE_LOCALE_NUMERIC */
12867 /* utf8 character classes */
12868 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12869 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12870 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12871 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
12872 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12873 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
12874 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
12875 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
12876 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
12877 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
12878 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
12879 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12880 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
12881 PL_utf8_X_begin = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
12882 PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
12883 PL_utf8_X_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
12884 PL_utf8_X_non_hangul = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
12885 PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
12886 PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
12887 PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
12888 PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
12889 PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
12890 PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
12891 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12892 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12893 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12894 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12895 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12896 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12898 /* Did the locale setup indicate UTF-8? */
12899 PL_utf8locale = proto_perl->Iutf8locale;
12900 /* Unicode features (see perlrun/-C) */
12901 PL_unicode = proto_perl->Iunicode;
12903 /* Pre-5.8 signals control */
12904 PL_signals = proto_perl->Isignals;
12906 /* times() ticks per second */
12907 PL_clocktick = proto_perl->Iclocktick;
12909 /* Recursion stopper for PerlIO_find_layer */
12910 PL_in_load_module = proto_perl->Iin_load_module;
12912 /* sort() routine */
12913 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
12915 /* Not really needed/useful since the reenrant_retint is "volatile",
12916 * but do it for consistency's sake. */
12917 PL_reentrant_retint = proto_perl->Ireentrant_retint;
12919 /* Hooks to shared SVs and locks. */
12920 PL_sharehook = proto_perl->Isharehook;
12921 PL_lockhook = proto_perl->Ilockhook;
12922 PL_unlockhook = proto_perl->Iunlockhook;
12923 PL_threadhook = proto_perl->Ithreadhook;
12924 PL_destroyhook = proto_perl->Idestroyhook;
12925 PL_signalhook = proto_perl->Isignalhook;
12927 #ifdef THREADS_HAVE_PIDS
12928 PL_ppid = proto_perl->Ippid;
12932 PL_last_swash_hv = NULL; /* reinits on demand */
12933 PL_last_swash_klen = 0;
12934 PL_last_swash_key[0]= '\0';
12935 PL_last_swash_tmps = (U8*)NULL;
12936 PL_last_swash_slen = 0;
12938 PL_glob_index = proto_perl->Iglob_index;
12939 PL_srand_called = proto_perl->Isrand_called;
12941 if (proto_perl->Ipsig_pend) {
12942 Newxz(PL_psig_pend, SIG_SIZE, int);
12945 PL_psig_pend = (int*)NULL;
12948 if (proto_perl->Ipsig_name) {
12949 Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
12950 sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
12952 PL_psig_ptr = PL_psig_name + SIG_SIZE;
12955 PL_psig_ptr = (SV**)NULL;
12956 PL_psig_name = (SV**)NULL;
12959 /* intrpvar.h stuff */
12961 if (flags & CLONEf_COPY_STACKS) {
12962 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12963 PL_tmps_ix = proto_perl->Itmps_ix;
12964 PL_tmps_max = proto_perl->Itmps_max;
12965 PL_tmps_floor = proto_perl->Itmps_floor;
12966 Newx(PL_tmps_stack, PL_tmps_max, SV*);
12967 sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
12968 PL_tmps_ix+1, param);
12970 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12971 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
12972 Newxz(PL_markstack, i, I32);
12973 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
12974 - proto_perl->Imarkstack);
12975 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
12976 - proto_perl->Imarkstack);
12977 Copy(proto_perl->Imarkstack, PL_markstack,
12978 PL_markstack_ptr - PL_markstack + 1, I32);
12980 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12981 * NOTE: unlike the others! */
12982 PL_scopestack_ix = proto_perl->Iscopestack_ix;
12983 PL_scopestack_max = proto_perl->Iscopestack_max;
12984 Newxz(PL_scopestack, PL_scopestack_max, I32);
12985 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
12988 Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
12989 Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
12991 /* NOTE: si_dup() looks at PL_markstack */
12992 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
12994 /* PL_curstack = PL_curstackinfo->si_stack; */
12995 PL_curstack = av_dup(proto_perl->Icurstack, param);
12996 PL_mainstack = av_dup(proto_perl->Imainstack, param);
12998 /* next PUSHs() etc. set *(PL_stack_sp+1) */
12999 PL_stack_base = AvARRAY(PL_curstack);
13000 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
13001 - proto_perl->Istack_base);
13002 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
13004 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
13005 * NOTE: unlike the others! */
13006 PL_savestack_ix = proto_perl->Isavestack_ix;
13007 PL_savestack_max = proto_perl->Isavestack_max;
13008 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
13009 PL_savestack = ss_dup(proto_perl, param);
13013 ENTER; /* perl_destruct() wants to LEAVE; */
13016 PL_start_env = proto_perl->Istart_env; /* XXXXXX */
13017 PL_top_env = &PL_start_env;
13019 PL_op = proto_perl->Iop;
13022 PL_Xpv = (XPV*)NULL;
13023 my_perl->Ina = proto_perl->Ina;
13025 PL_statbuf = proto_perl->Istatbuf;
13026 PL_statcache = proto_perl->Istatcache;
13027 PL_statgv = gv_dup(proto_perl->Istatgv, param);
13028 PL_statname = sv_dup_inc(proto_perl->Istatname, param);
13030 PL_timesbuf = proto_perl->Itimesbuf;
13033 PL_tainted = proto_perl->Itainted;
13034 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
13035 PL_rs = sv_dup_inc(proto_perl->Irs, param);
13036 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
13037 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
13038 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
13039 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
13040 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
13041 PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
13043 PL_restartjmpenv = proto_perl->Irestartjmpenv;
13044 PL_restartop = proto_perl->Irestartop;
13045 PL_in_eval = proto_perl->Iin_eval;
13046 PL_delaymagic = proto_perl->Idelaymagic;
13047 PL_dirty = proto_perl->Idirty;
13048 PL_localizing = proto_perl->Ilocalizing;
13050 PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
13051 PL_hv_fetch_ent_mh = NULL;
13052 PL_modcount = proto_perl->Imodcount;
13053 PL_lastgotoprobe = NULL;
13054 PL_dumpindent = proto_perl->Idumpindent;
13056 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
13057 PL_sortstash = hv_dup(proto_perl->Isortstash, param);
13058 PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
13059 PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
13060 PL_efloatbuf = NULL; /* reinits on demand */
13061 PL_efloatsize = 0; /* reinits on demand */
13065 PL_screamfirst = NULL;
13066 PL_screamnext = NULL;
13067 PL_maxscream = -1; /* reinits on demand */
13068 PL_lastscream = NULL;
13071 PL_regdummy = proto_perl->Iregdummy;
13072 PL_colorset = 0; /* reinits PL_colors[] */
13073 /*PL_colors[6] = {0,0,0,0,0,0};*/
13077 /* Pluggable optimizer */
13078 PL_peepp = proto_perl->Ipeepp;
13079 PL_rpeepp = proto_perl->Irpeepp;
13080 /* op_free() hook */
13081 PL_opfreehook = proto_perl->Iopfreehook;
13083 PL_stashcache = newHV();
13085 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
13086 proto_perl->Iwatchaddr);
13087 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
13088 if (PL_debug && PL_watchaddr) {
13089 PerlIO_printf(Perl_debug_log,
13090 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
13091 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
13092 PTR2UV(PL_watchok));
13095 PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
13096 PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param);
13098 /* Call the ->CLONE method, if it exists, for each of the stashes
13099 identified by sv_dup() above.
13101 while(av_len(param->stashes) != -1) {
13102 HV* const stash = MUTABLE_HV(av_shift(param->stashes));
13103 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
13104 if (cloner && GvCV(cloner)) {
13109 mXPUSHs(newSVhek(HvNAME_HEK(stash)));
13111 call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
13117 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
13118 ptr_table_free(PL_ptr_table);
13119 PL_ptr_table = NULL;
13122 if (!(flags & CLONEf_COPY_STACKS)) {
13123 unreferenced_to_tmp_stack(param->unreferenced);
13126 SvREFCNT_dec(param->stashes);
13128 /* orphaned? eg threads->new inside BEGIN or use */
13129 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
13130 SvREFCNT_inc_simple_void(PL_compcv);
13131 SAVEFREESV(PL_compcv);
13138 S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
13140 PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
13142 if (AvFILLp(unreferenced) > -1) {
13143 SV **svp = AvARRAY(unreferenced);
13144 SV **const last = svp + AvFILLp(unreferenced);
13148 if (SvREFCNT(*svp) == 1)
13150 } while (++svp <= last);
13152 EXTEND_MORTAL(count);
13153 svp = AvARRAY(unreferenced);
13156 if (SvREFCNT(*svp) == 1) {
13157 /* Our reference is the only one to this SV. This means that
13158 in this thread, the scalar effectively has a 0 reference.
13159 That doesn't work (cleanup never happens), so donate our
13160 reference to it onto the save stack. */
13161 PL_tmps_stack[++PL_tmps_ix] = *svp;
13163 /* As an optimisation, because we are already walking the
13164 entire array, instead of above doing either
13165 SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
13166 release our reference to the scalar, so that at the end of
13167 the array owns zero references to the scalars it happens to
13168 point to. We are effectively converting the array from
13169 AvREAL() on to AvREAL() off. This saves the av_clear()
13170 (triggered by the SvREFCNT_dec(unreferenced) below) from
13171 walking the array a second time. */
13172 SvREFCNT_dec(*svp);
13175 } while (++svp <= last);
13176 AvREAL_off(unreferenced);
13178 SvREFCNT_dec(unreferenced);
13182 Perl_clone_params_del(CLONE_PARAMS *param)
13184 /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
13186 PerlInterpreter *const to = param->new_perl;
13188 PerlInterpreter *const was = PERL_GET_THX;
13190 PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
13196 SvREFCNT_dec(param->stashes);
13197 if (param->unreferenced)
13198 unreferenced_to_tmp_stack(param->unreferenced);
13208 Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
13211 /* Need to play this game, as newAV() can call safesysmalloc(), and that
13212 does a dTHX; to get the context from thread local storage.
13213 FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
13214 a version that passes in my_perl. */
13215 PerlInterpreter *const was = PERL_GET_THX;
13216 CLONE_PARAMS *param;
13218 PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
13224 /* Given that we've set the context, we can do this unshared. */
13225 Newx(param, 1, CLONE_PARAMS);
13228 param->proto_perl = from;
13229 param->new_perl = to;
13230 param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
13231 AvREAL_off(param->stashes);
13232 param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
13240 #endif /* USE_ITHREADS */
13243 =head1 Unicode Support
13245 =for apidoc sv_recode_to_utf8
13247 The encoding is assumed to be an Encode object, on entry the PV
13248 of the sv is assumed to be octets in that encoding, and the sv
13249 will be converted into Unicode (and UTF-8).
13251 If the sv already is UTF-8 (or if it is not POK), or if the encoding
13252 is not a reference, nothing is done to the sv. If the encoding is not
13253 an C<Encode::XS> Encoding object, bad things will happen.
13254 (See F<lib/encoding.pm> and L<Encode>).
13256 The PV of the sv is returned.
13261 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
13265 PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
13267 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
13281 Passing sv_yes is wrong - it needs to be or'ed set of constants
13282 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
13283 remove converted chars from source.
13285 Both will default the value - let them.
13287 XPUSHs(&PL_sv_yes);
13290 call_method("decode", G_SCALAR);
13294 s = SvPV_const(uni, len);
13295 if (s != SvPVX_const(sv)) {
13296 SvGROW(sv, len + 1);
13297 Move(s, SvPVX(sv), len + 1, char);
13298 SvCUR_set(sv, len);
13305 return SvPOKp(sv) ? SvPVX(sv) : NULL;
13309 =for apidoc sv_cat_decode
13311 The encoding is assumed to be an Encode object, the PV of the ssv is
13312 assumed to be octets in that encoding and decoding the input starts
13313 from the position which (PV + *offset) pointed to. The dsv will be
13314 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
13315 when the string tstr appears in decoding output or the input ends on
13316 the PV of the ssv. The value which the offset points will be modified
13317 to the last input position on the ssv.
13319 Returns TRUE if the terminator was found, else returns FALSE.
13324 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
13325 SV *ssv, int *offset, char *tstr, int tlen)
13330 PERL_ARGS_ASSERT_SV_CAT_DECODE;
13332 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
13343 offsv = newSViv(*offset);
13345 mXPUSHp(tstr, tlen);
13347 call_method("cat_decode", G_SCALAR);
13349 ret = SvTRUE(TOPs);
13350 *offset = SvIV(offsv);
13356 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
13361 /* ---------------------------------------------------------------------
13363 * support functions for report_uninit()
13366 /* the maxiumum size of array or hash where we will scan looking
13367 * for the undefined element that triggered the warning */
13369 #define FUV_MAX_SEARCH_SIZE 1000
13371 /* Look for an entry in the hash whose value has the same SV as val;
13372 * If so, return a mortal copy of the key. */
13375 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
13378 register HE **array;
13381 PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
13383 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
13384 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
13387 array = HvARRAY(hv);
13389 for (i=HvMAX(hv); i>0; i--) {
13390 register HE *entry;
13391 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
13392 if (HeVAL(entry) != val)
13394 if ( HeVAL(entry) == &PL_sv_undef ||
13395 HeVAL(entry) == &PL_sv_placeholder)
13399 if (HeKLEN(entry) == HEf_SVKEY)
13400 return sv_mortalcopy(HeKEY_sv(entry));
13401 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
13407 /* Look for an entry in the array whose value has the same SV as val;
13408 * If so, return the index, otherwise return -1. */
13411 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
13415 PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
13417 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
13418 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
13421 if (val != &PL_sv_undef) {
13422 SV ** const svp = AvARRAY(av);
13425 for (i=AvFILLp(av); i>=0; i--)
13432 /* S_varname(): return the name of a variable, optionally with a subscript.
13433 * If gv is non-zero, use the name of that global, along with gvtype (one
13434 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
13435 * targ. Depending on the value of the subscript_type flag, return:
13438 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
13439 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
13440 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
13441 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
13444 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
13445 const SV *const keyname, I32 aindex, int subscript_type)
13448 SV * const name = sv_newmortal();
13451 buffer[0] = gvtype;
13454 /* as gv_fullname4(), but add literal '^' for $^FOO names */
13456 gv_fullname4(name, gv, buffer, 0);
13458 if ((unsigned int)SvPVX(name)[1] <= 26) {
13460 buffer[1] = SvPVX(name)[1] + 'A' - 1;
13462 /* Swap the 1 unprintable control character for the 2 byte pretty
13463 version - ie substr($name, 1, 1) = $buffer; */
13464 sv_insert(name, 1, 1, buffer, 2);
13468 CV * const cv = find_runcv(NULL);
13472 if (!cv || !CvPADLIST(cv))
13474 av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
13475 sv = *av_fetch(av, targ, FALSE);
13476 sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
13479 if (subscript_type == FUV_SUBSCRIPT_HASH) {
13480 SV * const sv = newSV(0);
13481 *SvPVX(name) = '$';
13482 Perl_sv_catpvf(aTHX_ name, "{%s}",
13483 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
13486 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
13487 *SvPVX(name) = '$';
13488 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
13490 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
13491 /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
13492 Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
13500 =for apidoc find_uninit_var
13502 Find the name of the undefined variable (if any) that caused the operator o
13503 to issue a "Use of uninitialized value" warning.
13504 If match is true, only return a name if it's value matches uninit_sv.
13505 So roughly speaking, if a unary operator (such as OP_COS) generates a
13506 warning, then following the direct child of the op may yield an
13507 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
13508 other hand, with OP_ADD there are two branches to follow, so we only print
13509 the variable name if we get an exact match.
13511 The name is returned as a mortal SV.
13513 Assumes that PL_op is the op that originally triggered the error, and that
13514 PL_comppad/PL_curpad points to the currently executing pad.
13520 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
13526 const OP *o, *o2, *kid;
13528 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
13529 uninit_sv == &PL_sv_placeholder)))
13532 switch (obase->op_type) {
13539 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
13540 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
13543 int subscript_type = FUV_SUBSCRIPT_WITHIN;
13545 if (pad) { /* @lex, %lex */
13546 sv = PAD_SVl(obase->op_targ);
13550 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
13551 /* @global, %global */
13552 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
13555 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
13557 else /* @{expr}, %{expr} */
13558 return find_uninit_var(cUNOPx(obase)->op_first,
13562 /* attempt to find a match within the aggregate */
13564 keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13566 subscript_type = FUV_SUBSCRIPT_HASH;
13569 index = find_array_subscript((const AV *)sv, uninit_sv);
13571 subscript_type = FUV_SUBSCRIPT_ARRAY;
13574 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
13577 return varname(gv, hash ? '%' : '@', obase->op_targ,
13578 keysv, index, subscript_type);
13582 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
13584 return varname(NULL, '$', obase->op_targ,
13585 NULL, 0, FUV_SUBSCRIPT_NONE);
13588 gv = cGVOPx_gv(obase);
13589 if (!gv || (match && GvSV(gv) != uninit_sv))
13591 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
13594 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
13597 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
13598 if (!av || SvRMAGICAL(av))
13600 svp = av_fetch(av, (I32)obase->op_private, FALSE);
13601 if (!svp || *svp != uninit_sv)
13604 return varname(NULL, '$', obase->op_targ,
13605 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
13608 gv = cGVOPx_gv(obase);
13613 AV *const av = GvAV(gv);
13614 if (!av || SvRMAGICAL(av))
13616 svp = av_fetch(av, (I32)obase->op_private, FALSE);
13617 if (!svp || *svp != uninit_sv)
13620 return varname(gv, '$', 0,
13621 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
13626 o = cUNOPx(obase)->op_first;
13627 if (!o || o->op_type != OP_NULL ||
13628 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
13630 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
13634 if (PL_op == obase)
13635 /* $a[uninit_expr] or $h{uninit_expr} */
13636 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
13639 o = cBINOPx(obase)->op_first;
13640 kid = cBINOPx(obase)->op_last;
13642 /* get the av or hv, and optionally the gv */
13644 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
13645 sv = PAD_SV(o->op_targ);
13647 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
13648 && cUNOPo->op_first->op_type == OP_GV)
13650 gv = cGVOPx_gv(cUNOPo->op_first);
13654 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
13659 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
13660 /* index is constant */
13664 if (obase->op_type == OP_HELEM) {
13665 HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
13666 if (!he || HeVAL(he) != uninit_sv)
13670 SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
13671 if (!svp || *svp != uninit_sv)
13675 if (obase->op_type == OP_HELEM)
13676 return varname(gv, '%', o->op_targ,
13677 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
13679 return varname(gv, '@', o->op_targ, NULL,
13680 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
13683 /* index is an expression;
13684 * attempt to find a match within the aggregate */
13685 if (obase->op_type == OP_HELEM) {
13686 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13688 return varname(gv, '%', o->op_targ,
13689 keysv, 0, FUV_SUBSCRIPT_HASH);
13693 = find_array_subscript((const AV *)sv, uninit_sv);
13695 return varname(gv, '@', o->op_targ,
13696 NULL, index, FUV_SUBSCRIPT_ARRAY);
13701 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
13703 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
13708 /* only examine RHS */
13709 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
13712 o = cUNOPx(obase)->op_first;
13713 if (o->op_type == OP_PUSHMARK)
13716 if (!o->op_sibling) {
13717 /* one-arg version of open is highly magical */
13719 if (o->op_type == OP_GV) { /* open FOO; */
13721 if (match && GvSV(gv) != uninit_sv)
13723 return varname(gv, '$', 0,
13724 NULL, 0, FUV_SUBSCRIPT_NONE);
13726 /* other possibilities not handled are:
13727 * open $x; or open my $x; should return '${*$x}'
13728 * open expr; should return '$'.expr ideally
13734 /* ops where $_ may be an implicit arg */
13738 if ( !(obase->op_flags & OPf_STACKED)) {
13739 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
13740 ? PAD_SVl(obase->op_targ)
13743 sv = sv_newmortal();
13744 sv_setpvs(sv, "$_");
13753 match = 1; /* print etc can return undef on defined args */
13754 /* skip filehandle as it can't produce 'undef' warning */
13755 o = cUNOPx(obase)->op_first;
13756 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
13757 o = o->op_sibling->op_sibling;
13761 case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
13763 case OP_CUSTOM: /* XS or custom code could trigger random warnings */
13765 /* the following ops are capable of returning PL_sv_undef even for
13766 * defined arg(s) */
13785 case OP_GETPEERNAME:
13833 case OP_SMARTMATCH:
13842 /* XXX tmp hack: these two may call an XS sub, and currently
13843 XS subs don't have a SUB entry on the context stack, so CV and
13844 pad determination goes wrong, and BAD things happen. So, just
13845 don't try to determine the value under those circumstances.
13846 Need a better fix at dome point. DAPM 11/2007 */
13852 GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
13853 if (gv && GvSV(gv) == uninit_sv)
13854 return newSVpvs_flags("$.", SVs_TEMP);
13859 /* def-ness of rval pos() is independent of the def-ness of its arg */
13860 if ( !(obase->op_flags & OPf_MOD))
13865 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
13866 return newSVpvs_flags("${$/}", SVs_TEMP);
13871 if (!(obase->op_flags & OPf_KIDS))
13873 o = cUNOPx(obase)->op_first;
13879 /* if all except one arg are constant, or have no side-effects,
13880 * or are optimized away, then it's unambiguous */
13882 for (kid=o; kid; kid = kid->op_sibling) {
13884 const OPCODE type = kid->op_type;
13885 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
13886 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
13887 || (type == OP_PUSHMARK)
13891 if (o2) { /* more than one found */
13898 return find_uninit_var(o2, uninit_sv, match);
13900 /* scan all args */
13902 sv = find_uninit_var(o, uninit_sv, 1);
13914 =for apidoc report_uninit
13916 Print appropriate "Use of uninitialized variable" warning
13922 Perl_report_uninit(pTHX_ const SV *uninit_sv)
13926 SV* varname = NULL;
13928 varname = find_uninit_var(PL_op, uninit_sv,0);
13930 sv_insert(varname, 0, 0, " ", 1);
13932 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13933 varname ? SvPV_nolen_const(varname) : "",
13934 " in ", OP_DESC(PL_op));
13937 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13943 * c-indentation-style: bsd
13944 * c-basic-offset: 4
13945 * indent-tabs-mode: t
13948 * ex: set ts=8 sts=4 sw=4 noet: