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 if((old_stash = GvHV(dstr)))
3633 /* Make sure we do not lose it early. */
3634 SvREFCNT_inc_simple_void_NN(
3635 sv_2mortal((SV *)old_stash)
3641 gp_free(MUTABLE_GV(dstr));
3642 isGV_with_GP_off(dstr);
3643 (void)SvOK_off(dstr);
3644 isGV_with_GP_on(dstr);
3645 GvINTRO_off(dstr); /* one-shot flag */
3646 GvGP(dstr) = gp_ref(GvGP(sstr));
3647 if (SvTAINTED(sstr))
3649 if (GvIMPORTED(dstr) != GVf_IMPORTED
3650 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3652 GvIMPORTED_on(dstr);
3655 if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
3656 else if(mro_changes == 3) {
3657 HV * const stash = GvHV(dstr);
3658 if((stash && HvNAME(stash)) || (old_stash && HvNAME(old_stash)))
3660 stash && HvNAME(stash) ? stash : NULL,
3661 old_stash && HvNAME(old_stash) ? old_stash : NULL,
3665 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3670 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3672 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3674 const int intro = GvINTRO(dstr);
3677 const U32 stype = SvTYPE(sref);
3679 PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3682 GvINTRO_off(dstr); /* one-shot flag */
3683 GvLINE(dstr) = CopLINE(PL_curcop);
3684 GvEGV(dstr) = MUTABLE_GV(dstr);
3689 location = (SV **) &GvCV(dstr);
3690 import_flag = GVf_IMPORTED_CV;
3693 location = (SV **) &GvHV(dstr);
3694 import_flag = GVf_IMPORTED_HV;
3697 location = (SV **) &GvAV(dstr);
3698 import_flag = GVf_IMPORTED_AV;
3701 location = (SV **) &GvIOp(dstr);
3704 location = (SV **) &GvFORM(dstr);
3707 location = &GvSV(dstr);
3708 import_flag = GVf_IMPORTED_SV;
3711 if (stype == SVt_PVCV) {
3712 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3713 if (GvCVGEN(dstr)) {
3714 SvREFCNT_dec(GvCV(dstr));
3716 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3719 SAVEGENERICSV(*location);
3723 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3724 CV* const cv = MUTABLE_CV(*location);
3726 if (!GvCVGEN((const GV *)dstr) &&
3727 (CvROOT(cv) || CvXSUB(cv)))
3729 /* Redefining a sub - warning is mandatory if
3730 it was a const and its value changed. */
3731 if (CvCONST(cv) && CvCONST((const CV *)sref)
3733 == cv_const_sv((const CV *)sref)) {
3735 /* They are 2 constant subroutines generated from
3736 the same constant. This probably means that
3737 they are really the "same" proxy subroutine
3738 instantiated in 2 places. Most likely this is
3739 when a constant is exported twice. Don't warn.
3742 else if (ckWARN(WARN_REDEFINE)
3744 && (!CvCONST((const CV *)sref)
3745 || sv_cmp(cv_const_sv(cv),
3746 cv_const_sv((const CV *)
3748 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3751 ? "Constant subroutine %s::%s redefined"
3752 : "Subroutine %s::%s redefined"),
3753 HvNAME_get(GvSTASH((const GV *)dstr)),
3754 GvENAME(MUTABLE_GV(dstr)));
3758 cv_ckproto_len(cv, (const GV *)dstr,
3759 SvPOK(sref) ? SvPVX_const(sref) : NULL,
3760 SvPOK(sref) ? SvCUR(sref) : 0);
3762 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3763 GvASSUMECV_on(dstr);
3764 if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3767 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3768 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3769 GvFLAGS(dstr) |= import_flag;
3771 if (stype == SVt_PVHV) {
3772 const char * const name = GvNAME((GV*)dstr);
3773 const STRLEN len = GvNAMELEN(dstr);
3775 len > 1 && name[len-2] == ':' && name[len-1] == ':'
3776 && (HvNAME(dref) || HvNAME(sref))
3779 HvNAME(sref) ? (HV *)sref : NULL,
3780 HvNAME(dref) ? (HV *)dref : NULL,
3785 else if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
3786 sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3787 mro_isa_changed_in(GvSTASH(dstr));
3792 if (SvTAINTED(sstr))
3798 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3801 register U32 sflags;
3803 register svtype stype;
3805 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3810 if (SvIS_FREED(dstr)) {
3811 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3812 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3814 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3816 sstr = &PL_sv_undef;
3817 if (SvIS_FREED(sstr)) {
3818 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3819 (void*)sstr, (void*)dstr);
3821 stype = SvTYPE(sstr);
3822 dtype = SvTYPE(dstr);
3824 (void)SvAMAGIC_off(dstr);
3827 /* need to nuke the magic */
3831 /* There's a lot of redundancy below but we're going for speed here */
3836 if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
3837 (void)SvOK_off(dstr);
3845 sv_upgrade(dstr, SVt_IV);
3849 sv_upgrade(dstr, SVt_PVIV);
3853 goto end_of_first_switch;
3855 (void)SvIOK_only(dstr);
3856 SvIV_set(dstr, SvIVX(sstr));
3859 /* SvTAINTED can only be true if the SV has taint magic, which in
3860 turn means that the SV type is PVMG (or greater). This is the
3861 case statement for SVt_IV, so this cannot be true (whatever gcov
3863 assert(!SvTAINTED(sstr));
3868 if (dtype < SVt_PV && dtype != SVt_IV)
3869 sv_upgrade(dstr, SVt_IV);
3877 sv_upgrade(dstr, SVt_NV);
3881 sv_upgrade(dstr, SVt_PVNV);
3885 goto end_of_first_switch;
3887 SvNV_set(dstr, SvNVX(sstr));
3888 (void)SvNOK_only(dstr);
3889 /* SvTAINTED can only be true if the SV has taint magic, which in
3890 turn means that the SV type is PVMG (or greater). This is the
3891 case statement for SVt_NV, so this cannot be true (whatever gcov
3893 assert(!SvTAINTED(sstr));
3899 #ifdef PERL_OLD_COPY_ON_WRITE
3900 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3901 if (dtype < SVt_PVIV)
3902 sv_upgrade(dstr, SVt_PVIV);
3909 sv_upgrade(dstr, SVt_PV);
3912 if (dtype < SVt_PVIV)
3913 sv_upgrade(dstr, SVt_PVIV);
3916 if (dtype < SVt_PVNV)
3917 sv_upgrade(dstr, SVt_PVNV);
3921 const char * const type = sv_reftype(sstr,0);
3923 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
3925 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3930 if (dtype < SVt_REGEXP)
3931 sv_upgrade(dstr, SVt_REGEXP);
3934 /* case SVt_BIND: */
3937 if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
3938 glob_assign_glob(dstr, sstr, dtype);
3941 /* SvVALID means that this PVGV is playing at being an FBM. */
3945 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3947 if (SvTYPE(sstr) != stype)
3948 stype = SvTYPE(sstr);
3949 if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
3950 glob_assign_glob(dstr, sstr, dtype);
3954 if (stype == SVt_PVLV)
3955 SvUPGRADE(dstr, SVt_PVNV);
3957 SvUPGRADE(dstr, (svtype)stype);
3959 end_of_first_switch:
3961 /* dstr may have been upgraded. */
3962 dtype = SvTYPE(dstr);
3963 sflags = SvFLAGS(sstr);
3965 if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
3966 /* Assigning to a subroutine sets the prototype. */
3969 const char *const ptr = SvPV_const(sstr, len);
3971 SvGROW(dstr, len + 1);
3972 Copy(ptr, SvPVX(dstr), len + 1, char);
3973 SvCUR_set(dstr, len);
3975 SvFLAGS(dstr) |= sflags & SVf_UTF8;
3979 } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3980 const char * const type = sv_reftype(dstr,0);
3982 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
3984 Perl_croak(aTHX_ "Cannot copy to %s", type);
3985 } else if (sflags & SVf_ROK) {
3986 if (isGV_with_GP(dstr)
3987 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
3990 if (GvIMPORTED(dstr) != GVf_IMPORTED
3991 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3993 GvIMPORTED_on(dstr);
3998 glob_assign_glob(dstr, sstr, dtype);
4002 if (dtype >= SVt_PV) {
4003 if (isGV_with_GP(dstr)) {
4004 glob_assign_ref(dstr, sstr);
4007 if (SvPVX_const(dstr)) {
4013 (void)SvOK_off(dstr);
4014 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4015 SvFLAGS(dstr) |= sflags & SVf_ROK;
4016 assert(!(sflags & SVp_NOK));
4017 assert(!(sflags & SVp_IOK));
4018 assert(!(sflags & SVf_NOK));
4019 assert(!(sflags & SVf_IOK));
4021 else if (isGV_with_GP(dstr)) {
4022 if (!(sflags & SVf_OK)) {
4023 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4024 "Undefined value assigned to typeglob");
4027 GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
4028 if (dstr != (const SV *)gv) {
4029 const char * const name = GvNAME((const GV *)dstr);
4030 const STRLEN len = GvNAMELEN(dstr);
4031 HV *old_stash = NULL;
4032 bool reset_isa = FALSE;
4033 if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
4034 /* Set aside the old stash, so we can reset isa caches
4035 on its subclasses. */
4036 old_stash = GvHV(dstr);
4041 gp_free(MUTABLE_GV(dstr));
4042 GvGP(dstr) = gp_ref(GvGP(gv));
4045 HV * const stash = GvHV(dstr);
4047 (stash && HvNAME(stash))
4048 || (old_stash && HvNAME(old_stash))
4051 stash && HvNAME(stash) ? stash : NULL,
4052 old_stash && HvNAME(old_stash) ? old_stash : NULL,
4059 else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
4060 reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4062 else if (sflags & SVp_POK) {
4066 * Check to see if we can just swipe the string. If so, it's a
4067 * possible small lose on short strings, but a big win on long ones.
4068 * It might even be a win on short strings if SvPVX_const(dstr)
4069 * has to be allocated and SvPVX_const(sstr) has to be freed.
4070 * Likewise if we can set up COW rather than doing an actual copy, we
4071 * drop to the else clause, as the swipe code and the COW setup code
4072 * have much in common.
4075 /* Whichever path we take through the next code, we want this true,
4076 and doing it now facilitates the COW check. */
4077 (void)SvPOK_only(dstr);
4080 /* If we're already COW then this clause is not true, and if COW
4081 is allowed then we drop down to the else and make dest COW
4082 with us. If caller hasn't said that we're allowed to COW
4083 shared hash keys then we don't do the COW setup, even if the
4084 source scalar is a shared hash key scalar. */
4085 (((flags & SV_COW_SHARED_HASH_KEYS)
4086 ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4087 : 1 /* If making a COW copy is forbidden then the behaviour we
4088 desire is as if the source SV isn't actually already
4089 COW, even if it is. So we act as if the source flags
4090 are not COW, rather than actually testing them. */
4092 #ifndef PERL_OLD_COPY_ON_WRITE
4093 /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4094 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4095 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4096 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4097 but in turn, it's somewhat dead code, never expected to go
4098 live, but more kept as a placeholder on how to do it better
4099 in a newer implementation. */
4100 /* If we are COW and dstr is a suitable target then we drop down
4101 into the else and make dest a COW of us. */
4102 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4107 (sflags & SVs_TEMP) && /* slated for free anyway? */
4108 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4109 (!(flags & SV_NOSTEAL)) &&
4110 /* and we're allowed to steal temps */
4111 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4112 SvLEN(sstr)) /* and really is a string */
4113 #ifdef PERL_OLD_COPY_ON_WRITE
4114 && ((flags & SV_COW_SHARED_HASH_KEYS)
4115 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4116 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4117 && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4121 /* Failed the swipe test, and it's not a shared hash key either.
4122 Have to copy the string. */
4123 STRLEN len = SvCUR(sstr);
4124 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4125 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4126 SvCUR_set(dstr, len);
4127 *SvEND(dstr) = '\0';
4129 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4131 /* Either it's a shared hash key, or it's suitable for
4132 copy-on-write or we can swipe the string. */
4134 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4138 #ifdef PERL_OLD_COPY_ON_WRITE
4140 if ((sflags & (SVf_FAKE | SVf_READONLY))
4141 != (SVf_FAKE | SVf_READONLY)) {
4142 SvREADONLY_on(sstr);
4144 /* Make the source SV into a loop of 1.
4145 (about to become 2) */
4146 SV_COW_NEXT_SV_SET(sstr, sstr);
4150 /* Initial code is common. */
4151 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4156 /* making another shared SV. */
4157 STRLEN cur = SvCUR(sstr);
4158 STRLEN len = SvLEN(sstr);
4159 #ifdef PERL_OLD_COPY_ON_WRITE
4161 assert (SvTYPE(dstr) >= SVt_PVIV);
4162 /* SvIsCOW_normal */
4163 /* splice us in between source and next-after-source. */
4164 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4165 SV_COW_NEXT_SV_SET(sstr, dstr);
4166 SvPV_set(dstr, SvPVX_mutable(sstr));
4170 /* SvIsCOW_shared_hash */
4171 DEBUG_C(PerlIO_printf(Perl_debug_log,
4172 "Copy on write: Sharing hash\n"));
4174 assert (SvTYPE(dstr) >= SVt_PV);
4176 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4178 SvLEN_set(dstr, len);
4179 SvCUR_set(dstr, cur);
4180 SvREADONLY_on(dstr);
4184 { /* Passes the swipe test. */
4185 SvPV_set(dstr, SvPVX_mutable(sstr));
4186 SvLEN_set(dstr, SvLEN(sstr));
4187 SvCUR_set(dstr, SvCUR(sstr));
4190 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4191 SvPV_set(sstr, NULL);
4197 if (sflags & SVp_NOK) {
4198 SvNV_set(dstr, SvNVX(sstr));
4200 if (sflags & SVp_IOK) {
4201 SvIV_set(dstr, SvIVX(sstr));
4202 /* Must do this otherwise some other overloaded use of 0x80000000
4203 gets confused. I guess SVpbm_VALID */
4204 if (sflags & SVf_IVisUV)
4207 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4209 const MAGIC * const smg = SvVSTRING_mg(sstr);
4211 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4212 smg->mg_ptr, smg->mg_len);
4213 SvRMAGICAL_on(dstr);
4217 else if (sflags & (SVp_IOK|SVp_NOK)) {
4218 (void)SvOK_off(dstr);
4219 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4220 if (sflags & SVp_IOK) {
4221 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4222 SvIV_set(dstr, SvIVX(sstr));
4224 if (sflags & SVp_NOK) {
4225 SvNV_set(dstr, SvNVX(sstr));
4229 if (isGV_with_GP(sstr)) {
4230 /* This stringification rule for globs is spread in 3 places.
4231 This feels bad. FIXME. */
4232 const U32 wasfake = sflags & SVf_FAKE;
4234 /* FAKE globs can get coerced, so need to turn this off
4235 temporarily if it is on. */
4237 gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4238 SvFLAGS(sstr) |= wasfake;
4241 (void)SvOK_off(dstr);
4243 if (SvTAINTED(sstr))
4248 =for apidoc sv_setsv_mg
4250 Like C<sv_setsv>, but also handles 'set' magic.
4256 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4258 PERL_ARGS_ASSERT_SV_SETSV_MG;
4260 sv_setsv(dstr,sstr);
4264 #ifdef PERL_OLD_COPY_ON_WRITE
4266 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4268 STRLEN cur = SvCUR(sstr);
4269 STRLEN len = SvLEN(sstr);
4270 register char *new_pv;
4272 PERL_ARGS_ASSERT_SV_SETSV_COW;
4275 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4276 (void*)sstr, (void*)dstr);
4283 if (SvTHINKFIRST(dstr))
4284 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4285 else if (SvPVX_const(dstr))
4286 Safefree(SvPVX_const(dstr));
4290 SvUPGRADE(dstr, SVt_PVIV);
4292 assert (SvPOK(sstr));
4293 assert (SvPOKp(sstr));
4294 assert (!SvIOK(sstr));
4295 assert (!SvIOKp(sstr));
4296 assert (!SvNOK(sstr));
4297 assert (!SvNOKp(sstr));
4299 if (SvIsCOW(sstr)) {
4301 if (SvLEN(sstr) == 0) {
4302 /* source is a COW shared hash key. */
4303 DEBUG_C(PerlIO_printf(Perl_debug_log,
4304 "Fast copy on write: Sharing hash\n"));
4305 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4308 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4310 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4311 SvUPGRADE(sstr, SVt_PVIV);
4312 SvREADONLY_on(sstr);
4314 DEBUG_C(PerlIO_printf(Perl_debug_log,
4315 "Fast copy on write: Converting sstr to COW\n"));
4316 SV_COW_NEXT_SV_SET(dstr, sstr);
4318 SV_COW_NEXT_SV_SET(sstr, dstr);
4319 new_pv = SvPVX_mutable(sstr);
4322 SvPV_set(dstr, new_pv);
4323 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4326 SvLEN_set(dstr, len);
4327 SvCUR_set(dstr, cur);
4336 =for apidoc sv_setpvn
4338 Copies a string into an SV. The C<len> parameter indicates the number of
4339 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4340 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4346 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4349 register char *dptr;
4351 PERL_ARGS_ASSERT_SV_SETPVN;
4353 SV_CHECK_THINKFIRST_COW_DROP(sv);
4359 /* len is STRLEN which is unsigned, need to copy to signed */
4362 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4364 SvUPGRADE(sv, SVt_PV);
4366 dptr = SvGROW(sv, len + 1);
4367 Move(ptr,dptr,len,char);
4370 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4375 =for apidoc sv_setpvn_mg
4377 Like C<sv_setpvn>, but also handles 'set' magic.
4383 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4385 PERL_ARGS_ASSERT_SV_SETPVN_MG;
4387 sv_setpvn(sv,ptr,len);
4392 =for apidoc sv_setpv
4394 Copies a string into an SV. The string must be null-terminated. Does not
4395 handle 'set' magic. See C<sv_setpv_mg>.
4401 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4404 register STRLEN len;
4406 PERL_ARGS_ASSERT_SV_SETPV;
4408 SV_CHECK_THINKFIRST_COW_DROP(sv);
4414 SvUPGRADE(sv, SVt_PV);
4416 SvGROW(sv, len + 1);
4417 Move(ptr,SvPVX(sv),len+1,char);
4419 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4424 =for apidoc sv_setpv_mg
4426 Like C<sv_setpv>, but also handles 'set' magic.
4432 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4434 PERL_ARGS_ASSERT_SV_SETPV_MG;
4441 =for apidoc sv_usepvn_flags
4443 Tells an SV to use C<ptr> to find its string value. Normally the
4444 string is stored inside the SV but sv_usepvn allows the SV to use an
4445 outside string. The C<ptr> should point to memory that was allocated
4446 by C<malloc>. The string length, C<len>, must be supplied. By default
4447 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4448 so that pointer should not be freed or used by the programmer after
4449 giving it to sv_usepvn, and neither should any pointers from "behind"
4450 that pointer (e.g. ptr + 1) be used.
4452 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4453 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4454 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4455 C<len>, and already meets the requirements for storing in C<SvPVX>)
4461 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4466 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4468 SV_CHECK_THINKFIRST_COW_DROP(sv);
4469 SvUPGRADE(sv, SVt_PV);
4472 if (flags & SV_SMAGIC)
4476 if (SvPVX_const(sv))
4480 if (flags & SV_HAS_TRAILING_NUL)
4481 assert(ptr[len] == '\0');
4484 allocate = (flags & SV_HAS_TRAILING_NUL)
4486 #ifdef Perl_safesysmalloc_size
4489 PERL_STRLEN_ROUNDUP(len + 1);
4491 if (flags & SV_HAS_TRAILING_NUL) {
4492 /* It's long enough - do nothing.
4493 Specfically Perl_newCONSTSUB is relying on this. */
4496 /* Force a move to shake out bugs in callers. */
4497 char *new_ptr = (char*)safemalloc(allocate);
4498 Copy(ptr, new_ptr, len, char);
4499 PoisonFree(ptr,len,char);
4503 ptr = (char*) saferealloc (ptr, allocate);
4506 #ifdef Perl_safesysmalloc_size
4507 SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4509 SvLEN_set(sv, allocate);
4513 if (!(flags & SV_HAS_TRAILING_NUL)) {
4516 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4518 if (flags & SV_SMAGIC)
4522 #ifdef PERL_OLD_COPY_ON_WRITE
4523 /* Need to do this *after* making the SV normal, as we need the buffer
4524 pointer to remain valid until after we've copied it. If we let go too early,
4525 another thread could invalidate it by unsharing last of the same hash key
4526 (which it can do by means other than releasing copy-on-write Svs)
4527 or by changing the other copy-on-write SVs in the loop. */
4529 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4531 PERL_ARGS_ASSERT_SV_RELEASE_COW;
4533 { /* this SV was SvIsCOW_normal(sv) */
4534 /* we need to find the SV pointing to us. */
4535 SV *current = SV_COW_NEXT_SV(after);
4537 if (current == sv) {
4538 /* The SV we point to points back to us (there were only two of us
4540 Hence other SV is no longer copy on write either. */
4542 SvREADONLY_off(after);
4544 /* We need to follow the pointers around the loop. */
4546 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4549 /* don't loop forever if the structure is bust, and we have
4550 a pointer into a closed loop. */
4551 assert (current != after);
4552 assert (SvPVX_const(current) == pvx);
4554 /* Make the SV before us point to the SV after us. */
4555 SV_COW_NEXT_SV_SET(current, after);
4561 =for apidoc sv_force_normal_flags
4563 Undo various types of fakery on an SV: if the PV is a shared string, make
4564 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4565 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4566 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4567 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4568 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4569 set to some other value.) In addition, the C<flags> parameter gets passed to
4570 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4571 with flags set to 0.
4577 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4581 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4583 #ifdef PERL_OLD_COPY_ON_WRITE
4584 if (SvREADONLY(sv)) {
4586 const char * const pvx = SvPVX_const(sv);
4587 const STRLEN len = SvLEN(sv);
4588 const STRLEN cur = SvCUR(sv);
4589 /* next COW sv in the loop. If len is 0 then this is a shared-hash
4590 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4591 we'll fail an assertion. */
4592 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4595 PerlIO_printf(Perl_debug_log,
4596 "Copy on write: Force normal %ld\n",
4602 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4605 if (flags & SV_COW_DROP_PV) {
4606 /* OK, so we don't need to copy our buffer. */
4609 SvGROW(sv, cur + 1);
4610 Move(pvx,SvPVX(sv),cur,char);
4615 sv_release_COW(sv, pvx, next);
4617 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4623 else if (IN_PERL_RUNTIME)
4624 Perl_croak_no_modify(aTHX);
4627 if (SvREADONLY(sv)) {
4629 const char * const pvx = SvPVX_const(sv);
4630 const STRLEN len = SvCUR(sv);
4635 SvGROW(sv, len + 1);
4636 Move(pvx,SvPVX(sv),len,char);
4638 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4640 else if (IN_PERL_RUNTIME)
4641 Perl_croak_no_modify(aTHX);
4645 sv_unref_flags(sv, flags);
4646 else if (SvFAKE(sv) && isGV_with_GP(sv))
4648 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
4649 /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous
4650 to sv_unglob. We only need it here, so inline it. */
4651 const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
4652 SV *const temp = newSV_type(new_type);
4653 void *const temp_p = SvANY(sv);
4655 if (new_type == SVt_PVMG) {
4656 SvMAGIC_set(temp, SvMAGIC(sv));
4657 SvMAGIC_set(sv, NULL);
4658 SvSTASH_set(temp, SvSTASH(sv));
4659 SvSTASH_set(sv, NULL);
4661 SvCUR_set(temp, SvCUR(sv));
4662 /* Remember that SvPVX is in the head, not the body. */
4664 SvLEN_set(temp, SvLEN(sv));
4665 /* This signals "buffer is owned by someone else" in sv_clear,
4666 which is the least effort way to stop it freeing the buffer.
4668 SvLEN_set(sv, SvLEN(sv)+1);
4670 /* Their buffer is already owned by someone else. */
4671 SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
4672 SvLEN_set(temp, SvCUR(sv)+1);
4675 /* Now swap the rest of the bodies. */
4677 SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
4678 SvFLAGS(sv) |= new_type;
4679 SvANY(sv) = SvANY(temp);
4681 SvFLAGS(temp) &= ~(SVTYPEMASK);
4682 SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
4683 SvANY(temp) = temp_p;
4692 Efficient removal of characters from the beginning of the string buffer.
4693 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4694 the string buffer. The C<ptr> becomes the first character of the adjusted
4695 string. Uses the "OOK hack".
4696 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4697 refer to the same chunk of data.
4703 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4709 const U8 *real_start;
4713 PERL_ARGS_ASSERT_SV_CHOP;
4715 if (!ptr || !SvPOKp(sv))
4717 delta = ptr - SvPVX_const(sv);
4719 /* Nothing to do. */
4722 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4723 nothing uses the value of ptr any more. */
4724 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4725 if (ptr <= SvPVX_const(sv))
4726 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4727 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4728 SV_CHECK_THINKFIRST(sv);
4729 if (delta > max_delta)
4730 Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4731 SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4732 SvPVX_const(sv) + max_delta);
4735 if (!SvLEN(sv)) { /* make copy of shared string */
4736 const char *pvx = SvPVX_const(sv);
4737 const STRLEN len = SvCUR(sv);
4738 SvGROW(sv, len + 1);
4739 Move(pvx,SvPVX(sv),len,char);
4742 SvFLAGS(sv) |= SVf_OOK;
4745 SvOOK_offset(sv, old_delta);
4747 SvLEN_set(sv, SvLEN(sv) - delta);
4748 SvCUR_set(sv, SvCUR(sv) - delta);
4749 SvPV_set(sv, SvPVX(sv) + delta);
4751 p = (U8 *)SvPVX_const(sv);
4756 real_start = p - delta;
4760 if (delta < 0x100) {
4764 p -= sizeof(STRLEN);
4765 Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4769 /* Fill the preceding buffer with sentinals to verify that no-one is
4771 while (p > real_start) {
4779 =for apidoc sv_catpvn
4781 Concatenates the string onto the end of the string which is in the SV. The
4782 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4783 status set, then the bytes appended should be valid UTF-8.
4784 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4786 =for apidoc sv_catpvn_flags
4788 Concatenates the string onto the end of the string which is in the SV. The
4789 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4790 status set, then the bytes appended should be valid UTF-8.
4791 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4792 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4793 in terms of this function.
4799 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4803 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4805 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4807 SvGROW(dsv, dlen + slen + 1);
4809 sstr = SvPVX_const(dsv);
4810 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4811 SvCUR_set(dsv, SvCUR(dsv) + slen);
4813 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4815 if (flags & SV_SMAGIC)
4820 =for apidoc sv_catsv
4822 Concatenates the string from SV C<ssv> onto the end of the string in
4823 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4824 not 'set' magic. See C<sv_catsv_mg>.
4826 =for apidoc sv_catsv_flags
4828 Concatenates the string from SV C<ssv> onto the end of the string in
4829 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4830 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4831 and C<sv_catsv_nomg> are implemented in terms of this function.
4836 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4840 PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4844 const char *spv = SvPV_flags_const(ssv, slen, flags);
4846 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4847 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4848 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4849 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4850 dsv->sv_flags doesn't have that bit set.
4851 Andy Dougherty 12 Oct 2001
4853 const I32 sutf8 = DO_UTF8(ssv);
4856 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4858 dutf8 = DO_UTF8(dsv);
4860 if (dutf8 != sutf8) {
4862 /* Not modifying source SV, so taking a temporary copy. */
4863 SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4865 sv_utf8_upgrade(csv);
4866 spv = SvPV_const(csv, slen);
4869 /* Leave enough space for the cat that's about to happen */
4870 sv_utf8_upgrade_flags_grow(dsv, 0, slen);
4872 sv_catpvn_nomg(dsv, spv, slen);
4875 if (flags & SV_SMAGIC)
4880 =for apidoc sv_catpv
4882 Concatenates the string onto the end of the string which is in the SV.
4883 If the SV has the UTF-8 status set, then the bytes appended should be
4884 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4889 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4892 register STRLEN len;
4896 PERL_ARGS_ASSERT_SV_CATPV;
4900 junk = SvPV_force(sv, tlen);
4902 SvGROW(sv, tlen + len + 1);
4904 ptr = SvPVX_const(sv);
4905 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4906 SvCUR_set(sv, SvCUR(sv) + len);
4907 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4912 =for apidoc sv_catpv_flags
4914 Concatenates the string onto the end of the string which is in the SV.
4915 If the SV has the UTF-8 status set, then the bytes appended should
4916 be valid UTF-8. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get>
4917 on the SVs if appropriate, else not.
4923 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, I32 flags)
4925 PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
4926 sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
4930 =for apidoc sv_catpv_mg
4932 Like C<sv_catpv>, but also handles 'set' magic.
4938 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4940 PERL_ARGS_ASSERT_SV_CATPV_MG;
4949 Creates a new SV. A non-zero C<len> parameter indicates the number of
4950 bytes of preallocated string space the SV should have. An extra byte for a
4951 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
4952 space is allocated.) The reference count for the new SV is set to 1.
4954 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4955 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4956 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4957 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
4958 modules supporting older perls.
4964 Perl_newSV(pTHX_ const STRLEN len)
4971 sv_upgrade(sv, SVt_PV);
4972 SvGROW(sv, len + 1);
4977 =for apidoc sv_magicext
4979 Adds magic to an SV, upgrading it if necessary. Applies the
4980 supplied vtable and returns a pointer to the magic added.
4982 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4983 In particular, you can add magic to SvREADONLY SVs, and add more than
4984 one instance of the same 'how'.
4986 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4987 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4988 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4989 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4991 (This is now used as a subroutine by C<sv_magic>.)
4996 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
4997 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5002 PERL_ARGS_ASSERT_SV_MAGICEXT;
5004 SvUPGRADE(sv, SVt_PVMG);
5005 Newxz(mg, 1, MAGIC);
5006 mg->mg_moremagic = SvMAGIC(sv);
5007 SvMAGIC_set(sv, mg);
5009 /* Sometimes a magic contains a reference loop, where the sv and
5010 object refer to each other. To prevent a reference loop that
5011 would prevent such objects being freed, we look for such loops
5012 and if we find one we avoid incrementing the object refcount.
5014 Note we cannot do this to avoid self-tie loops as intervening RV must
5015 have its REFCNT incremented to keep it in existence.
5018 if (!obj || obj == sv ||
5019 how == PERL_MAGIC_arylen ||
5020 how == PERL_MAGIC_symtab ||
5021 (SvTYPE(obj) == SVt_PVGV &&
5022 (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5023 || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5024 || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5029 mg->mg_obj = SvREFCNT_inc_simple(obj);
5030 mg->mg_flags |= MGf_REFCOUNTED;
5033 /* Normal self-ties simply pass a null object, and instead of
5034 using mg_obj directly, use the SvTIED_obj macro to produce a
5035 new RV as needed. For glob "self-ties", we are tieing the PVIO
5036 with an RV obj pointing to the glob containing the PVIO. In
5037 this case, to avoid a reference loop, we need to weaken the
5041 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5042 obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5048 mg->mg_len = namlen;
5051 mg->mg_ptr = savepvn(name, namlen);
5052 else if (namlen == HEf_SVKEY) {
5053 /* Yes, this is casting away const. This is only for the case of
5054 HEf_SVKEY. I think we need to document this abberation of the
5055 constness of the API, rather than making name non-const, as
5056 that change propagating outwards a long way. */
5057 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5059 mg->mg_ptr = (char *) name;
5061 mg->mg_virtual = (MGVTBL *) vtable;
5065 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5070 =for apidoc sv_magic
5072 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5073 then adds a new magic item of type C<how> to the head of the magic list.
5075 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5076 handling of the C<name> and C<namlen> arguments.
5078 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5079 to add more than one instance of the same 'how'.
5085 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
5086 const char *const name, const I32 namlen)
5089 const MGVTBL *vtable;
5092 PERL_ARGS_ASSERT_SV_MAGIC;
5094 #ifdef PERL_OLD_COPY_ON_WRITE
5096 sv_force_normal_flags(sv, 0);
5098 if (SvREADONLY(sv)) {
5100 /* its okay to attach magic to shared strings; the subsequent
5101 * upgrade to PVMG will unshare the string */
5102 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
5105 && how != PERL_MAGIC_regex_global
5106 && how != PERL_MAGIC_bm
5107 && how != PERL_MAGIC_fm
5108 && how != PERL_MAGIC_sv
5109 && how != PERL_MAGIC_backref
5112 Perl_croak_no_modify(aTHX);
5115 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5116 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5117 /* sv_magic() refuses to add a magic of the same 'how' as an
5120 if (how == PERL_MAGIC_taint) {
5122 /* Any scalar which already had taint magic on which someone
5123 (erroneously?) did SvIOK_on() or similar will now be
5124 incorrectly sporting public "OK" flags. */
5125 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5133 vtable = &PL_vtbl_sv;
5135 case PERL_MAGIC_overload:
5136 vtable = &PL_vtbl_amagic;
5138 case PERL_MAGIC_overload_elem:
5139 vtable = &PL_vtbl_amagicelem;
5141 case PERL_MAGIC_overload_table:
5142 vtable = &PL_vtbl_ovrld;
5145 vtable = &PL_vtbl_bm;
5147 case PERL_MAGIC_regdata:
5148 vtable = &PL_vtbl_regdata;
5150 case PERL_MAGIC_regdatum:
5151 vtable = &PL_vtbl_regdatum;
5153 case PERL_MAGIC_env:
5154 vtable = &PL_vtbl_env;
5157 vtable = &PL_vtbl_fm;
5159 case PERL_MAGIC_envelem:
5160 vtable = &PL_vtbl_envelem;
5162 case PERL_MAGIC_regex_global:
5163 vtable = &PL_vtbl_mglob;
5165 case PERL_MAGIC_isa:
5166 vtable = &PL_vtbl_isa;
5168 case PERL_MAGIC_isaelem:
5169 vtable = &PL_vtbl_isaelem;
5171 case PERL_MAGIC_nkeys:
5172 vtable = &PL_vtbl_nkeys;
5174 case PERL_MAGIC_dbfile:
5177 case PERL_MAGIC_dbline:
5178 vtable = &PL_vtbl_dbline;
5180 #ifdef USE_LOCALE_COLLATE
5181 case PERL_MAGIC_collxfrm:
5182 vtable = &PL_vtbl_collxfrm;
5184 #endif /* USE_LOCALE_COLLATE */
5185 case PERL_MAGIC_tied:
5186 vtable = &PL_vtbl_pack;
5188 case PERL_MAGIC_tiedelem:
5189 case PERL_MAGIC_tiedscalar:
5190 vtable = &PL_vtbl_packelem;
5193 vtable = &PL_vtbl_regexp;
5195 case PERL_MAGIC_sig:
5196 vtable = &PL_vtbl_sig;
5198 case PERL_MAGIC_sigelem:
5199 vtable = &PL_vtbl_sigelem;
5201 case PERL_MAGIC_taint:
5202 vtable = &PL_vtbl_taint;
5204 case PERL_MAGIC_uvar:
5205 vtable = &PL_vtbl_uvar;
5207 case PERL_MAGIC_vec:
5208 vtable = &PL_vtbl_vec;
5210 case PERL_MAGIC_arylen_p:
5211 case PERL_MAGIC_rhash:
5212 case PERL_MAGIC_symtab:
5213 case PERL_MAGIC_vstring:
5214 case PERL_MAGIC_checkcall:
5217 case PERL_MAGIC_utf8:
5218 vtable = &PL_vtbl_utf8;
5220 case PERL_MAGIC_substr:
5221 vtable = &PL_vtbl_substr;
5223 case PERL_MAGIC_defelem:
5224 vtable = &PL_vtbl_defelem;
5226 case PERL_MAGIC_arylen:
5227 vtable = &PL_vtbl_arylen;
5229 case PERL_MAGIC_pos:
5230 vtable = &PL_vtbl_pos;
5232 case PERL_MAGIC_backref:
5233 vtable = &PL_vtbl_backref;
5235 case PERL_MAGIC_hintselem:
5236 vtable = &PL_vtbl_hintselem;
5238 case PERL_MAGIC_hints:
5239 vtable = &PL_vtbl_hints;
5241 case PERL_MAGIC_ext:
5242 /* Reserved for use by extensions not perl internals. */
5243 /* Useful for attaching extension internal data to perl vars. */
5244 /* Note that multiple extensions may clash if magical scalars */
5245 /* etc holding private data from one are passed to another. */
5249 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5252 /* Rest of work is done else where */
5253 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5256 case PERL_MAGIC_taint:
5259 case PERL_MAGIC_ext:
5260 case PERL_MAGIC_dbfile:
5267 =for apidoc sv_unmagic
5269 Removes all magic of type C<type> from an SV.
5275 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5280 PERL_ARGS_ASSERT_SV_UNMAGIC;
5282 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5284 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5285 for (mg = *mgp; mg; mg = *mgp) {
5286 if (mg->mg_type == type) {
5287 const MGVTBL* const vtbl = mg->mg_virtual;
5288 *mgp = mg->mg_moremagic;
5289 if (vtbl && vtbl->svt_free)
5290 vtbl->svt_free(aTHX_ sv, mg);
5291 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5293 Safefree(mg->mg_ptr);
5294 else if (mg->mg_len == HEf_SVKEY)
5295 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5296 else if (mg->mg_type == PERL_MAGIC_utf8)
5297 Safefree(mg->mg_ptr);
5299 if (mg->mg_flags & MGf_REFCOUNTED)
5300 SvREFCNT_dec(mg->mg_obj);
5304 mgp = &mg->mg_moremagic;
5307 if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
5308 mg_magical(sv); /* else fix the flags now */
5312 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5318 =for apidoc sv_rvweaken
5320 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5321 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5322 push a back-reference to this RV onto the array of backreferences
5323 associated with that magic. If the RV is magical, set magic will be
5324 called after the RV is cleared.
5330 Perl_sv_rvweaken(pTHX_ SV *const sv)
5334 PERL_ARGS_ASSERT_SV_RVWEAKEN;
5336 if (!SvOK(sv)) /* let undefs pass */
5339 Perl_croak(aTHX_ "Can't weaken a nonreference");
5340 else if (SvWEAKREF(sv)) {
5341 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5345 Perl_sv_add_backref(aTHX_ tsv, sv);
5351 /* Give tsv backref magic if it hasn't already got it, then push a
5352 * back-reference to sv onto the array associated with the backref magic.
5354 * As an optimisation, if there's only one backref and it's not an AV,
5355 * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5356 * allocate an AV. (Whether the slot holds an AV tells us whether this is
5359 * If an HV's backref is stored in magic, it is moved back to HvAUX.
5362 /* A discussion about the backreferences array and its refcount:
5364 * The AV holding the backreferences is pointed to either as the mg_obj of
5365 * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
5366 * structure, from the xhv_backreferences field. (A HV without hv_aux will
5367 * have the standard magic instead.) The array is created with a refcount
5368 * of 2. This means that if during global destruction the array gets
5369 * picked on before its parent to have its refcount decremented by the
5370 * random zapper, it won't actually be freed, meaning it's still there for
5371 * when its parent gets freed.
5373 * When the parent SV is freed, the extra ref is killed by
5374 * Perl_sv_kill_backrefs. The other ref is killed, in the case of magic,
5375 * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5377 * When a single backref SV is stored directly, it is not reference
5382 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5389 PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5391 /* find slot to store array or singleton backref */
5393 if (SvTYPE(tsv) == SVt_PVHV) {
5394 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5397 if ((mg = mg_find(tsv, PERL_MAGIC_backref))) {
5398 /* Aha. They've got it stowed in magic instead.
5399 * Move it back to xhv_backreferences */
5401 /* Stop mg_free decreasing the reference count. */
5403 /* Stop mg_free even calling the destructor, given that
5404 there's no AV to free up. */
5406 sv_unmagic(tsv, PERL_MAGIC_backref);
5412 (SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
5414 sv_magic(tsv, NULL, PERL_MAGIC_backref, NULL, 0);
5415 mg = mg_find(tsv, PERL_MAGIC_backref);
5417 svp = &(mg->mg_obj);
5420 /* create or retrieve the array */
5422 if ( (!*svp && SvTYPE(sv) == SVt_PVAV)
5423 || (*svp && SvTYPE(*svp) != SVt_PVAV)
5428 SvREFCNT_inc_simple_void(av);
5429 /* av now has a refcnt of 2; see discussion above */
5431 /* move single existing backref to the array */
5433 AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5437 mg->mg_flags |= MGf_REFCOUNTED;
5440 av = MUTABLE_AV(*svp);
5443 /* optimisation: store single backref directly in HvAUX or mg_obj */
5447 /* push new backref */
5448 assert(SvTYPE(av) == SVt_PVAV);
5449 if (AvFILLp(av) >= AvMAX(av)) {
5450 av_extend(av, AvFILLp(av)+1);
5452 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5455 /* delete a back-reference to ourselves from the backref magic associated
5456 * with the SV we point to.
5460 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5466 PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5468 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5469 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5471 if (!svp || !*svp) {
5473 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5474 svp = mg ? &(mg->mg_obj) : NULL;
5478 Perl_croak(aTHX_ "panic: del_backref");
5480 if (SvTYPE(*svp) == SVt_PVAV) {
5482 AV * const av = (AV*)*svp;
5483 assert(!SvIS_FREED(av));
5485 for (i = AvFILLp(av); i >= 0; i--) {
5487 const SSize_t fill = AvFILLp(av);
5489 /* We weren't the last entry.
5490 An unordered list has this property that you can take the
5491 last element off the end to fill the hole, and it's still
5492 an unordered list :-)
5497 AvFILLp(av) = fill - 1;
5500 break; /* should only be one */
5507 /* optimisation: only a single backref, stored directly */
5509 Perl_croak(aTHX_ "panic: del_backref");
5516 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5522 PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5527 is_array = (SvTYPE(av) == SVt_PVAV);
5529 assert(!SvIS_FREED(av));
5532 last = svp + AvFILLp(av);
5535 /* optimisation: only a single backref, stored directly */
5541 while (svp <= last) {
5543 SV *const referrer = *svp;
5544 if (SvWEAKREF(referrer)) {
5545 /* XXX Should we check that it hasn't changed? */
5546 assert(SvROK(referrer));
5547 SvRV_set(referrer, 0);
5549 SvWEAKREF_off(referrer);
5550 SvSETMAGIC(referrer);
5551 } else if (SvTYPE(referrer) == SVt_PVGV ||
5552 SvTYPE(referrer) == SVt_PVLV) {
5553 assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
5554 /* You lookin' at me? */
5555 assert(GvSTASH(referrer));
5556 assert(GvSTASH(referrer) == (const HV *)sv);
5557 GvSTASH(referrer) = 0;
5558 } else if (SvTYPE(referrer) == SVt_PVCV ||
5559 SvTYPE(referrer) == SVt_PVFM) {
5560 if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
5561 /* You lookin' at me? */
5562 assert(CvSTASH(referrer));
5563 assert(CvSTASH(referrer) == (const HV *)sv);
5564 CvSTASH(referrer) = 0;
5567 assert(SvTYPE(sv) == SVt_PVGV);
5568 /* You lookin' at me? */
5569 assert(CvGV(referrer));
5570 assert(CvGV(referrer) == (const GV *)sv);
5571 anonymise_cv_maybe(MUTABLE_GV(sv),
5572 MUTABLE_CV(referrer));
5577 "panic: magic_killbackrefs (flags=%"UVxf")",
5578 (UV)SvFLAGS(referrer));
5589 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5595 =for apidoc sv_insert
5597 Inserts a string at the specified offset/length within the SV. Similar to
5598 the Perl substr() function. Handles get magic.
5600 =for apidoc sv_insert_flags
5602 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5608 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5613 register char *midend;
5614 register char *bigend;
5618 PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5621 Perl_croak(aTHX_ "Can't modify non-existent substring");
5622 SvPV_force_flags(bigstr, curlen, flags);
5623 (void)SvPOK_only_UTF8(bigstr);
5624 if (offset + len > curlen) {
5625 SvGROW(bigstr, offset+len+1);
5626 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5627 SvCUR_set(bigstr, offset+len);
5631 i = littlelen - len;
5632 if (i > 0) { /* string might grow */
5633 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5634 mid = big + offset + len;
5635 midend = bigend = big + SvCUR(bigstr);
5638 while (midend > mid) /* shove everything down */
5639 *--bigend = *--midend;
5640 Move(little,big+offset,littlelen,char);
5641 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5646 Move(little,SvPVX(bigstr)+offset,len,char);
5651 big = SvPVX(bigstr);
5654 bigend = big + SvCUR(bigstr);
5656 if (midend > bigend)
5657 Perl_croak(aTHX_ "panic: sv_insert");
5659 if (mid - big > bigend - midend) { /* faster to shorten from end */
5661 Move(little, mid, littlelen,char);
5664 i = bigend - midend;
5666 Move(midend, mid, i,char);
5670 SvCUR_set(bigstr, mid - big);
5672 else if ((i = mid - big)) { /* faster from front */
5673 midend -= littlelen;
5675 Move(big, midend - i, i, char);
5676 sv_chop(bigstr,midend-i);
5678 Move(little, mid, littlelen,char);
5680 else if (littlelen) {
5681 midend -= littlelen;
5682 sv_chop(bigstr,midend);
5683 Move(little,midend,littlelen,char);
5686 sv_chop(bigstr,midend);
5692 =for apidoc sv_replace
5694 Make the first argument a copy of the second, then delete the original.
5695 The target SV physically takes over ownership of the body of the source SV
5696 and inherits its flags; however, the target keeps any magic it owns,
5697 and any magic in the source is discarded.
5698 Note that this is a rather specialist SV copying operation; most of the
5699 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5705 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5708 const U32 refcnt = SvREFCNT(sv);
5710 PERL_ARGS_ASSERT_SV_REPLACE;
5712 SV_CHECK_THINKFIRST_COW_DROP(sv);
5713 if (SvREFCNT(nsv) != 1) {
5714 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
5715 " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
5717 if (SvMAGICAL(sv)) {
5721 sv_upgrade(nsv, SVt_PVMG);
5722 SvMAGIC_set(nsv, SvMAGIC(sv));
5723 SvFLAGS(nsv) |= SvMAGICAL(sv);
5725 SvMAGIC_set(sv, NULL);
5729 assert(!SvREFCNT(sv));
5730 #ifdef DEBUG_LEAKING_SCALARS
5731 sv->sv_flags = nsv->sv_flags;
5732 sv->sv_any = nsv->sv_any;
5733 sv->sv_refcnt = nsv->sv_refcnt;
5734 sv->sv_u = nsv->sv_u;
5736 StructCopy(nsv,sv,SV);
5738 if(SvTYPE(sv) == SVt_IV) {
5740 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5744 #ifdef PERL_OLD_COPY_ON_WRITE
5745 if (SvIsCOW_normal(nsv)) {
5746 /* We need to follow the pointers around the loop to make the
5747 previous SV point to sv, rather than nsv. */
5750 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5753 assert(SvPVX_const(current) == SvPVX_const(nsv));
5755 /* Make the SV before us point to the SV after us. */
5757 PerlIO_printf(Perl_debug_log, "previous is\n");
5759 PerlIO_printf(Perl_debug_log,
5760 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5761 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5763 SV_COW_NEXT_SV_SET(current, sv);
5766 SvREFCNT(sv) = refcnt;
5767 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5772 /* We're about to free a GV which has a CV that refers back to us.
5773 * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
5777 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
5783 PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
5786 assert(SvREFCNT(gv) == 0);
5787 assert(isGV(gv) && isGV_with_GP(gv));
5789 assert(!CvANON(cv));
5790 assert(CvGV(cv) == gv);
5792 /* will the CV shortly be freed by gp_free() ? */
5793 if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
5794 SvANY(cv)->xcv_gv = NULL;
5798 /* if not, anonymise: */
5799 stash = GvSTASH(gv) ? HvNAME(GvSTASH(gv)) : NULL;
5800 gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
5801 stash ? stash : "__ANON__");
5802 anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
5803 SvREFCNT_dec(gvname);
5807 SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
5812 =for apidoc sv_clear
5814 Clear an SV: call any destructors, free up any memory used by the body,
5815 and free the body itself. The SV's head is I<not> freed, although
5816 its type is set to all 1's so that it won't inadvertently be assumed
5817 to be live during global destruction etc.
5818 This function should only be called when REFCNT is zero. Most of the time
5819 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5826 Perl_sv_clear(pTHX_ SV *const orig_sv)
5831 const struct body_details *sv_type_details;
5834 register SV *sv = orig_sv;
5836 PERL_ARGS_ASSERT_SV_CLEAR;
5838 /* within this loop, sv is the SV currently being freed, and
5839 * iter_sv is the most recent AV or whatever that's being iterated
5840 * over to provide more SVs */
5846 assert(SvREFCNT(sv) == 0);
5847 assert(SvTYPE(sv) != SVTYPEMASK);
5849 if (type <= SVt_IV) {
5850 /* See the comment in sv.h about the collusion between this
5851 * early return and the overloading of the NULL slots in the
5855 SvFLAGS(sv) &= SVf_BREAK;
5856 SvFLAGS(sv) |= SVTYPEMASK;
5861 if (PL_defstash && /* Still have a symbol table? */
5868 stash = SvSTASH(sv);
5869 destructor = StashHANDLER(stash,DESTROY);
5871 /* A constant subroutine can have no side effects, so
5872 don't bother calling it. */
5873 && !CvCONST(destructor)
5874 /* Don't bother calling an empty destructor */
5875 && (CvISXSUB(destructor)
5876 || (CvSTART(destructor)
5877 && (CvSTART(destructor)->op_next->op_type
5880 SV* const tmpref = newRV(sv);
5881 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5883 PUSHSTACKi(PERLSI_DESTROY);
5888 call_sv(MUTABLE_SV(destructor),
5889 G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5893 if(SvREFCNT(tmpref) < 2) {
5894 /* tmpref is not kept alive! */
5896 SvRV_set(tmpref, NULL);
5899 SvREFCNT_dec(tmpref);
5901 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5905 if (PL_in_clean_objs)
5907 "DESTROY created new reference to dead object '%s'",
5909 /* DESTROY gave object new lease on life */
5915 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5916 SvOBJECT_off(sv); /* Curse the object. */
5917 if (type != SVt_PVIO)
5918 --PL_sv_objcount;/* XXX Might want something more general */
5921 if (type >= SVt_PVMG) {
5922 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
5923 SvREFCNT_dec(SvOURSTASH(sv));
5924 } else if (SvMAGIC(sv))
5926 if (type == SVt_PVMG && SvPAD_TYPED(sv))
5927 SvREFCNT_dec(SvSTASH(sv));
5930 /* case SVt_BIND: */
5933 IoIFP(sv) != PerlIO_stdin() &&
5934 IoIFP(sv) != PerlIO_stdout() &&
5935 IoIFP(sv) != PerlIO_stderr() &&
5936 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5938 io_close(MUTABLE_IO(sv), FALSE);
5940 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5941 PerlDir_close(IoDIRP(sv));
5942 IoDIRP(sv) = (DIR*)NULL;
5943 Safefree(IoTOP_NAME(sv));
5944 Safefree(IoFMT_NAME(sv));
5945 Safefree(IoBOTTOM_NAME(sv));
5948 /* FIXME for plugins */
5949 pregfree2((REGEXP*) sv);
5953 cv_undef(MUTABLE_CV(sv));
5954 /* If we're in a stash, we don't own a reference to it.
5955 * However it does have a back reference to us, which needs to
5957 if ((stash = CvSTASH(sv)))
5958 sv_del_backref(MUTABLE_SV(stash), sv);
5961 if (PL_last_swash_hv == (const HV *)sv) {
5962 PL_last_swash_hv = NULL;
5964 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
5965 hv_undef(MUTABLE_HV(sv));
5969 AV* av = MUTABLE_AV(sv);
5970 if (PL_comppad == av) {
5974 if (AvREAL(av) && AvFILLp(av) > -1) {
5975 next_sv = AvARRAY(av)[AvFILLp(av)--];
5976 /* save old iter_sv in top-most slot of AV,
5977 * and pray that it doesn't get wiped in the meantime */
5978 AvARRAY(av)[AvMAX(av)] = iter_sv;
5980 goto get_next_sv; /* process this new sv */
5982 Safefree(AvALLOC(av));
5987 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5988 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5989 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5990 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5992 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5993 SvREFCNT_dec(LvTARG(sv));
5995 if (isGV_with_GP(sv)) {
5996 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
5997 && HvNAME_get(stash))
5998 mro_method_changed_in(stash);
5999 gp_free(MUTABLE_GV(sv));
6001 unshare_hek(GvNAME_HEK(sv));
6002 /* If we're in a stash, we don't own a reference to it.
6003 * However it does have a back reference to us, which
6004 * needs to be cleared. */
6005 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
6006 sv_del_backref(MUTABLE_SV(stash), sv);
6008 /* FIXME. There are probably more unreferenced pointers to SVs
6009 * in the interpreter struct that we should check and tidy in
6010 * a similar fashion to this: */
6011 if ((const GV *)sv == PL_last_in_gv)
6012 PL_last_in_gv = NULL;
6018 /* Don't bother with SvOOK_off(sv); as we're only going to
6022 SvOOK_offset(sv, offset);
6023 SvPV_set(sv, SvPVX_mutable(sv) - offset);
6024 /* Don't even bother with turning off the OOK flag. */
6029 SV * const target = SvRV(sv);
6031 sv_del_backref(target, sv);
6036 #ifdef PERL_OLD_COPY_ON_WRITE
6037 else if (SvPVX_const(sv)
6038 && !(SvTYPE(sv) == SVt_PVIO
6039 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6043 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6047 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
6049 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6053 } else if (SvLEN(sv)) {
6054 Safefree(SvPVX_const(sv));
6058 else if (SvPVX_const(sv) && SvLEN(sv)
6059 && !(SvTYPE(sv) == SVt_PVIO
6060 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6061 Safefree(SvPVX_mutable(sv));
6062 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
6063 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6074 SvFLAGS(sv) &= SVf_BREAK;
6075 SvFLAGS(sv) |= SVTYPEMASK;
6077 sv_type_details = bodies_by_type + type;
6078 if (sv_type_details->arena) {
6079 del_body(((char *)SvANY(sv) + sv_type_details->offset),
6080 &PL_body_roots[type]);
6082 else if (sv_type_details->body_size) {
6083 safefree(SvANY(sv));
6087 /* caller is responsible for freeing the head of the original sv */
6088 if (sv != orig_sv && !SvREFCNT(sv))
6091 /* grab and free next sv, if any */
6099 else if (!iter_sv) {
6101 } else if (SvTYPE(iter_sv) == SVt_PVAV) {
6102 AV *const av = (AV*)iter_sv;
6103 if (AvFILLp(av) > -1) {
6104 sv = AvARRAY(av)[AvFILLp(av)--];
6106 else { /* no more elements of current AV to free */
6109 /* restore previous value, squirrelled away */
6110 iter_sv = AvARRAY(av)[AvMAX(av)];
6111 Safefree(AvALLOC(av));
6116 /* unrolled SvREFCNT_dec and sv_free2 follows: */
6120 if (!SvREFCNT(sv)) {
6124 if (--(SvREFCNT(sv)))
6128 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6129 "Attempt to free temp prematurely: SV 0x%"UVxf
6130 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6134 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6135 /* make sure SvREFCNT(sv)==0 happens very seldom */
6136 SvREFCNT(sv) = (~(U32)0)/2;
6146 =for apidoc sv_newref
6148 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6155 Perl_sv_newref(pTHX_ SV *const sv)
6157 PERL_UNUSED_CONTEXT;
6166 Decrement an SV's reference count, and if it drops to zero, call
6167 C<sv_clear> to invoke destructors and free up any memory used by
6168 the body; finally, deallocate the SV's head itself.
6169 Normally called via a wrapper macro C<SvREFCNT_dec>.
6175 Perl_sv_free(pTHX_ SV *const sv)
6180 if (SvREFCNT(sv) == 0) {
6181 if (SvFLAGS(sv) & SVf_BREAK)
6182 /* this SV's refcnt has been artificially decremented to
6183 * trigger cleanup */
6185 if (PL_in_clean_all) /* All is fair */
6187 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6188 /* make sure SvREFCNT(sv)==0 happens very seldom */
6189 SvREFCNT(sv) = (~(U32)0)/2;
6192 if (ckWARN_d(WARN_INTERNAL)) {
6193 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
6194 Perl_dump_sv_child(aTHX_ sv);
6196 #ifdef DEBUG_LEAKING_SCALARS
6199 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6200 if (PL_warnhook == PERL_WARNHOOK_FATAL
6201 || ckDEAD(packWARN(WARN_INTERNAL))) {
6202 /* Don't let Perl_warner cause us to escape our fate: */
6206 /* This may not return: */
6207 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6208 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6209 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6212 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6217 if (--(SvREFCNT(sv)) > 0)
6219 Perl_sv_free2(aTHX_ sv);
6223 Perl_sv_free2(pTHX_ SV *const sv)
6227 PERL_ARGS_ASSERT_SV_FREE2;
6231 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6232 "Attempt to free temp prematurely: SV 0x%"UVxf
6233 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6237 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6238 /* make sure SvREFCNT(sv)==0 happens very seldom */
6239 SvREFCNT(sv) = (~(U32)0)/2;
6250 Returns the length of the string in the SV. Handles magic and type
6251 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6257 Perl_sv_len(pTHX_ register SV *const sv)
6265 len = mg_length(sv);
6267 (void)SvPV_const(sv, len);
6272 =for apidoc sv_len_utf8
6274 Returns the number of characters in the string in an SV, counting wide
6275 UTF-8 bytes as a single character. Handles magic and type coercion.
6281 * The length is cached in PERL_MAGIC_utf8, in the mg_len field. Also the
6282 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6283 * (Note that the mg_len is not the length of the mg_ptr field.
6284 * This allows the cache to store the character length of the string without
6285 * needing to malloc() extra storage to attach to the mg_ptr.)
6290 Perl_sv_len_utf8(pTHX_ register SV *const sv)
6296 return mg_length(sv);
6300 const U8 *s = (U8*)SvPV_const(sv, len);
6304 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6306 if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
6307 if (mg->mg_len != -1)
6310 /* We can use the offset cache for a headstart.
6311 The longer value is stored in the first pair. */
6312 STRLEN *cache = (STRLEN *) mg->mg_ptr;
6314 ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
6318 if (PL_utf8cache < 0) {
6319 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6320 assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
6324 ulen = Perl_utf8_length(aTHX_ s, s + len);
6325 utf8_mg_len_cache_update(sv, &mg, ulen);
6329 return Perl_utf8_length(aTHX_ s, s + len);
6333 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6336 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6337 STRLEN *const uoffset_p, bool *const at_end)
6339 const U8 *s = start;
6340 STRLEN uoffset = *uoffset_p;
6342 PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6344 while (s < send && uoffset) {
6351 else if (s > send) {
6353 /* This is the existing behaviour. Possibly it should be a croak, as
6354 it's actually a bounds error */
6357 *uoffset_p -= uoffset;
6361 /* Given the length of the string in both bytes and UTF-8 characters, decide
6362 whether to walk forwards or backwards to find the byte corresponding to
6363 the passed in UTF-8 offset. */
6365 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6366 STRLEN uoffset, const STRLEN uend)
6368 STRLEN backw = uend - uoffset;
6370 PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6372 if (uoffset < 2 * backw) {
6373 /* The assumption is that going forwards is twice the speed of going
6374 forward (that's where the 2 * backw comes from).
6375 (The real figure of course depends on the UTF-8 data.) */
6376 const U8 *s = start;
6378 while (s < send && uoffset--)
6388 while (UTF8_IS_CONTINUATION(*send))
6391 return send - start;
6394 /* For the string representation of the given scalar, find the byte
6395 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
6396 give another position in the string, *before* the sought offset, which
6397 (which is always true, as 0, 0 is a valid pair of positions), which should
6398 help reduce the amount of linear searching.
6399 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6400 will be used to reduce the amount of linear searching. The cache will be
6401 created if necessary, and the found value offered to it for update. */
6403 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6404 const U8 *const send, STRLEN uoffset,
6405 STRLEN uoffset0, STRLEN boffset0)
6407 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
6409 bool at_end = FALSE;
6411 PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6413 assert (uoffset >= uoffset0);
6420 && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
6421 (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
6422 if ((*mgp)->mg_ptr) {
6423 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6424 if (cache[0] == uoffset) {
6425 /* An exact match. */
6428 if (cache[2] == uoffset) {
6429 /* An exact match. */
6433 if (cache[0] < uoffset) {
6434 /* The cache already knows part of the way. */
6435 if (cache[0] > uoffset0) {
6436 /* The cache knows more than the passed in pair */
6437 uoffset0 = cache[0];
6438 boffset0 = cache[1];
6440 if ((*mgp)->mg_len != -1) {
6441 /* And we know the end too. */
6443 + sv_pos_u2b_midway(start + boffset0, send,
6445 (*mgp)->mg_len - uoffset0);
6447 uoffset -= uoffset0;
6449 + sv_pos_u2b_forwards(start + boffset0,
6450 send, &uoffset, &at_end);
6451 uoffset += uoffset0;
6454 else if (cache[2] < uoffset) {
6455 /* We're between the two cache entries. */
6456 if (cache[2] > uoffset0) {
6457 /* and the cache knows more than the passed in pair */
6458 uoffset0 = cache[2];
6459 boffset0 = cache[3];
6463 + sv_pos_u2b_midway(start + boffset0,
6466 cache[0] - uoffset0);
6469 + sv_pos_u2b_midway(start + boffset0,
6472 cache[2] - uoffset0);
6476 else if ((*mgp)->mg_len != -1) {
6477 /* If we can take advantage of a passed in offset, do so. */
6478 /* In fact, offset0 is either 0, or less than offset, so don't
6479 need to worry about the other possibility. */
6481 + sv_pos_u2b_midway(start + boffset0, send,
6483 (*mgp)->mg_len - uoffset0);
6488 if (!found || PL_utf8cache < 0) {
6489 STRLEN real_boffset;
6490 uoffset -= uoffset0;
6491 real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6492 send, &uoffset, &at_end);
6493 uoffset += uoffset0;
6495 if (found && PL_utf8cache < 0)
6496 assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
6498 boffset = real_boffset;
6503 utf8_mg_len_cache_update(sv, mgp, uoffset);
6505 utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6512 =for apidoc sv_pos_u2b_flags
6514 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6515 the start of the string, to a count of the equivalent number of bytes; if
6516 lenp is non-zero, it does the same to lenp, but this time starting from
6517 the offset, rather than from the start of the string. Handles type coercion.
6518 I<flags> is passed to C<SvPV_flags>, and usually should be
6519 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
6525 * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
6526 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6527 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6532 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
6539 PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
6541 start = (U8*)SvPV_flags(sv, len, flags);
6543 const U8 * const send = start + len;
6545 boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
6548 && *lenp /* don't bother doing work for 0, as its bytes equivalent
6549 is 0, and *lenp is already set to that. */) {
6550 /* Convert the relative offset to absolute. */
6551 const STRLEN uoffset2 = uoffset + *lenp;
6552 const STRLEN boffset2
6553 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6554 uoffset, boffset) - boffset;
6568 =for apidoc sv_pos_u2b
6570 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6571 the start of the string, to a count of the equivalent number of bytes; if
6572 lenp is non-zero, it does the same to lenp, but this time starting from
6573 the offset, rather than from the start of the string. Handles magic and
6576 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
6583 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6584 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6585 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6589 /* This function is subject to size and sign problems */
6592 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6594 PERL_ARGS_ASSERT_SV_POS_U2B;
6597 STRLEN ulen = (STRLEN)*lenp;
6598 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
6599 SV_GMAGIC|SV_CONST_RETURN);
6602 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
6603 SV_GMAGIC|SV_CONST_RETURN);
6608 S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
6611 PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
6615 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6616 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6617 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
6621 (*mgp)->mg_len = ulen;
6622 /* For now, treat "overflowed" as "still unknown". See RT #72924. */
6623 if (ulen != (STRLEN) (*mgp)->mg_len)
6624 (*mgp)->mg_len = -1;
6627 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6628 byte length pairing. The (byte) length of the total SV is passed in too,
6629 as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6630 may not have updated SvCUR, so we can't rely on reading it directly.
6632 The proffered utf8/byte length pairing isn't used if the cache already has
6633 two pairs, and swapping either for the proffered pair would increase the
6634 RMS of the intervals between known byte offsets.
6636 The cache itself consists of 4 STRLEN values
6637 0: larger UTF-8 offset
6638 1: corresponding byte offset
6639 2: smaller UTF-8 offset
6640 3: corresponding byte offset
6642 Unused cache pairs have the value 0, 0.
6643 Keeping the cache "backwards" means that the invariant of
6644 cache[0] >= cache[2] is maintained even with empty slots, which means that
6645 the code that uses it doesn't need to worry if only 1 entry has actually
6646 been set to non-zero. It also makes the "position beyond the end of the
6647 cache" logic much simpler, as the first slot is always the one to start
6651 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6652 const STRLEN utf8, const STRLEN blen)
6656 PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6661 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6662 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6663 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6665 (*mgp)->mg_len = -1;
6669 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6670 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6671 (*mgp)->mg_ptr = (char *) cache;
6675 if (PL_utf8cache < 0 && SvPOKp(sv)) {
6676 /* SvPOKp() because it's possible that sv has string overloading, and
6677 therefore is a reference, hence SvPVX() is actually a pointer.
6678 This cures the (very real) symptoms of RT 69422, but I'm not actually
6679 sure whether we should even be caching the results of UTF-8
6680 operations on overloading, given that nothing stops overloading
6681 returning a different value every time it's called. */
6682 const U8 *start = (const U8 *) SvPVX_const(sv);
6683 const STRLEN realutf8 = utf8_length(start, start + byte);
6685 assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
6689 /* Cache is held with the later position first, to simplify the code
6690 that deals with unbounded ends. */
6692 ASSERT_UTF8_CACHE(cache);
6693 if (cache[1] == 0) {
6694 /* Cache is totally empty */
6697 } else if (cache[3] == 0) {
6698 if (byte > cache[1]) {
6699 /* New one is larger, so goes first. */
6700 cache[2] = cache[0];
6701 cache[3] = cache[1];
6709 #define THREEWAY_SQUARE(a,b,c,d) \
6710 ((float)((d) - (c))) * ((float)((d) - (c))) \
6711 + ((float)((c) - (b))) * ((float)((c) - (b))) \
6712 + ((float)((b) - (a))) * ((float)((b) - (a)))
6714 /* Cache has 2 slots in use, and we know three potential pairs.
6715 Keep the two that give the lowest RMS distance. Do the
6716 calcualation in bytes simply because we always know the byte
6717 length. squareroot has the same ordering as the positive value,
6718 so don't bother with the actual square root. */
6719 const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6720 if (byte > cache[1]) {
6721 /* New position is after the existing pair of pairs. */
6722 const float keep_earlier
6723 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6724 const float keep_later
6725 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6727 if (keep_later < keep_earlier) {
6728 if (keep_later < existing) {
6729 cache[2] = cache[0];
6730 cache[3] = cache[1];
6736 if (keep_earlier < existing) {
6742 else if (byte > cache[3]) {
6743 /* New position is between the existing pair of pairs. */
6744 const float keep_earlier
6745 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6746 const float keep_later
6747 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6749 if (keep_later < keep_earlier) {
6750 if (keep_later < existing) {
6756 if (keep_earlier < existing) {
6763 /* New position is before the existing pair of pairs. */
6764 const float keep_earlier
6765 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6766 const float keep_later
6767 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6769 if (keep_later < keep_earlier) {
6770 if (keep_later < existing) {
6776 if (keep_earlier < existing) {
6777 cache[0] = cache[2];
6778 cache[1] = cache[3];
6785 ASSERT_UTF8_CACHE(cache);
6788 /* We already know all of the way, now we may be able to walk back. The same
6789 assumption is made as in S_sv_pos_u2b_midway(), namely that walking
6790 backward is half the speed of walking forward. */
6792 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
6793 const U8 *end, STRLEN endu)
6795 const STRLEN forw = target - s;
6796 STRLEN backw = end - target;
6798 PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
6800 if (forw < 2 * backw) {
6801 return utf8_length(s, target);
6804 while (end > target) {
6806 while (UTF8_IS_CONTINUATION(*end)) {
6815 =for apidoc sv_pos_b2u
6817 Converts the value pointed to by offsetp from a count of bytes from the
6818 start of the string, to a count of the equivalent number of UTF-8 chars.
6819 Handles magic and type coercion.
6825 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6826 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6831 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
6834 const STRLEN byte = *offsetp;
6835 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
6841 PERL_ARGS_ASSERT_SV_POS_B2U;
6846 s = (const U8*)SvPV_const(sv, blen);
6849 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6855 && SvTYPE(sv) >= SVt_PVMG
6856 && (mg = mg_find(sv, PERL_MAGIC_utf8)))
6859 STRLEN * const cache = (STRLEN *) mg->mg_ptr;
6860 if (cache[1] == byte) {
6861 /* An exact match. */
6862 *offsetp = cache[0];
6865 if (cache[3] == byte) {
6866 /* An exact match. */
6867 *offsetp = cache[2];
6871 if (cache[1] < byte) {
6872 /* We already know part of the way. */
6873 if (mg->mg_len != -1) {
6874 /* Actually, we know the end too. */
6876 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
6877 s + blen, mg->mg_len - cache[0]);
6879 len = cache[0] + utf8_length(s + cache[1], send);
6882 else if (cache[3] < byte) {
6883 /* We're between the two cached pairs, so we do the calculation
6884 offset by the byte/utf-8 positions for the earlier pair,
6885 then add the utf-8 characters from the string start to
6887 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
6888 s + cache[1], cache[0] - cache[2])
6892 else { /* cache[3] > byte */
6893 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
6897 ASSERT_UTF8_CACHE(cache);
6899 } else if (mg->mg_len != -1) {
6900 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
6904 if (!found || PL_utf8cache < 0) {
6905 const STRLEN real_len = utf8_length(s, send);
6907 if (found && PL_utf8cache < 0)
6908 assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
6915 utf8_mg_len_cache_update(sv, &mg, len);
6917 utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
6922 S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
6923 STRLEN real, SV *const sv)
6925 PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
6927 /* As this is debugging only code, save space by keeping this test here,
6928 rather than inlining it in all the callers. */
6929 if (from_cache == real)
6932 /* Need to turn the assertions off otherwise we may recurse infinitely
6933 while printing error messages. */
6934 SAVEI8(PL_utf8cache);
6936 Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
6937 func, (UV) from_cache, (UV) real, SVfARG(sv));
6943 Returns a boolean indicating whether the strings in the two SVs are
6944 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6945 coerce its args to strings if necessary.
6947 =for apidoc sv_eq_flags
6949 Returns a boolean indicating whether the strings in the two SVs are
6950 identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings
6951 if necessary. If the flags include SV_GMAGIC, it handles get-magic, too.
6957 Perl_sv_eq_flags(pTHX_ register SV *sv1, register SV *sv2, const I32 flags)
6966 SV* svrecode = NULL;
6973 /* if pv1 and pv2 are the same, second SvPV_const call may
6974 * invalidate pv1 (if we are handling magic), so we may need to
6976 if (sv1 == sv2 && flags & SV_GMAGIC
6977 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
6978 pv1 = SvPV_const(sv1, cur1);
6979 sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
6981 pv1 = SvPV_flags_const(sv1, cur1, flags);
6989 pv2 = SvPV_flags_const(sv2, cur2, flags);
6991 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6992 /* Differing utf8ness.
6993 * Do not UTF8size the comparands as a side-effect. */
6996 svrecode = newSVpvn(pv2, cur2);
6997 sv_recode_to_utf8(svrecode, PL_encoding);
6998 pv2 = SvPV_const(svrecode, cur2);
7001 svrecode = newSVpvn(pv1, cur1);
7002 sv_recode_to_utf8(svrecode, PL_encoding);
7003 pv1 = SvPV_const(svrecode, cur1);
7005 /* Now both are in UTF-8. */
7007 SvREFCNT_dec(svrecode);
7012 bool is_utf8 = TRUE;
7015 /* sv1 is the UTF-8 one,
7016 * if is equal it must be downgrade-able */
7017 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
7023 /* sv2 is the UTF-8 one,
7024 * if is equal it must be downgrade-able */
7025 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
7031 /* Downgrade not possible - cannot be eq */
7039 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
7041 SvREFCNT_dec(svrecode);
7051 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7052 string in C<sv1> is less than, equal to, or greater than the string in
7053 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7054 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
7056 =for apidoc sv_cmp_flags
7058 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7059 string in C<sv1> is less than, equal to, or greater than the string in
7060 C<sv2>. Is UTF-8 and 'use bytes' aware and will coerce its args to strings
7061 if necessary. If the flags include SV_GMAGIC, it handles get magic. See
7062 also C<sv_cmp_locale_flags>.
7068 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
7070 return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
7074 Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2, const I32 flags)
7078 const char *pv1, *pv2;
7081 SV *svrecode = NULL;
7088 pv1 = SvPV_flags_const(sv1, cur1, flags);
7095 pv2 = SvPV_flags_const(sv2, cur2, flags);
7097 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7098 /* Differing utf8ness.
7099 * Do not UTF8size the comparands as a side-effect. */
7102 svrecode = newSVpvn(pv2, cur2);
7103 sv_recode_to_utf8(svrecode, PL_encoding);
7104 pv2 = SvPV_const(svrecode, cur2);
7107 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
7112 svrecode = newSVpvn(pv1, cur1);
7113 sv_recode_to_utf8(svrecode, PL_encoding);
7114 pv1 = SvPV_const(svrecode, cur1);
7117 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
7123 cmp = cur2 ? -1 : 0;
7127 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
7130 cmp = retval < 0 ? -1 : 1;
7131 } else if (cur1 == cur2) {
7134 cmp = cur1 < cur2 ? -1 : 1;
7138 SvREFCNT_dec(svrecode);
7146 =for apidoc sv_cmp_locale
7148 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7149 'use bytes' aware, handles get magic, and will coerce its args to strings
7150 if necessary. See also C<sv_cmp>.
7152 =for apidoc sv_cmp_locale_flags
7154 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7155 'use bytes' aware and will coerce its args to strings if necessary. If the
7156 flags contain SV_GMAGIC, it handles get magic. See also C<sv_cmp_flags>.
7162 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
7164 return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
7168 Perl_sv_cmp_locale_flags(pTHX_ register SV *const sv1, register SV *const sv2, const I32 flags)
7171 #ifdef USE_LOCALE_COLLATE
7177 if (PL_collation_standard)
7181 pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
7183 pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
7185 if (!pv1 || !len1) {
7196 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
7199 return retval < 0 ? -1 : 1;
7202 * When the result of collation is equality, that doesn't mean
7203 * that there are no differences -- some locales exclude some
7204 * characters from consideration. So to avoid false equalities,
7205 * we use the raw string as a tiebreaker.
7211 #endif /* USE_LOCALE_COLLATE */
7213 return sv_cmp(sv1, sv2);
7217 #ifdef USE_LOCALE_COLLATE
7220 =for apidoc sv_collxfrm
7222 This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag. See
7223 C<sv_collxfrm_flags>.
7225 =for apidoc sv_collxfrm_flags
7227 Add Collate Transform magic to an SV if it doesn't already have it. If the
7228 flags contain SV_GMAGIC, it handles get-magic.
7230 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
7231 scalar data of the variable, but transformed to such a format that a normal
7232 memory comparison can be used to compare the data according to the locale
7239 Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
7244 PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
7246 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
7247 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
7253 Safefree(mg->mg_ptr);
7254 s = SvPV_flags_const(sv, len, flags);
7255 if ((xf = mem_collxfrm(s, len, &xlen))) {
7257 #ifdef PERL_OLD_COPY_ON_WRITE
7259 sv_force_normal_flags(sv, 0);
7261 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
7275 if (mg && mg->mg_ptr) {
7277 return mg->mg_ptr + sizeof(PL_collation_ix);
7285 #endif /* USE_LOCALE_COLLATE */
7290 Get a line from the filehandle and store it into the SV, optionally
7291 appending to the currently-stored string.
7297 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
7302 register STDCHAR rslast;
7303 register STDCHAR *bp;
7308 PERL_ARGS_ASSERT_SV_GETS;
7310 if (SvTHINKFIRST(sv))
7311 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
7312 /* XXX. If you make this PVIV, then copy on write can copy scalars read
7314 However, perlbench says it's slower, because the existing swipe code
7315 is faster than copy on write.
7316 Swings and roundabouts. */
7317 SvUPGRADE(sv, SVt_PV);
7322 if (PerlIO_isutf8(fp)) {
7324 sv_utf8_upgrade_nomg(sv);
7325 sv_pos_u2b(sv,&append,0);
7327 } else if (SvUTF8(sv)) {
7328 SV * const tsv = newSV(0);
7329 sv_gets(tsv, fp, 0);
7330 sv_utf8_upgrade_nomg(tsv);
7331 SvCUR_set(sv,append);
7334 goto return_string_or_null;
7342 if (PerlIO_isutf8(fp))
7345 if (IN_PERL_COMPILETIME) {
7346 /* we always read code in line mode */
7350 else if (RsSNARF(PL_rs)) {
7351 /* If it is a regular disk file use size from stat() as estimate
7352 of amount we are going to read -- may result in mallocing
7353 more memory than we really need if the layers below reduce
7354 the size we read (e.g. CRLF or a gzip layer).
7357 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
7358 const Off_t offset = PerlIO_tell(fp);
7359 if (offset != (Off_t) -1 && st.st_size + append > offset) {
7360 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7366 else if (RsRECORD(PL_rs)) {
7374 /* Grab the size of the record we're getting */
7375 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7376 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7379 /* VMS wants read instead of fread, because fread doesn't respect */
7380 /* RMS record boundaries. This is not necessarily a good thing to be */
7381 /* doing, but we've got no other real choice - except avoid stdio
7382 as implementation - perhaps write a :vms layer ?
7384 fd = PerlIO_fileno(fp);
7385 if (fd == -1) { /* in-memory file from PerlIO::Scalar */
7386 bytesread = PerlIO_read(fp, buffer, recsize);
7389 bytesread = PerlLIO_read(fd, buffer, recsize);
7392 bytesread = PerlIO_read(fp, buffer, recsize);
7396 SvCUR_set(sv, bytesread + append);
7397 buffer[bytesread] = '\0';
7398 goto return_string_or_null;
7400 else if (RsPARA(PL_rs)) {
7406 /* Get $/ i.e. PL_rs into same encoding as stream wants */
7407 if (PerlIO_isutf8(fp)) {
7408 rsptr = SvPVutf8(PL_rs, rslen);
7411 if (SvUTF8(PL_rs)) {
7412 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7413 Perl_croak(aTHX_ "Wide character in $/");
7416 rsptr = SvPV_const(PL_rs, rslen);
7420 rslast = rslen ? rsptr[rslen - 1] : '\0';
7422 if (rspara) { /* have to do this both before and after */
7423 do { /* to make sure file boundaries work right */
7426 i = PerlIO_getc(fp);
7430 PerlIO_ungetc(fp,i);
7436 /* See if we know enough about I/O mechanism to cheat it ! */
7438 /* This used to be #ifdef test - it is made run-time test for ease
7439 of abstracting out stdio interface. One call should be cheap
7440 enough here - and may even be a macro allowing compile
7444 if (PerlIO_fast_gets(fp)) {
7447 * We're going to steal some values from the stdio struct
7448 * and put EVERYTHING in the innermost loop into registers.
7450 register STDCHAR *ptr;
7454 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7455 /* An ungetc()d char is handled separately from the regular
7456 * buffer, so we getc() it back out and stuff it in the buffer.
7458 i = PerlIO_getc(fp);
7459 if (i == EOF) return 0;
7460 *(--((*fp)->_ptr)) = (unsigned char) i;
7464 /* Here is some breathtakingly efficient cheating */
7466 cnt = PerlIO_get_cnt(fp); /* get count into register */
7467 /* make sure we have the room */
7468 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7469 /* Not room for all of it
7470 if we are looking for a separator and room for some
7472 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7473 /* just process what we have room for */
7474 shortbuffered = cnt - SvLEN(sv) + append + 1;
7475 cnt -= shortbuffered;
7479 /* remember that cnt can be negative */
7480 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7485 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
7486 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7487 DEBUG_P(PerlIO_printf(Perl_debug_log,
7488 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7489 DEBUG_P(PerlIO_printf(Perl_debug_log,
7490 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7491 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7492 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7497 while (cnt > 0) { /* this | eat */
7499 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7500 goto thats_all_folks; /* screams | sed :-) */
7504 Copy(ptr, bp, cnt, char); /* this | eat */
7505 bp += cnt; /* screams | dust */
7506 ptr += cnt; /* louder | sed :-) */
7511 if (shortbuffered) { /* oh well, must extend */
7512 cnt = shortbuffered;
7514 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7516 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7517 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7521 DEBUG_P(PerlIO_printf(Perl_debug_log,
7522 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7523 PTR2UV(ptr),(long)cnt));
7524 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7526 DEBUG_P(PerlIO_printf(Perl_debug_log,
7527 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7528 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7529 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7531 /* This used to call 'filbuf' in stdio form, but as that behaves like
7532 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7533 another abstraction. */
7534 i = PerlIO_getc(fp); /* get more characters */
7536 DEBUG_P(PerlIO_printf(Perl_debug_log,
7537 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7538 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7539 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7541 cnt = PerlIO_get_cnt(fp);
7542 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7543 DEBUG_P(PerlIO_printf(Perl_debug_log,
7544 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7546 if (i == EOF) /* all done for ever? */
7547 goto thats_really_all_folks;
7549 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7551 SvGROW(sv, bpx + cnt + 2);
7552 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7554 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7556 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7557 goto thats_all_folks;
7561 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7562 memNE((char*)bp - rslen, rsptr, rslen))
7563 goto screamer; /* go back to the fray */
7564 thats_really_all_folks:
7566 cnt += shortbuffered;
7567 DEBUG_P(PerlIO_printf(Perl_debug_log,
7568 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7569 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7570 DEBUG_P(PerlIO_printf(Perl_debug_log,
7571 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7572 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7573 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7575 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
7576 DEBUG_P(PerlIO_printf(Perl_debug_log,
7577 "Screamer: done, len=%ld, string=|%.*s|\n",
7578 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7582 /*The big, slow, and stupid way. */
7583 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
7584 STDCHAR *buf = NULL;
7585 Newx(buf, 8192, STDCHAR);
7593 register const STDCHAR * const bpe = buf + sizeof(buf);
7595 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7596 ; /* keep reading */
7600 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7601 /* Accomodate broken VAXC compiler, which applies U8 cast to
7602 * both args of ?: operator, causing EOF to change into 255
7605 i = (U8)buf[cnt - 1];
7611 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7613 sv_catpvn(sv, (char *) buf, cnt);
7615 sv_setpvn(sv, (char *) buf, cnt);
7617 if (i != EOF && /* joy */
7619 SvCUR(sv) < rslen ||
7620 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7624 * If we're reading from a TTY and we get a short read,
7625 * indicating that the user hit his EOF character, we need
7626 * to notice it now, because if we try to read from the TTY
7627 * again, the EOF condition will disappear.
7629 * The comparison of cnt to sizeof(buf) is an optimization
7630 * that prevents unnecessary calls to feof().
7634 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7638 #ifdef USE_HEAP_INSTEAD_OF_STACK
7643 if (rspara) { /* have to do this both before and after */
7644 while (i != EOF) { /* to make sure file boundaries work right */
7645 i = PerlIO_getc(fp);
7647 PerlIO_ungetc(fp,i);
7653 return_string_or_null:
7654 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7660 Auto-increment of the value in the SV, doing string to numeric conversion
7661 if necessary. Handles 'get' magic and operator overloading.
7667 Perl_sv_inc(pTHX_ register SV *const sv)
7676 =for apidoc sv_inc_nomg
7678 Auto-increment of the value in the SV, doing string to numeric conversion
7679 if necessary. Handles operator overloading. Skips handling 'get' magic.
7685 Perl_sv_inc_nomg(pTHX_ register SV *const sv)
7693 if (SvTHINKFIRST(sv)) {
7695 sv_force_normal_flags(sv, 0);
7696 if (SvREADONLY(sv)) {
7697 if (IN_PERL_RUNTIME)
7698 Perl_croak_no_modify(aTHX);
7702 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7704 i = PTR2IV(SvRV(sv));
7709 flags = SvFLAGS(sv);
7710 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7711 /* It's (privately or publicly) a float, but not tested as an
7712 integer, so test it to see. */
7714 flags = SvFLAGS(sv);
7716 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7717 /* It's publicly an integer, or privately an integer-not-float */
7718 #ifdef PERL_PRESERVE_IVUV
7722 if (SvUVX(sv) == UV_MAX)
7723 sv_setnv(sv, UV_MAX_P1);
7725 (void)SvIOK_only_UV(sv);
7726 SvUV_set(sv, SvUVX(sv) + 1);
7728 if (SvIVX(sv) == IV_MAX)
7729 sv_setuv(sv, (UV)IV_MAX + 1);
7731 (void)SvIOK_only(sv);
7732 SvIV_set(sv, SvIVX(sv) + 1);
7737 if (flags & SVp_NOK) {
7738 const NV was = SvNVX(sv);
7739 if (NV_OVERFLOWS_INTEGERS_AT &&
7740 was >= NV_OVERFLOWS_INTEGERS_AT) {
7741 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7742 "Lost precision when incrementing %" NVff " by 1",
7745 (void)SvNOK_only(sv);
7746 SvNV_set(sv, was + 1.0);
7750 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7751 if ((flags & SVTYPEMASK) < SVt_PVIV)
7752 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
7753 (void)SvIOK_only(sv);
7758 while (isALPHA(*d)) d++;
7759 while (isDIGIT(*d)) d++;
7760 if (d < SvEND(sv)) {
7761 #ifdef PERL_PRESERVE_IVUV
7762 /* Got to punt this as an integer if needs be, but we don't issue
7763 warnings. Probably ought to make the sv_iv_please() that does
7764 the conversion if possible, and silently. */
7765 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7766 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7767 /* Need to try really hard to see if it's an integer.
7768 9.22337203685478e+18 is an integer.
7769 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7770 so $a="9.22337203685478e+18"; $a+0; $a++
7771 needs to be the same as $a="9.22337203685478e+18"; $a++
7778 /* sv_2iv *should* have made this an NV */
7779 if (flags & SVp_NOK) {
7780 (void)SvNOK_only(sv);
7781 SvNV_set(sv, SvNVX(sv) + 1.0);
7784 /* I don't think we can get here. Maybe I should assert this
7785 And if we do get here I suspect that sv_setnv will croak. NWC
7787 #if defined(USE_LONG_DOUBLE)
7788 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",
7789 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7791 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7792 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7795 #endif /* PERL_PRESERVE_IVUV */
7796 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7800 while (d >= SvPVX_const(sv)) {
7808 /* MKS: The original code here died if letters weren't consecutive.
7809 * at least it didn't have to worry about non-C locales. The
7810 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7811 * arranged in order (although not consecutively) and that only
7812 * [A-Za-z] are accepted by isALPHA in the C locale.
7814 if (*d != 'z' && *d != 'Z') {
7815 do { ++*d; } while (!isALPHA(*d));
7818 *(d--) -= 'z' - 'a';
7823 *(d--) -= 'z' - 'a' + 1;
7827 /* oh,oh, the number grew */
7828 SvGROW(sv, SvCUR(sv) + 2);
7829 SvCUR_set(sv, SvCUR(sv) + 1);
7830 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7841 Auto-decrement of the value in the SV, doing string to numeric conversion
7842 if necessary. Handles 'get' magic and operator overloading.
7848 Perl_sv_dec(pTHX_ register SV *const sv)
7858 =for apidoc sv_dec_nomg
7860 Auto-decrement of the value in the SV, doing string to numeric conversion
7861 if necessary. Handles operator overloading. Skips handling 'get' magic.
7867 Perl_sv_dec_nomg(pTHX_ register SV *const sv)
7874 if (SvTHINKFIRST(sv)) {
7876 sv_force_normal_flags(sv, 0);
7877 if (SvREADONLY(sv)) {
7878 if (IN_PERL_RUNTIME)
7879 Perl_croak_no_modify(aTHX);
7883 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7885 i = PTR2IV(SvRV(sv));
7890 /* Unlike sv_inc we don't have to worry about string-never-numbers
7891 and keeping them magic. But we mustn't warn on punting */
7892 flags = SvFLAGS(sv);
7893 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7894 /* It's publicly an integer, or privately an integer-not-float */
7895 #ifdef PERL_PRESERVE_IVUV
7899 if (SvUVX(sv) == 0) {
7900 (void)SvIOK_only(sv);
7904 (void)SvIOK_only_UV(sv);
7905 SvUV_set(sv, SvUVX(sv) - 1);
7908 if (SvIVX(sv) == IV_MIN) {
7909 sv_setnv(sv, (NV)IV_MIN);
7913 (void)SvIOK_only(sv);
7914 SvIV_set(sv, SvIVX(sv) - 1);
7919 if (flags & SVp_NOK) {
7922 const NV was = SvNVX(sv);
7923 if (NV_OVERFLOWS_INTEGERS_AT &&
7924 was <= -NV_OVERFLOWS_INTEGERS_AT) {
7925 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7926 "Lost precision when decrementing %" NVff " by 1",
7929 (void)SvNOK_only(sv);
7930 SvNV_set(sv, was - 1.0);
7934 if (!(flags & SVp_POK)) {
7935 if ((flags & SVTYPEMASK) < SVt_PVIV)
7936 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
7938 (void)SvIOK_only(sv);
7941 #ifdef PERL_PRESERVE_IVUV
7943 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7944 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7945 /* Need to try really hard to see if it's an integer.
7946 9.22337203685478e+18 is an integer.
7947 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7948 so $a="9.22337203685478e+18"; $a+0; $a--
7949 needs to be the same as $a="9.22337203685478e+18"; $a--
7956 /* sv_2iv *should* have made this an NV */
7957 if (flags & SVp_NOK) {
7958 (void)SvNOK_only(sv);
7959 SvNV_set(sv, SvNVX(sv) - 1.0);
7962 /* I don't think we can get here. Maybe I should assert this
7963 And if we do get here I suspect that sv_setnv will croak. NWC
7965 #if defined(USE_LONG_DOUBLE)
7966 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",
7967 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7969 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7970 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7974 #endif /* PERL_PRESERVE_IVUV */
7975 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
7978 /* this define is used to eliminate a chunk of duplicated but shared logic
7979 * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
7980 * used anywhere but here - yves
7982 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
7985 PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
7989 =for apidoc sv_mortalcopy
7991 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7992 The new SV is marked as mortal. It will be destroyed "soon", either by an
7993 explicit call to FREETMPS, or by an implicit call at places such as
7994 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7999 /* Make a string that will exist for the duration of the expression
8000 * evaluation. Actually, it may have to last longer than that, but
8001 * hopefully we won't free it until it has been assigned to a
8002 * permanent location. */
8005 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
8011 sv_setsv(sv,oldstr);
8012 PUSH_EXTEND_MORTAL__SV_C(sv);
8018 =for apidoc sv_newmortal
8020 Creates a new null SV which is mortal. The reference count of the SV is
8021 set to 1. It will be destroyed "soon", either by an explicit call to
8022 FREETMPS, or by an implicit call at places such as statement boundaries.
8023 See also C<sv_mortalcopy> and C<sv_2mortal>.
8029 Perl_sv_newmortal(pTHX)
8035 SvFLAGS(sv) = SVs_TEMP;
8036 PUSH_EXTEND_MORTAL__SV_C(sv);
8042 =for apidoc newSVpvn_flags
8044 Creates a new SV and copies a string into it. The reference count for the
8045 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
8046 string. You are responsible for ensuring that the source string is at least
8047 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
8048 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
8049 If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before
8050 returning. If C<SVf_UTF8> is set, C<s> is considered to be in UTF-8 and the
8051 C<SVf_UTF8> flag will be set on the new SV.
8052 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
8054 #define newSVpvn_utf8(s, len, u) \
8055 newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
8061 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
8066 /* All the flags we don't support must be zero.
8067 And we're new code so I'm going to assert this from the start. */
8068 assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
8070 sv_setpvn(sv,s,len);
8072 /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal()
8073 * and do what it does outselves here.
8074 * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags
8075 * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which
8076 * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we
8077 * eleminate quite a few steps than it looks - Yves (explaining patch by gfx)
8080 SvFLAGS(sv) |= flags;
8082 if(flags & SVs_TEMP){
8083 PUSH_EXTEND_MORTAL__SV_C(sv);
8090 =for apidoc sv_2mortal
8092 Marks an existing SV as mortal. The SV will be destroyed "soon", either
8093 by an explicit call to FREETMPS, or by an implicit call at places such as
8094 statement boundaries. SvTEMP() is turned on which means that the SV's
8095 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
8096 and C<sv_mortalcopy>.
8102 Perl_sv_2mortal(pTHX_ register SV *const sv)
8107 if (SvREADONLY(sv) && SvIMMORTAL(sv))
8109 PUSH_EXTEND_MORTAL__SV_C(sv);
8117 Creates a new SV and copies a string into it. The reference count for the
8118 SV is set to 1. If C<len> is zero, Perl will compute the length using
8119 strlen(). For efficiency, consider using C<newSVpvn> instead.
8125 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
8131 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
8136 =for apidoc newSVpvn
8138 Creates a new SV and copies a string into it. The reference count for the
8139 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
8140 string. You are responsible for ensuring that the source string is at least
8141 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
8147 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
8153 sv_setpvn(sv,s,len);
8158 =for apidoc newSVhek
8160 Creates a new SV from the hash key structure. It will generate scalars that
8161 point to the shared string table where possible. Returns a new (undefined)
8162 SV if the hek is NULL.
8168 Perl_newSVhek(pTHX_ const HEK *const hek)
8178 if (HEK_LEN(hek) == HEf_SVKEY) {
8179 return newSVsv(*(SV**)HEK_KEY(hek));
8181 const int flags = HEK_FLAGS(hek);
8182 if (flags & HVhek_WASUTF8) {
8184 Andreas would like keys he put in as utf8 to come back as utf8
8186 STRLEN utf8_len = HEK_LEN(hek);
8187 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
8188 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
8191 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
8193 } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
8194 /* We don't have a pointer to the hv, so we have to replicate the
8195 flag into every HEK. This hv is using custom a hasing
8196 algorithm. Hence we can't return a shared string scalar, as
8197 that would contain the (wrong) hash value, and might get passed
8198 into an hv routine with a regular hash.
8199 Similarly, a hash that isn't using shared hash keys has to have
8200 the flag in every key so that we know not to try to call
8201 share_hek_kek on it. */
8203 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
8208 /* This will be overwhelminly the most common case. */
8210 /* Inline most of newSVpvn_share(), because share_hek_hek() is far
8211 more efficient than sharepvn(). */
8215 sv_upgrade(sv, SVt_PV);
8216 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
8217 SvCUR_set(sv, HEK_LEN(hek));
8230 =for apidoc newSVpvn_share
8232 Creates a new SV with its SvPVX_const pointing to a shared string in the string
8233 table. If the string does not already exist in the table, it is created
8234 first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
8235 value is used; otherwise the hash is computed. The string's hash can be later
8236 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
8237 that as the string table is used for shared hash keys these strings will have
8238 SvPVX_const == HeKEY and hash lookup will avoid string compare.
8244 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
8248 bool is_utf8 = FALSE;
8249 const char *const orig_src = src;
8252 STRLEN tmplen = -len;
8254 /* See the note in hv.c:hv_fetch() --jhi */
8255 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
8259 PERL_HASH(hash, src, len);
8261 /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
8262 changes here, update it there too. */
8263 sv_upgrade(sv, SVt_PV);
8264 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
8272 if (src != orig_src)
8278 =for apidoc newSVpv_share
8280 Like C<newSVpvn_share>, but takes a nul-terminated string instead of a
8287 Perl_newSVpv_share(pTHX_ const char *src, U32 hash)
8289 return newSVpvn_share(src, strlen(src), hash);
8292 #if defined(PERL_IMPLICIT_CONTEXT)
8294 /* pTHX_ magic can't cope with varargs, so this is a no-context
8295 * version of the main function, (which may itself be aliased to us).
8296 * Don't access this version directly.
8300 Perl_newSVpvf_nocontext(const char *const pat, ...)
8306 PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
8308 va_start(args, pat);
8309 sv = vnewSVpvf(pat, &args);
8316 =for apidoc newSVpvf
8318 Creates a new SV and initializes it with the string formatted like
8325 Perl_newSVpvf(pTHX_ const char *const pat, ...)
8330 PERL_ARGS_ASSERT_NEWSVPVF;
8332 va_start(args, pat);
8333 sv = vnewSVpvf(pat, &args);
8338 /* backend for newSVpvf() and newSVpvf_nocontext() */
8341 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
8346 PERL_ARGS_ASSERT_VNEWSVPVF;
8349 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8356 Creates a new SV and copies a floating point value into it.
8357 The reference count for the SV is set to 1.
8363 Perl_newSVnv(pTHX_ const NV n)
8376 Creates a new SV and copies an integer into it. The reference count for the
8383 Perl_newSViv(pTHX_ const IV i)
8396 Creates a new SV and copies an unsigned integer into it.
8397 The reference count for the SV is set to 1.
8403 Perl_newSVuv(pTHX_ const UV u)
8414 =for apidoc newSV_type
8416 Creates a new SV, of the type specified. The reference count for the new SV
8423 Perl_newSV_type(pTHX_ const svtype type)
8428 sv_upgrade(sv, type);
8433 =for apidoc newRV_noinc
8435 Creates an RV wrapper for an SV. The reference count for the original
8436 SV is B<not> incremented.
8442 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
8445 register SV *sv = newSV_type(SVt_IV);
8447 PERL_ARGS_ASSERT_NEWRV_NOINC;
8450 SvRV_set(sv, tmpRef);
8455 /* newRV_inc is the official function name to use now.
8456 * newRV_inc is in fact #defined to newRV in sv.h
8460 Perl_newRV(pTHX_ SV *const sv)
8464 PERL_ARGS_ASSERT_NEWRV;
8466 return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
8472 Creates a new SV which is an exact duplicate of the original SV.
8479 Perl_newSVsv(pTHX_ register SV *const old)
8486 if (SvTYPE(old) == SVTYPEMASK) {
8487 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
8491 /* SV_GMAGIC is the default for sv_setv()
8492 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
8493 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
8494 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
8499 =for apidoc sv_reset
8501 Underlying implementation for the C<reset> Perl function.
8502 Note that the perl-level function is vaguely deprecated.
8508 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
8511 char todo[PERL_UCHAR_MAX+1];
8513 PERL_ARGS_ASSERT_SV_RESET;
8518 if (!*s) { /* reset ?? searches */
8519 MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
8521 const U32 count = mg->mg_len / sizeof(PMOP**);
8522 PMOP **pmp = (PMOP**) mg->mg_ptr;
8523 PMOP *const *const end = pmp + count;
8527 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
8529 (*pmp)->op_pmflags &= ~PMf_USED;
8537 /* reset variables */
8539 if (!HvARRAY(stash))
8542 Zero(todo, 256, char);
8545 I32 i = (unsigned char)*s;
8549 max = (unsigned char)*s++;
8550 for ( ; i <= max; i++) {
8553 for (i = 0; i <= (I32) HvMAX(stash); i++) {
8555 for (entry = HvARRAY(stash)[i];
8557 entry = HeNEXT(entry))
8562 if (!todo[(U8)*HeKEY(entry)])
8564 gv = MUTABLE_GV(HeVAL(entry));
8567 if (SvTHINKFIRST(sv)) {
8568 if (!SvREADONLY(sv) && SvROK(sv))
8570 /* XXX Is this continue a bug? Why should THINKFIRST
8571 exempt us from resetting arrays and hashes? */
8575 if (SvTYPE(sv) >= SVt_PV) {
8577 if (SvPVX_const(sv) != NULL)
8585 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8587 Perl_die(aTHX_ "Can't reset %%ENV on this system");
8590 # if defined(USE_ENVIRON_ARRAY)
8593 # endif /* USE_ENVIRON_ARRAY */
8604 Using various gambits, try to get an IO from an SV: the IO slot if its a
8605 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8606 named after the PV if we're a string.
8612 Perl_sv_2io(pTHX_ SV *const sv)
8617 PERL_ARGS_ASSERT_SV_2IO;
8619 switch (SvTYPE(sv)) {
8621 io = MUTABLE_IO(sv);
8625 if (isGV_with_GP(sv)) {
8626 gv = MUTABLE_GV(sv);
8629 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8635 Perl_croak(aTHX_ PL_no_usym, "filehandle");
8637 return sv_2io(SvRV(sv));
8638 gv = gv_fetchsv(sv, 0, SVt_PVIO);
8644 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
8653 Using various gambits, try to get a CV from an SV; in addition, try if
8654 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8655 The flags in C<lref> are passed to gv_fetchsv.
8661 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8667 PERL_ARGS_ASSERT_SV_2CV;
8674 switch (SvTYPE(sv)) {
8678 return MUTABLE_CV(sv);
8685 if (isGV_with_GP(sv)) {
8686 gv = MUTABLE_GV(sv);
8695 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
8697 tryAMAGICunDEREF(to_cv);
8700 if (SvTYPE(sv) == SVt_PVCV) {
8701 cv = MUTABLE_CV(sv);
8706 else if(isGV_with_GP(sv))
8707 gv = MUTABLE_GV(sv);
8709 Perl_croak(aTHX_ "Not a subroutine reference");
8711 else if (isGV_with_GP(sv)) {
8713 gv = MUTABLE_GV(sv);
8716 gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
8722 /* Some flags to gv_fetchsv mean don't really create the GV */
8723 if (!isGV_with_GP(gv)) {
8729 if (lref && !GvCVu(gv)) {
8733 gv_efullname3(tmpsv, gv, NULL);
8734 /* XXX this is probably not what they think they're getting.
8735 * It has the same effect as "sub name;", i.e. just a forward
8737 newSUB(start_subparse(FALSE, 0),
8738 newSVOP(OP_CONST, 0, tmpsv),
8742 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8743 SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8752 Returns true if the SV has a true value by Perl's rules.
8753 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8754 instead use an in-line version.
8760 Perl_sv_true(pTHX_ register SV *const sv)
8765 register const XPV* const tXpv = (XPV*)SvANY(sv);
8767 (tXpv->xpv_cur > 1 ||
8768 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
8775 return SvIVX(sv) != 0;
8778 return SvNVX(sv) != 0.0;
8780 return sv_2bool(sv);
8786 =for apidoc sv_pvn_force
8788 Get a sensible string out of the SV somehow.
8789 A private implementation of the C<SvPV_force> macro for compilers which
8790 can't cope with complex macro expressions. Always use the macro instead.
8792 =for apidoc sv_pvn_force_flags
8794 Get a sensible string out of the SV somehow.
8795 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8796 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8797 implemented in terms of this function.
8798 You normally want to use the various wrapper macros instead: see
8799 C<SvPV_force> and C<SvPV_force_nomg>
8805 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
8809 PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
8811 if (SvTHINKFIRST(sv) && !SvROK(sv))
8812 sv_force_normal_flags(sv, 0);
8822 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8823 const char * const ref = sv_reftype(sv,0);
8825 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8826 ref, OP_DESC(PL_op));
8828 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
8830 if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
8831 || isGV_with_GP(sv))
8832 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8834 s = sv_2pv_flags(sv, &len, flags);
8838 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
8841 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8842 SvGROW(sv, len + 1);
8843 Move(s,SvPVX(sv),len,char);
8845 SvPVX(sv)[len] = '\0';
8848 SvPOK_on(sv); /* validate pointer */
8850 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8851 PTR2UV(sv),SvPVX_const(sv)));
8854 return SvPVX_mutable(sv);
8858 =for apidoc sv_pvbyten_force
8860 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
8866 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
8868 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
8870 sv_pvn_force(sv,lp);
8871 sv_utf8_downgrade(sv,0);
8877 =for apidoc sv_pvutf8n_force
8879 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
8885 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
8887 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
8889 sv_pvn_force(sv,lp);
8890 sv_utf8_upgrade(sv);
8896 =for apidoc sv_reftype
8898 Returns a string describing what the SV is a reference to.
8904 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
8906 PERL_ARGS_ASSERT_SV_REFTYPE;
8908 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8909 inside return suggests a const propagation bug in g++. */
8910 if (ob && SvOBJECT(sv)) {
8911 char * const name = HvNAME_get(SvSTASH(sv));
8912 return name ? name : (char *) "__ANON__";
8915 switch (SvTYPE(sv)) {
8930 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
8931 /* tied lvalues should appear to be
8932 * scalars for backwards compatitbility */
8933 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8934 ? "SCALAR" : "LVALUE");
8935 case SVt_PVAV: return "ARRAY";
8936 case SVt_PVHV: return "HASH";
8937 case SVt_PVCV: return "CODE";
8938 case SVt_PVGV: return (char *) (isGV_with_GP(sv)
8939 ? "GLOB" : "SCALAR");
8940 case SVt_PVFM: return "FORMAT";
8941 case SVt_PVIO: return "IO";
8942 case SVt_BIND: return "BIND";
8943 case SVt_REGEXP: return "REGEXP";
8944 default: return "UNKNOWN";
8950 =for apidoc sv_isobject
8952 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8953 object. If the SV is not an RV, or if the object is not blessed, then this
8960 Perl_sv_isobject(pTHX_ SV *sv)
8976 Returns a boolean indicating whether the SV is blessed into the specified
8977 class. This does not check for subtypes; use C<sv_derived_from> to verify
8978 an inheritance relationship.
8984 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
8988 PERL_ARGS_ASSERT_SV_ISA;
8998 hvname = HvNAME_get(SvSTASH(sv));
9002 return strEQ(hvname, name);
9008 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
9009 it will be upgraded to one. If C<classname> is non-null then the new SV will
9010 be blessed in the specified package. The new SV is returned and its
9011 reference count is 1.
9017 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
9022 PERL_ARGS_ASSERT_NEWSVRV;
9026 SV_CHECK_THINKFIRST_COW_DROP(rv);
9027 (void)SvAMAGIC_off(rv);
9029 if (SvTYPE(rv) >= SVt_PVMG) {
9030 const U32 refcnt = SvREFCNT(rv);
9034 SvREFCNT(rv) = refcnt;
9036 sv_upgrade(rv, SVt_IV);
9037 } else if (SvROK(rv)) {
9038 SvREFCNT_dec(SvRV(rv));
9040 prepare_SV_for_RV(rv);
9048 HV* const stash = gv_stashpv(classname, GV_ADD);
9049 (void)sv_bless(rv, stash);
9055 =for apidoc sv_setref_pv
9057 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
9058 argument will be upgraded to an RV. That RV will be modified to point to
9059 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
9060 into the SV. The C<classname> argument indicates the package for the
9061 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9062 will have a reference count of 1, and the RV will be returned.
9064 Do not use with other Perl types such as HV, AV, SV, CV, because those
9065 objects will become corrupted by the pointer copy process.
9067 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
9073 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
9077 PERL_ARGS_ASSERT_SV_SETREF_PV;
9080 sv_setsv(rv, &PL_sv_undef);
9084 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
9089 =for apidoc sv_setref_iv
9091 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
9092 argument will be upgraded to an RV. That RV will be modified to point to
9093 the new SV. The C<classname> argument indicates the package for the
9094 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9095 will have a reference count of 1, and the RV will be returned.
9101 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
9103 PERL_ARGS_ASSERT_SV_SETREF_IV;
9105 sv_setiv(newSVrv(rv,classname), iv);
9110 =for apidoc sv_setref_uv
9112 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
9113 argument will be upgraded to an RV. That RV will be modified to point to
9114 the new SV. The C<classname> argument indicates the package for the
9115 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9116 will have a reference count of 1, and the RV will be returned.
9122 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
9124 PERL_ARGS_ASSERT_SV_SETREF_UV;
9126 sv_setuv(newSVrv(rv,classname), uv);
9131 =for apidoc sv_setref_nv
9133 Copies a double into a new SV, optionally blessing the SV. The C<rv>
9134 argument will be upgraded to an RV. That RV will be modified to point to
9135 the new SV. The C<classname> argument indicates the package for the
9136 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9137 will have a reference count of 1, and the RV will be returned.
9143 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
9145 PERL_ARGS_ASSERT_SV_SETREF_NV;
9147 sv_setnv(newSVrv(rv,classname), nv);
9152 =for apidoc sv_setref_pvn
9154 Copies a string into a new SV, optionally blessing the SV. The length of the
9155 string must be specified with C<n>. The C<rv> argument will be upgraded to
9156 an RV. That RV will be modified to point to the new SV. The C<classname>
9157 argument indicates the package for the blessing. Set C<classname> to
9158 C<NULL> to avoid the blessing. The new SV will have a reference count
9159 of 1, and the RV will be returned.
9161 Note that C<sv_setref_pv> copies the pointer while this copies the string.
9167 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
9168 const char *const pv, const STRLEN n)
9170 PERL_ARGS_ASSERT_SV_SETREF_PVN;
9172 sv_setpvn(newSVrv(rv,classname), pv, n);
9177 =for apidoc sv_bless
9179 Blesses an SV into a specified package. The SV must be an RV. The package
9180 must be designated by its stash (see C<gv_stashpv()>). The reference count
9181 of the SV is unaffected.
9187 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
9192 PERL_ARGS_ASSERT_SV_BLESS;
9195 Perl_croak(aTHX_ "Can't bless non-reference value");
9197 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
9198 if (SvIsCOW(tmpRef))
9199 sv_force_normal_flags(tmpRef, 0);
9200 if (SvREADONLY(tmpRef))
9201 Perl_croak_no_modify(aTHX);
9202 if (SvOBJECT(tmpRef)) {
9203 if (SvTYPE(tmpRef) != SVt_PVIO)
9205 SvREFCNT_dec(SvSTASH(tmpRef));
9208 SvOBJECT_on(tmpRef);
9209 if (SvTYPE(tmpRef) != SVt_PVIO)
9211 SvUPGRADE(tmpRef, SVt_PVMG);
9212 SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
9217 (void)SvAMAGIC_off(sv);
9219 if(SvSMAGICAL(tmpRef))
9220 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
9228 /* Downgrades a PVGV to a PVMG. If it’s actually a PVLV, we leave the type
9229 * as it is after unglobbing it.
9233 S_sv_unglob(pTHX_ SV *const sv)
9238 SV * const temp = sv_newmortal();
9240 PERL_ARGS_ASSERT_SV_UNGLOB;
9242 assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
9244 gv_efullname3(temp, MUTABLE_GV(sv), "*");
9247 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
9248 && HvNAME_get(stash))
9249 mro_method_changed_in(stash);
9250 gp_free(MUTABLE_GV(sv));
9253 sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
9257 if (GvNAME_HEK(sv)) {
9258 unshare_hek(GvNAME_HEK(sv));
9260 isGV_with_GP_off(sv);
9262 if(SvTYPE(sv) == SVt_PVGV) {
9263 /* need to keep SvANY(sv) in the right arena */
9264 xpvmg = new_XPVMG();
9265 StructCopy(SvANY(sv), xpvmg, XPVMG);
9266 del_XPVGV(SvANY(sv));
9269 SvFLAGS(sv) &= ~SVTYPEMASK;
9270 SvFLAGS(sv) |= SVt_PVMG;
9273 /* Intentionally not calling any local SET magic, as this isn't so much a
9274 set operation as merely an internal storage change. */
9275 sv_setsv_flags(sv, temp, 0);
9279 =for apidoc sv_unref_flags
9281 Unsets the RV status of the SV, and decrements the reference count of
9282 whatever was being referenced by the RV. This can almost be thought of
9283 as a reversal of C<newSVrv>. The C<cflags> argument can contain
9284 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
9285 (otherwise the decrementing is conditional on the reference count being
9286 different from one or the reference being a readonly SV).
9293 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
9295 SV* const target = SvRV(ref);
9297 PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
9299 if (SvWEAKREF(ref)) {
9300 sv_del_backref(target, ref);
9302 SvRV_set(ref, NULL);
9305 SvRV_set(ref, NULL);
9307 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
9308 assigned to as BEGIN {$a = \"Foo"} will fail. */
9309 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
9310 SvREFCNT_dec(target);
9311 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
9312 sv_2mortal(target); /* Schedule for freeing later */
9316 =for apidoc sv_untaint
9318 Untaint an SV. Use C<SvTAINTED_off> instead.
9323 Perl_sv_untaint(pTHX_ SV *const sv)
9325 PERL_ARGS_ASSERT_SV_UNTAINT;
9327 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9328 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9335 =for apidoc sv_tainted
9337 Test an SV for taintedness. Use C<SvTAINTED> instead.
9342 Perl_sv_tainted(pTHX_ SV *const sv)
9344 PERL_ARGS_ASSERT_SV_TAINTED;
9346 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9347 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9348 if (mg && (mg->mg_len & 1) )
9355 =for apidoc sv_setpviv
9357 Copies an integer into the given SV, also updating its string value.
9358 Does not handle 'set' magic. See C<sv_setpviv_mg>.
9364 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
9366 char buf[TYPE_CHARS(UV)];
9368 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
9370 PERL_ARGS_ASSERT_SV_SETPVIV;
9372 sv_setpvn(sv, ptr, ebuf - ptr);
9376 =for apidoc sv_setpviv_mg
9378 Like C<sv_setpviv>, but also handles 'set' magic.
9384 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
9386 PERL_ARGS_ASSERT_SV_SETPVIV_MG;
9392 #if defined(PERL_IMPLICIT_CONTEXT)
9394 /* pTHX_ magic can't cope with varargs, so this is a no-context
9395 * version of the main function, (which may itself be aliased to us).
9396 * Don't access this version directly.
9400 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
9405 PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
9407 va_start(args, pat);
9408 sv_vsetpvf(sv, pat, &args);
9412 /* pTHX_ magic can't cope with varargs, so this is a no-context
9413 * version of the main function, (which may itself be aliased to us).
9414 * Don't access this version directly.
9418 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9423 PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
9425 va_start(args, pat);
9426 sv_vsetpvf_mg(sv, pat, &args);
9432 =for apidoc sv_setpvf
9434 Works like C<sv_catpvf> but copies the text into the SV instead of
9435 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
9441 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
9445 PERL_ARGS_ASSERT_SV_SETPVF;
9447 va_start(args, pat);
9448 sv_vsetpvf(sv, pat, &args);
9453 =for apidoc sv_vsetpvf
9455 Works like C<sv_vcatpvf> but copies the text into the SV instead of
9456 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
9458 Usually used via its frontend C<sv_setpvf>.
9464 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9466 PERL_ARGS_ASSERT_SV_VSETPVF;
9468 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9472 =for apidoc sv_setpvf_mg
9474 Like C<sv_setpvf>, but also handles 'set' magic.
9480 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9484 PERL_ARGS_ASSERT_SV_SETPVF_MG;
9486 va_start(args, pat);
9487 sv_vsetpvf_mg(sv, pat, &args);
9492 =for apidoc sv_vsetpvf_mg
9494 Like C<sv_vsetpvf>, but also handles 'set' magic.
9496 Usually used via its frontend C<sv_setpvf_mg>.
9502 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9504 PERL_ARGS_ASSERT_SV_VSETPVF_MG;
9506 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9510 #if defined(PERL_IMPLICIT_CONTEXT)
9512 /* pTHX_ magic can't cope with varargs, so this is a no-context
9513 * version of the main function, (which may itself be aliased to us).
9514 * Don't access this version directly.
9518 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
9523 PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
9525 va_start(args, pat);
9526 sv_vcatpvf(sv, pat, &args);
9530 /* pTHX_ magic can't cope with varargs, so this is a no-context
9531 * version of the main function, (which may itself be aliased to us).
9532 * Don't access this version directly.
9536 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9541 PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9543 va_start(args, pat);
9544 sv_vcatpvf_mg(sv, pat, &args);
9550 =for apidoc sv_catpvf
9552 Processes its arguments like C<sprintf> and appends the formatted
9553 output to an SV. If the appended data contains "wide" characters
9554 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9555 and characters >255 formatted with %c), the original SV might get
9556 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
9557 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9558 valid UTF-8; if the original SV was bytes, the pattern should be too.
9563 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9567 PERL_ARGS_ASSERT_SV_CATPVF;
9569 va_start(args, pat);
9570 sv_vcatpvf(sv, pat, &args);
9575 =for apidoc sv_vcatpvf
9577 Processes its arguments like C<vsprintf> and appends the formatted output
9578 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
9580 Usually used via its frontend C<sv_catpvf>.
9586 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9588 PERL_ARGS_ASSERT_SV_VCATPVF;
9590 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9594 =for apidoc sv_catpvf_mg
9596 Like C<sv_catpvf>, but also handles 'set' magic.
9602 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9606 PERL_ARGS_ASSERT_SV_CATPVF_MG;
9608 va_start(args, pat);
9609 sv_vcatpvf_mg(sv, pat, &args);
9614 =for apidoc sv_vcatpvf_mg
9616 Like C<sv_vcatpvf>, but also handles 'set' magic.
9618 Usually used via its frontend C<sv_catpvf_mg>.
9624 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9626 PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9628 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9633 =for apidoc sv_vsetpvfn
9635 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9638 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9644 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9645 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9647 PERL_ARGS_ASSERT_SV_VSETPVFN;
9650 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9655 * Warn of missing argument to sprintf, and then return a defined value
9656 * to avoid inappropriate "use of uninit" warnings [perl #71000].
9658 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
9660 S_vcatpvfn_missing_argument(pTHX) {
9661 if (ckWARN(WARN_MISSING)) {
9662 Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
9663 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
9670 S_expect_number(pTHX_ char **const pattern)
9675 PERL_ARGS_ASSERT_EXPECT_NUMBER;
9677 switch (**pattern) {
9678 case '1': case '2': case '3':
9679 case '4': case '5': case '6':
9680 case '7': case '8': case '9':
9681 var = *(*pattern)++ - '0';
9682 while (isDIGIT(**pattern)) {
9683 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
9685 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
9693 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
9695 const int neg = nv < 0;
9698 PERL_ARGS_ASSERT_F0CONVERT;
9706 if (uv & 1 && uv == nv)
9707 uv--; /* Round to even */
9709 const unsigned dig = uv % 10;
9722 =for apidoc sv_vcatpvfn
9724 Processes its arguments like C<vsprintf> and appends the formatted output
9725 to an SV. Uses an array of SVs if the C style variable argument list is
9726 missing (NULL). When running with taint checks enabled, indicates via
9727 C<maybe_tainted> if results are untrustworthy (often due to the use of
9730 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9736 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
9737 vecstr = (U8*)SvPV_const(vecsv,veclen);\
9738 vec_utf8 = DO_UTF8(vecsv);
9740 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9743 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9744 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9752 static const char nullstr[] = "(null)";
9754 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
9755 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9757 /* Times 4: a decimal digit takes more than 3 binary digits.
9758 * NV_DIG: mantissa takes than many decimal digits.
9759 * Plus 32: Playing safe. */
9760 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9761 /* large enough for "%#.#f" --chip */
9762 /* what about long double NVs? --jhi */
9764 PERL_ARGS_ASSERT_SV_VCATPVFN;
9765 PERL_UNUSED_ARG(maybe_tainted);
9767 /* no matter what, this is a string now */
9768 (void)SvPV_force(sv, origlen);
9770 /* special-case "", "%s", and "%-p" (SVf - see below) */
9773 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9775 const char * const s = va_arg(*args, char*);
9776 sv_catpv(sv, s ? s : nullstr);
9778 else if (svix < svmax) {
9779 sv_catsv(sv, *svargs);
9782 S_vcatpvfn_missing_argument(aTHX);
9785 if (args && patlen == 3 && pat[0] == '%' &&
9786 pat[1] == '-' && pat[2] == 'p') {
9787 argsv = MUTABLE_SV(va_arg(*args, void*));
9788 sv_catsv(sv, argsv);
9792 #ifndef USE_LONG_DOUBLE
9793 /* special-case "%.<number>[gf]" */
9794 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9795 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9796 unsigned digits = 0;
9800 while (*pp >= '0' && *pp <= '9')
9801 digits = 10 * digits + (*pp++ - '0');
9802 if (pp - pat == (int)patlen - 1 && svix < svmax) {
9803 const NV nv = SvNV(*svargs);
9805 /* Add check for digits != 0 because it seems that some
9806 gconverts are buggy in this case, and we don't yet have
9807 a Configure test for this. */
9808 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9809 /* 0, point, slack */
9810 Gconvert(nv, (int)digits, 0, ebuf);
9812 if (*ebuf) /* May return an empty string for digits==0 */
9815 } else if (!digits) {
9818 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9819 sv_catpvn(sv, p, l);
9825 #endif /* !USE_LONG_DOUBLE */
9827 if (!args && svix < svmax && DO_UTF8(*svargs))
9830 patend = (char*)pat + patlen;
9831 for (p = (char*)pat; p < patend; p = q) {
9834 bool vectorize = FALSE;
9835 bool vectorarg = FALSE;
9836 bool vec_utf8 = FALSE;
9842 bool has_precis = FALSE;
9844 const I32 osvix = svix;
9845 bool is_utf8 = FALSE; /* is this item utf8? */
9846 #ifdef HAS_LDBL_SPRINTF_BUG
9847 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9848 with sfio - Allen <allens@cpan.org> */
9849 bool fix_ldbl_sprintf_bug = FALSE;
9853 U8 utf8buf[UTF8_MAXBYTES+1];
9854 STRLEN esignlen = 0;
9856 const char *eptr = NULL;
9857 const char *fmtstart;
9860 const U8 *vecstr = NULL;
9867 /* we need a long double target in case HAS_LONG_DOUBLE but
9870 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9878 const char *dotstr = ".";
9879 STRLEN dotstrlen = 1;
9880 I32 efix = 0; /* explicit format parameter index */
9881 I32 ewix = 0; /* explicit width index */
9882 I32 epix = 0; /* explicit precision index */
9883 I32 evix = 0; /* explicit vector index */
9884 bool asterisk = FALSE;
9886 /* echo everything up to the next format specification */
9887 for (q = p; q < patend && *q != '%'; ++q) ;
9889 if (has_utf8 && !pat_utf8)
9890 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9892 sv_catpvn(sv, p, q - p);
9901 We allow format specification elements in this order:
9902 \d+\$ explicit format parameter index
9904 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9905 0 flag (as above): repeated to allow "v02"
9906 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9907 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9909 [%bcdefginopsuxDFOUX] format (mandatory)
9914 As of perl5.9.3, printf format checking is on by default.
9915 Internally, perl uses %p formats to provide an escape to
9916 some extended formatting. This block deals with those
9917 extensions: if it does not match, (char*)q is reset and
9918 the normal format processing code is used.
9920 Currently defined extensions are:
9921 %p include pointer address (standard)
9922 %-p (SVf) include an SV (previously %_)
9923 %-<num>p include an SV with precision <num>
9924 %<num>p reserved for future extensions
9926 Robin Barker 2005-07-14
9928 %1p (VDf) removed. RMB 2007-10-19
9935 n = expect_number(&q);
9942 argsv = MUTABLE_SV(va_arg(*args, void*));
9943 eptr = SvPV_const(argsv, elen);
9949 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
9950 "internal %%<num>p might conflict with future printf extensions");
9956 if ( (width = expect_number(&q)) ) {
9971 if (plus == '+' && *q == ' ') /* '+' over ' ' */
10000 if ( (ewix = expect_number(&q)) )
10009 if ((vectorarg = asterisk)) {
10022 width = expect_number(&q);
10028 vecsv = va_arg(*args, SV*);
10030 vecsv = (evix > 0 && evix <= svmax)
10031 ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
10033 vecsv = svix < svmax
10034 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10036 dotstr = SvPV_const(vecsv, dotstrlen);
10037 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
10038 bad with tied or overloaded values that return UTF8. */
10039 if (DO_UTF8(vecsv))
10041 else if (has_utf8) {
10042 vecsv = sv_mortalcopy(vecsv);
10043 sv_utf8_upgrade(vecsv);
10044 dotstr = SvPV_const(vecsv, dotstrlen);
10051 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
10052 vecsv = svargs[efix ? efix-1 : svix++];
10053 vecstr = (U8*)SvPV_const(vecsv,veclen);
10054 vec_utf8 = DO_UTF8(vecsv);
10056 /* if this is a version object, we need to convert
10057 * back into v-string notation and then let the
10058 * vectorize happen normally
10060 if (sv_derived_from(vecsv, "version")) {
10061 char *version = savesvpv(vecsv);
10062 if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
10063 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
10064 "vector argument not supported with alpha versions");
10067 vecsv = sv_newmortal();
10068 scan_vstring(version, version + veclen, vecsv);
10069 vecstr = (U8*)SvPV_const(vecsv, veclen);
10070 vec_utf8 = DO_UTF8(vecsv);
10082 i = va_arg(*args, int);
10084 i = (ewix ? ewix <= svmax : svix < svmax) ?
10085 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10087 width = (i < 0) ? -i : i;
10097 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
10099 /* XXX: todo, support specified precision parameter */
10103 i = va_arg(*args, int);
10105 i = (ewix ? ewix <= svmax : svix < svmax)
10106 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10108 has_precis = !(i < 0);
10112 while (isDIGIT(*q))
10113 precis = precis * 10 + (*q++ - '0');
10122 case 'I': /* Ix, I32x, and I64x */
10124 if (q[1] == '6' && q[2] == '4') {
10130 if (q[1] == '3' && q[2] == '2') {
10140 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10151 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10152 if (*(q + 1) == 'l') { /* lld, llf */
10178 if (!vectorize && !args) {
10180 const I32 i = efix-1;
10181 argsv = (i >= 0 && i < svmax)
10182 ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
10184 argsv = (svix >= 0 && svix < svmax)
10185 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10189 switch (c = *q++) {
10196 uv = (args) ? va_arg(*args, int) : SvIV(argsv);
10198 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
10200 eptr = (char*)utf8buf;
10201 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
10215 eptr = va_arg(*args, char*);
10217 elen = strlen(eptr);
10219 eptr = (char *)nullstr;
10220 elen = sizeof nullstr - 1;
10224 eptr = SvPV_const(argsv, elen);
10225 if (DO_UTF8(argsv)) {
10226 STRLEN old_precis = precis;
10227 if (has_precis && precis < elen) {
10228 STRLEN ulen = sv_len_utf8(argsv);
10229 I32 p = precis > ulen ? ulen : precis;
10230 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
10233 if (width) { /* fudge width (can't fudge elen) */
10234 if (has_precis && precis < elen)
10235 width += precis - old_precis;
10237 width += elen - sv_len_utf8(argsv);
10244 if (has_precis && precis < elen)
10251 if (alt || vectorize)
10253 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
10274 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10283 esignbuf[esignlen++] = plus;
10287 case 'h': iv = (short)va_arg(*args, int); break;
10288 case 'l': iv = va_arg(*args, long); break;
10289 case 'V': iv = va_arg(*args, IV); break;
10290 default: iv = va_arg(*args, int); break;
10293 iv = va_arg(*args, Quad_t); break;
10300 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
10302 case 'h': iv = (short)tiv; break;
10303 case 'l': iv = (long)tiv; break;
10305 default: iv = tiv; break;
10308 iv = (Quad_t)tiv; break;
10314 if ( !vectorize ) /* we already set uv above */
10319 esignbuf[esignlen++] = plus;
10323 esignbuf[esignlen++] = '-';
10367 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10378 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
10379 case 'l': uv = va_arg(*args, unsigned long); break;
10380 case 'V': uv = va_arg(*args, UV); break;
10381 default: uv = va_arg(*args, unsigned); break;
10384 uv = va_arg(*args, Uquad_t); break;
10391 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
10393 case 'h': uv = (unsigned short)tuv; break;
10394 case 'l': uv = (unsigned long)tuv; break;
10396 default: uv = tuv; break;
10399 uv = (Uquad_t)tuv; break;
10408 char *ptr = ebuf + sizeof ebuf;
10409 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
10415 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
10419 } while (uv >>= 4);
10421 esignbuf[esignlen++] = '0';
10422 esignbuf[esignlen++] = c; /* 'x' or 'X' */
10428 *--ptr = '0' + dig;
10429 } while (uv >>= 3);
10430 if (alt && *ptr != '0')
10436 *--ptr = '0' + dig;
10437 } while (uv >>= 1);
10439 esignbuf[esignlen++] = '0';
10440 esignbuf[esignlen++] = c;
10443 default: /* it had better be ten or less */
10446 *--ptr = '0' + dig;
10447 } while (uv /= base);
10450 elen = (ebuf + sizeof ebuf) - ptr;
10454 zeros = precis - elen;
10455 else if (precis == 0 && elen == 1 && *eptr == '0'
10456 && !(base == 8 && alt)) /* "%#.0o" prints "0" */
10459 /* a precision nullifies the 0 flag. */
10466 /* FLOATING POINT */
10469 c = 'f'; /* maybe %F isn't supported here */
10471 case 'e': case 'E':
10473 case 'g': case 'G':
10477 /* This is evil, but floating point is even more evil */
10479 /* for SV-style calling, we can only get NV
10480 for C-style calling, we assume %f is double;
10481 for simplicity we allow any of %Lf, %llf, %qf for long double
10485 #if defined(USE_LONG_DOUBLE)
10489 /* [perl #20339] - we should accept and ignore %lf rather than die */
10493 #if defined(USE_LONG_DOUBLE)
10494 intsize = args ? 0 : 'q';
10498 #if defined(HAS_LONG_DOUBLE)
10507 /* now we need (long double) if intsize == 'q', else (double) */
10509 #if LONG_DOUBLESIZE > DOUBLESIZE
10511 va_arg(*args, long double) :
10512 va_arg(*args, double)
10514 va_arg(*args, double)
10519 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
10520 else. frexp() has some unspecified behaviour for those three */
10521 if (c != 'e' && c != 'E' && (nv * 0) == 0) {
10523 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
10524 will cast our (long double) to (double) */
10525 (void)Perl_frexp(nv, &i);
10526 if (i == PERL_INT_MIN)
10527 Perl_die(aTHX_ "panic: frexp");
10529 need = BIT_DIGITS(i);
10531 need += has_precis ? precis : 6; /* known default */
10536 #ifdef HAS_LDBL_SPRINTF_BUG
10537 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10538 with sfio - Allen <allens@cpan.org> */
10541 # define MY_DBL_MAX DBL_MAX
10542 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
10543 # if DOUBLESIZE >= 8
10544 # define MY_DBL_MAX 1.7976931348623157E+308L
10546 # define MY_DBL_MAX 3.40282347E+38L
10550 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10551 # define MY_DBL_MAX_BUG 1L
10553 # define MY_DBL_MAX_BUG MY_DBL_MAX
10557 # define MY_DBL_MIN DBL_MIN
10558 # else /* XXX guessing! -Allen */
10559 # if DOUBLESIZE >= 8
10560 # define MY_DBL_MIN 2.2250738585072014E-308L
10562 # define MY_DBL_MIN 1.17549435E-38L
10566 if ((intsize == 'q') && (c == 'f') &&
10567 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10568 (need < DBL_DIG)) {
10569 /* it's going to be short enough that
10570 * long double precision is not needed */
10572 if ((nv <= 0L) && (nv >= -0L))
10573 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10575 /* would use Perl_fp_class as a double-check but not
10576 * functional on IRIX - see perl.h comments */
10578 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10579 /* It's within the range that a double can represent */
10580 #if defined(DBL_MAX) && !defined(DBL_MIN)
10581 if ((nv >= ((long double)1/DBL_MAX)) ||
10582 (nv <= (-(long double)1/DBL_MAX)))
10584 fix_ldbl_sprintf_bug = TRUE;
10587 if (fix_ldbl_sprintf_bug == TRUE) {
10597 # undef MY_DBL_MAX_BUG
10600 #endif /* HAS_LDBL_SPRINTF_BUG */
10602 need += 20; /* fudge factor */
10603 if (PL_efloatsize < need) {
10604 Safefree(PL_efloatbuf);
10605 PL_efloatsize = need + 20; /* more fudge */
10606 Newx(PL_efloatbuf, PL_efloatsize, char);
10607 PL_efloatbuf[0] = '\0';
10610 if ( !(width || left || plus || alt) && fill != '0'
10611 && has_precis && intsize != 'q' ) { /* Shortcuts */
10612 /* See earlier comment about buggy Gconvert when digits,
10614 if ( c == 'g' && precis) {
10615 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10616 /* May return an empty string for digits==0 */
10617 if (*PL_efloatbuf) {
10618 elen = strlen(PL_efloatbuf);
10619 goto float_converted;
10621 } else if ( c == 'f' && !precis) {
10622 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10627 char *ptr = ebuf + sizeof ebuf;
10630 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10631 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10632 if (intsize == 'q') {
10633 /* Copy the one or more characters in a long double
10634 * format before the 'base' ([efgEFG]) character to
10635 * the format string. */
10636 static char const prifldbl[] = PERL_PRIfldbl;
10637 char const *p = prifldbl + sizeof(prifldbl) - 3;
10638 while (p >= prifldbl) { *--ptr = *p--; }
10643 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10648 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10660 /* No taint. Otherwise we are in the strange situation
10661 * where printf() taints but print($float) doesn't.
10663 #if defined(HAS_LONG_DOUBLE)
10664 elen = ((intsize == 'q')
10665 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
10666 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
10668 elen = my_sprintf(PL_efloatbuf, ptr, nv);
10672 eptr = PL_efloatbuf;
10680 i = SvCUR(sv) - origlen;
10683 case 'h': *(va_arg(*args, short*)) = i; break;
10684 default: *(va_arg(*args, int*)) = i; break;
10685 case 'l': *(va_arg(*args, long*)) = i; break;
10686 case 'V': *(va_arg(*args, IV*)) = i; break;
10689 *(va_arg(*args, Quad_t*)) = i; break;
10696 sv_setuv_mg(argsv, (UV)i);
10697 continue; /* not "break" */
10704 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
10705 && ckWARN(WARN_PRINTF))
10707 SV * const msg = sv_newmortal();
10708 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10709 (PL_op->op_type == OP_PRTF) ? "" : "s");
10710 if (fmtstart < patend) {
10711 const char * const fmtend = q < patend ? q : patend;
10713 sv_catpvs(msg, "\"%");
10714 for (f = fmtstart; f < fmtend; f++) {
10716 sv_catpvn(msg, f, 1);
10718 Perl_sv_catpvf(aTHX_ msg,
10719 "\\%03"UVof, (UV)*f & 0xFF);
10722 sv_catpvs(msg, "\"");
10724 sv_catpvs(msg, "end of string");
10726 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
10729 /* output mangled stuff ... */
10735 /* ... right here, because formatting flags should not apply */
10736 SvGROW(sv, SvCUR(sv) + elen + 1);
10738 Copy(eptr, p, elen, char);
10741 SvCUR_set(sv, p - SvPVX_const(sv));
10743 continue; /* not "break" */
10746 if (is_utf8 != has_utf8) {
10749 sv_utf8_upgrade(sv);
10752 const STRLEN old_elen = elen;
10753 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
10754 sv_utf8_upgrade(nsv);
10755 eptr = SvPVX_const(nsv);
10758 if (width) { /* fudge width (can't fudge elen) */
10759 width += elen - old_elen;
10765 have = esignlen + zeros + elen;
10767 Perl_croak_nocontext("%s", PL_memory_wrap);
10769 need = (have > width ? have : width);
10772 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
10773 Perl_croak_nocontext("%s", PL_memory_wrap);
10774 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10776 if (esignlen && fill == '0') {
10778 for (i = 0; i < (int)esignlen; i++)
10779 *p++ = esignbuf[i];
10781 if (gap && !left) {
10782 memset(p, fill, gap);
10785 if (esignlen && fill != '0') {
10787 for (i = 0; i < (int)esignlen; i++)
10788 *p++ = esignbuf[i];
10792 for (i = zeros; i; i--)
10796 Copy(eptr, p, elen, char);
10800 memset(p, ' ', gap);
10805 Copy(dotstr, p, dotstrlen, char);
10809 vectorize = FALSE; /* done iterating over vecstr */
10816 SvCUR_set(sv, p - SvPVX_const(sv));
10825 /* =========================================================================
10827 =head1 Cloning an interpreter
10829 All the macros and functions in this section are for the private use of
10830 the main function, perl_clone().
10832 The foo_dup() functions make an exact copy of an existing foo thingy.
10833 During the course of a cloning, a hash table is used to map old addresses
10834 to new addresses. The table is created and manipulated with the
10835 ptr_table_* functions.
10839 * =========================================================================*/
10842 #if defined(USE_ITHREADS)
10844 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
10845 #ifndef GpREFCNT_inc
10846 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10850 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
10851 that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
10852 If this changes, please unmerge ss_dup.
10853 Likewise, sv_dup_inc_multiple() relies on this fact. */
10854 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup_inc(s,t))
10855 #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
10856 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
10857 #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
10858 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
10859 #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
10860 #define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t))
10861 #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
10862 #define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t))
10863 #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
10864 #define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t))
10865 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
10866 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
10868 /* clone a parser */
10871 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
10875 PERL_ARGS_ASSERT_PARSER_DUP;
10880 /* look for it in the table first */
10881 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
10885 /* create anew and remember what it is */
10886 Newxz(parser, 1, yy_parser);
10887 ptr_table_store(PL_ptr_table, proto, parser);
10889 /* XXX these not yet duped */
10890 parser->old_parser = NULL;
10891 parser->stack = NULL;
10893 parser->stack_size = 0;
10894 /* XXX parser->stack->state = 0; */
10896 /* XXX eventually, just Copy() most of the parser struct ? */
10898 parser->lex_brackets = proto->lex_brackets;
10899 parser->lex_casemods = proto->lex_casemods;
10900 parser->lex_brackstack = savepvn(proto->lex_brackstack,
10901 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
10902 parser->lex_casestack = savepvn(proto->lex_casestack,
10903 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
10904 parser->lex_defer = proto->lex_defer;
10905 parser->lex_dojoin = proto->lex_dojoin;
10906 parser->lex_expect = proto->lex_expect;
10907 parser->lex_formbrack = proto->lex_formbrack;
10908 parser->lex_inpat = proto->lex_inpat;
10909 parser->lex_inwhat = proto->lex_inwhat;
10910 parser->lex_op = proto->lex_op;
10911 parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
10912 parser->lex_starts = proto->lex_starts;
10913 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
10914 parser->multi_close = proto->multi_close;
10915 parser->multi_open = proto->multi_open;
10916 parser->multi_start = proto->multi_start;
10917 parser->multi_end = proto->multi_end;
10918 parser->pending_ident = proto->pending_ident;
10919 parser->preambled = proto->preambled;
10920 parser->sublex_info = proto->sublex_info; /* XXX not quite right */
10921 parser->linestr = sv_dup_inc(proto->linestr, param);
10922 parser->expect = proto->expect;
10923 parser->copline = proto->copline;
10924 parser->last_lop_op = proto->last_lop_op;
10925 parser->lex_state = proto->lex_state;
10926 parser->rsfp = fp_dup(proto->rsfp, '<', param);
10927 /* rsfp_filters entries have fake IoDIRP() */
10928 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
10929 parser->in_my = proto->in_my;
10930 parser->in_my_stash = hv_dup(proto->in_my_stash, param);
10931 parser->error_count = proto->error_count;
10934 parser->linestr = sv_dup_inc(proto->linestr, param);
10937 char * const ols = SvPVX(proto->linestr);
10938 char * const ls = SvPVX(parser->linestr);
10940 parser->bufptr = ls + (proto->bufptr >= ols ?
10941 proto->bufptr - ols : 0);
10942 parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
10943 proto->oldbufptr - ols : 0);
10944 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
10945 proto->oldoldbufptr - ols : 0);
10946 parser->linestart = ls + (proto->linestart >= ols ?
10947 proto->linestart - ols : 0);
10948 parser->last_uni = ls + (proto->last_uni >= ols ?
10949 proto->last_uni - ols : 0);
10950 parser->last_lop = ls + (proto->last_lop >= ols ?
10951 proto->last_lop - ols : 0);
10953 parser->bufend = ls + SvCUR(parser->linestr);
10956 Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
10960 parser->endwhite = proto->endwhite;
10961 parser->faketokens = proto->faketokens;
10962 parser->lasttoke = proto->lasttoke;
10963 parser->nextwhite = proto->nextwhite;
10964 parser->realtokenstart = proto->realtokenstart;
10965 parser->skipwhite = proto->skipwhite;
10966 parser->thisclose = proto->thisclose;
10967 parser->thismad = proto->thismad;
10968 parser->thisopen = proto->thisopen;
10969 parser->thisstuff = proto->thisstuff;
10970 parser->thistoken = proto->thistoken;
10971 parser->thiswhite = proto->thiswhite;
10973 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
10974 parser->curforce = proto->curforce;
10976 Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
10977 Copy(proto->nexttype, parser->nexttype, 5, I32);
10978 parser->nexttoke = proto->nexttoke;
10981 /* XXX should clone saved_curcop here, but we aren't passed
10982 * proto_perl; so do it in perl_clone_using instead */
10988 /* duplicate a file handle */
10991 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
10995 PERL_ARGS_ASSERT_FP_DUP;
10996 PERL_UNUSED_ARG(type);
10999 return (PerlIO*)NULL;
11001 /* look for it in the table first */
11002 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
11006 /* create anew and remember what it is */
11007 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
11008 ptr_table_store(PL_ptr_table, fp, ret);
11012 /* duplicate a directory handle */
11015 Perl_dirp_dup(pTHX_ DIR *const dp)
11020 register const Direntry_t *dirent;
11021 char smallbuf[256];
11027 PERL_UNUSED_CONTEXT;
11032 /* look for it in the table first */
11033 ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
11039 /* open the current directory (so we can switch back) */
11040 if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
11042 /* chdir to our dir handle and open the present working directory */
11043 if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
11044 PerlDir_close(pwd);
11045 return (DIR *)NULL;
11047 /* Now we should have two dir handles pointing to the same dir. */
11049 /* Be nice to the calling code and chdir back to where we were. */
11050 fchdir(my_dirfd(pwd)); /* If this fails, then what? */
11052 /* We have no need of the pwd handle any more. */
11053 PerlDir_close(pwd);
11056 # define d_namlen(d) (d)->d_namlen
11058 # define d_namlen(d) strlen((d)->d_name)
11060 /* Iterate once through dp, to get the file name at the current posi-
11061 tion. Then step back. */
11062 pos = PerlDir_tell(dp);
11063 if ((dirent = PerlDir_read(dp))) {
11064 len = d_namlen(dirent);
11065 if (len <= sizeof smallbuf) name = smallbuf;
11066 else Newx(name, len, char);
11067 Move(dirent->d_name, name, len, char);
11069 PerlDir_seek(dp, pos);
11071 /* Iterate through the new dir handle, till we find a file with the
11073 if (!dirent) /* just before the end */
11075 pos = PerlDir_tell(ret);
11076 if (PerlDir_read(ret)) continue; /* not there yet */
11077 PerlDir_seek(ret, pos); /* step back */
11081 const long pos0 = PerlDir_tell(ret);
11083 pos = PerlDir_tell(ret);
11084 if ((dirent = PerlDir_read(ret))) {
11085 if (len == d_namlen(dirent)
11086 && memEQ(name, dirent->d_name, len)) {
11088 PerlDir_seek(ret, pos); /* step back */
11091 /* else we are not there yet; keep iterating */
11093 else { /* This is not meant to happen. The best we can do is
11094 reset the iterator to the beginning. */
11095 PerlDir_seek(ret, pos0);
11102 if (name && name != smallbuf)
11105 /* pop it in the pointer table */
11106 ptr_table_store(PL_ptr_table, dp, ret);
11114 /* duplicate a typeglob */
11117 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
11121 PERL_ARGS_ASSERT_GP_DUP;
11125 /* look for it in the table first */
11126 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
11130 /* create anew and remember what it is */
11132 ptr_table_store(PL_ptr_table, gp, ret);
11135 /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
11136 on Newxz() to do this for us. */
11137 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
11138 ret->gp_io = io_dup_inc(gp->gp_io, param);
11139 ret->gp_form = cv_dup_inc(gp->gp_form, param);
11140 ret->gp_av = av_dup_inc(gp->gp_av, param);
11141 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
11142 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
11143 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
11144 ret->gp_cvgen = gp->gp_cvgen;
11145 ret->gp_line = gp->gp_line;
11146 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
11150 /* duplicate a chain of magic */
11153 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
11155 MAGIC *mgret = NULL;
11156 MAGIC **mgprev_p = &mgret;
11158 PERL_ARGS_ASSERT_MG_DUP;
11160 for (; mg; mg = mg->mg_moremagic) {
11163 if ((param->flags & CLONEf_JOIN_IN)
11164 && mg->mg_type == PERL_MAGIC_backref)
11165 /* when joining, we let the individual SVs add themselves to
11166 * backref as needed. */
11169 Newx(nmg, 1, MAGIC);
11171 mgprev_p = &(nmg->mg_moremagic);
11173 /* There was a comment "XXX copy dynamic vtable?" but as we don't have
11174 dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
11175 from the original commit adding Perl_mg_dup() - revision 4538.
11176 Similarly there is the annotation "XXX random ptr?" next to the
11177 assignment to nmg->mg_ptr. */
11180 /* FIXME for plugins
11181 if (nmg->mg_type == PERL_MAGIC_qr) {
11182 nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
11186 nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
11187 ? nmg->mg_type == PERL_MAGIC_backref
11188 /* The backref AV has its reference
11189 * count deliberately bumped by 1 */
11190 ? SvREFCNT_inc(av_dup_inc((const AV *)
11191 nmg->mg_obj, param))
11192 : sv_dup_inc(nmg->mg_obj, param)
11193 : sv_dup(nmg->mg_obj, param);
11195 if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
11196 if (nmg->mg_len > 0) {
11197 nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
11198 if (nmg->mg_type == PERL_MAGIC_overload_table &&
11199 AMT_AMAGIC((AMT*)nmg->mg_ptr))
11201 AMT * const namtp = (AMT*)nmg->mg_ptr;
11202 sv_dup_inc_multiple((SV**)(namtp->table),
11203 (SV**)(namtp->table), NofAMmeth, param);
11206 else if (nmg->mg_len == HEf_SVKEY)
11207 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
11209 if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
11210 nmg->mg_virtual->svt_dup(aTHX_ nmg, param);
11216 #endif /* USE_ITHREADS */
11218 struct ptr_tbl_arena {
11219 struct ptr_tbl_arena *next;
11220 struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */
11223 /* create a new pointer-mapping table */
11226 Perl_ptr_table_new(pTHX)
11229 PERL_UNUSED_CONTEXT;
11231 Newx(tbl, 1, PTR_TBL_t);
11232 tbl->tbl_max = 511;
11233 tbl->tbl_items = 0;
11234 tbl->tbl_arena = NULL;
11235 tbl->tbl_arena_next = NULL;
11236 tbl->tbl_arena_end = NULL;
11237 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
11241 #define PTR_TABLE_HASH(ptr) \
11242 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
11244 /* map an existing pointer using a table */
11246 STATIC PTR_TBL_ENT_t *
11247 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
11249 PTR_TBL_ENT_t *tblent;
11250 const UV hash = PTR_TABLE_HASH(sv);
11252 PERL_ARGS_ASSERT_PTR_TABLE_FIND;
11254 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
11255 for (; tblent; tblent = tblent->next) {
11256 if (tblent->oldval == sv)
11263 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
11265 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
11267 PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
11268 PERL_UNUSED_CONTEXT;
11270 return tblent ? tblent->newval : NULL;
11273 /* add a new entry to a pointer-mapping table */
11276 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
11278 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
11280 PERL_ARGS_ASSERT_PTR_TABLE_STORE;
11281 PERL_UNUSED_CONTEXT;
11284 tblent->newval = newsv;
11286 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
11288 if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
11289 struct ptr_tbl_arena *new_arena;
11291 Newx(new_arena, 1, struct ptr_tbl_arena);
11292 new_arena->next = tbl->tbl_arena;
11293 tbl->tbl_arena = new_arena;
11294 tbl->tbl_arena_next = new_arena->array;
11295 tbl->tbl_arena_end = new_arena->array
11296 + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
11299 tblent = tbl->tbl_arena_next++;
11301 tblent->oldval = oldsv;
11302 tblent->newval = newsv;
11303 tblent->next = tbl->tbl_ary[entry];
11304 tbl->tbl_ary[entry] = tblent;
11306 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
11307 ptr_table_split(tbl);
11311 /* double the hash bucket size of an existing ptr table */
11314 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
11316 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
11317 const UV oldsize = tbl->tbl_max + 1;
11318 UV newsize = oldsize * 2;
11321 PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
11322 PERL_UNUSED_CONTEXT;
11324 Renew(ary, newsize, PTR_TBL_ENT_t*);
11325 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
11326 tbl->tbl_max = --newsize;
11327 tbl->tbl_ary = ary;
11328 for (i=0; i < oldsize; i++, ary++) {
11329 PTR_TBL_ENT_t **entp = ary;
11330 PTR_TBL_ENT_t *ent = *ary;
11331 PTR_TBL_ENT_t **curentp;
11334 curentp = ary + oldsize;
11336 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
11338 ent->next = *curentp;
11348 /* remove all the entries from a ptr table */
11349 /* Deprecated - will be removed post 5.14 */
11352 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
11354 if (tbl && tbl->tbl_items) {
11355 struct ptr_tbl_arena *arena = tbl->tbl_arena;
11357 Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
11360 struct ptr_tbl_arena *next = arena->next;
11366 tbl->tbl_items = 0;
11367 tbl->tbl_arena = NULL;
11368 tbl->tbl_arena_next = NULL;
11369 tbl->tbl_arena_end = NULL;
11373 /* clear and free a ptr table */
11376 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
11378 struct ptr_tbl_arena *arena;
11384 arena = tbl->tbl_arena;
11387 struct ptr_tbl_arena *next = arena->next;
11393 Safefree(tbl->tbl_ary);
11397 #if defined(USE_ITHREADS)
11400 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
11402 PERL_ARGS_ASSERT_RVPV_DUP;
11405 if (SvWEAKREF(sstr)) {
11406 SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
11407 if (param->flags & CLONEf_JOIN_IN) {
11408 /* if joining, we add any back references individually rather
11409 * than copying the whole backref array */
11410 Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
11414 SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
11416 else if (SvPVX_const(sstr)) {
11417 /* Has something there */
11419 /* Normal PV - clone whole allocated space */
11420 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
11421 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
11422 /* Not that normal - actually sstr is copy on write.
11423 But we are a true, independant SV, so: */
11424 SvREADONLY_off(dstr);
11429 /* Special case - not normally malloced for some reason */
11430 if (isGV_with_GP(sstr)) {
11431 /* Don't need to do anything here. */
11433 else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
11434 /* A "shared" PV - clone it as "shared" PV */
11436 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
11440 /* Some other special case - random pointer */
11441 SvPV_set(dstr, (char *) SvPVX_const(sstr));
11446 /* Copy the NULL */
11447 SvPV_set(dstr, NULL);
11451 /* duplicate a list of SVs. source and dest may point to the same memory. */
11453 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
11454 SSize_t items, CLONE_PARAMS *const param)
11456 PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
11458 while (items-- > 0) {
11459 *dest++ = sv_dup_inc(*source++, param);
11465 /* duplicate an SV of any type (including AV, HV etc) */
11468 S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11473 PERL_ARGS_ASSERT_SV_DUP_COMMON;
11475 if (SvTYPE(sstr) == SVTYPEMASK) {
11476 #ifdef DEBUG_LEAKING_SCALARS_ABORT
11481 /* look for it in the table first */
11482 dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
11486 if(param->flags & CLONEf_JOIN_IN) {
11487 /** We are joining here so we don't want do clone
11488 something that is bad **/
11489 if (SvTYPE(sstr) == SVt_PVHV) {
11490 const HEK * const hvname = HvNAME_HEK(sstr);
11492 /** don't clone stashes if they already exist **/
11493 dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
11494 ptr_table_store(PL_ptr_table, sstr, dstr);
11500 /* create anew and remember what it is */
11503 #ifdef DEBUG_LEAKING_SCALARS
11504 dstr->sv_debug_optype = sstr->sv_debug_optype;
11505 dstr->sv_debug_line = sstr->sv_debug_line;
11506 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
11507 dstr->sv_debug_parent = (SV*)sstr;
11508 FREE_SV_DEBUG_FILE(dstr);
11509 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
11512 ptr_table_store(PL_ptr_table, sstr, dstr);
11515 SvFLAGS(dstr) = SvFLAGS(sstr);
11516 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
11517 SvREFCNT(dstr) = 0; /* must be before any other dups! */
11520 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
11521 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
11522 (void*)PL_watch_pvx, SvPVX_const(sstr));
11525 /* don't clone objects whose class has asked us not to */
11526 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
11531 switch (SvTYPE(sstr)) {
11533 SvANY(dstr) = NULL;
11536 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
11538 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11540 SvIV_set(dstr, SvIVX(sstr));
11544 SvANY(dstr) = new_XNV();
11545 SvNV_set(dstr, SvNVX(sstr));
11547 /* case SVt_BIND: */
11550 /* These are all the types that need complex bodies allocating. */
11552 const svtype sv_type = SvTYPE(sstr);
11553 const struct body_details *const sv_type_details
11554 = bodies_by_type + sv_type;
11558 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11573 assert(sv_type_details->body_size);
11574 if (sv_type_details->arena) {
11575 new_body_inline(new_body, sv_type);
11577 = (void*)((char*)new_body - sv_type_details->offset);
11579 new_body = new_NOARENA(sv_type_details);
11583 SvANY(dstr) = new_body;
11586 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
11587 ((char*)SvANY(dstr)) + sv_type_details->offset,
11588 sv_type_details->copy, char);
11590 Copy(((char*)SvANY(sstr)),
11591 ((char*)SvANY(dstr)),
11592 sv_type_details->body_size + sv_type_details->offset, char);
11595 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
11596 && !isGV_with_GP(dstr)
11597 && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
11598 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11600 /* The Copy above means that all the source (unduplicated) pointers
11601 are now in the destination. We can check the flags and the
11602 pointers in either, but it's possible that there's less cache
11603 missing by always going for the destination.
11604 FIXME - instrument and check that assumption */
11605 if (sv_type >= SVt_PVMG) {
11606 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
11607 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
11608 } else if (SvMAGIC(dstr))
11609 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
11611 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
11614 /* The cast silences a GCC warning about unhandled types. */
11615 switch ((int)sv_type) {
11625 /* FIXME for plugins */
11626 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
11629 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
11630 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
11631 LvTARG(dstr) = dstr;
11632 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
11633 LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
11635 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
11637 /* non-GP case already handled above */
11638 if(isGV_with_GP(sstr)) {
11639 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
11640 /* Don't call sv_add_backref here as it's going to be
11641 created as part of the magic cloning of the symbol
11642 table--unless this is during a join and the stash
11643 is not actually being cloned. */
11644 /* Danger Will Robinson - GvGP(dstr) isn't initialised
11645 at the point of this comment. */
11646 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
11647 if (param->flags & CLONEf_JOIN_IN)
11648 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
11649 GvGP(dstr) = gp_dup(GvGP(sstr), param);
11650 (void)GpREFCNT_inc(GvGP(dstr));
11654 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
11655 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
11656 /* I have no idea why fake dirp (rsfps)
11657 should be treated differently but otherwise
11658 we end up with leaks -- sky*/
11659 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
11660 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
11661 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
11663 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
11664 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
11665 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
11666 if (IoDIRP(dstr)) {
11667 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
11670 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
11672 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param);
11674 if (IoOFP(dstr) == IoIFP(sstr))
11675 IoOFP(dstr) = IoIFP(dstr);
11677 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
11678 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
11679 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
11680 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
11683 /* avoid cloning an empty array */
11684 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
11685 SV **dst_ary, **src_ary;
11686 SSize_t items = AvFILLp((const AV *)sstr) + 1;
11688 src_ary = AvARRAY((const AV *)sstr);
11689 Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
11690 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
11691 AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
11692 AvALLOC((const AV *)dstr) = dst_ary;
11693 if (AvREAL((const AV *)sstr)) {
11694 dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
11698 while (items-- > 0)
11699 *dst_ary++ = sv_dup(*src_ary++, param);
11701 items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
11702 while (items-- > 0) {
11703 *dst_ary++ = &PL_sv_undef;
11707 AvARRAY(MUTABLE_AV(dstr)) = NULL;
11708 AvALLOC((const AV *)dstr) = (SV**)NULL;
11709 AvMAX( (const AV *)dstr) = -1;
11710 AvFILLp((const AV *)dstr) = -1;
11714 if (HvARRAY((const HV *)sstr)) {
11716 const bool sharekeys = !!HvSHAREKEYS(sstr);
11717 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
11718 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
11720 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
11721 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
11723 HvARRAY(dstr) = (HE**)darray;
11724 while (i <= sxhv->xhv_max) {
11725 const HE * const source = HvARRAY(sstr)[i];
11726 HvARRAY(dstr)[i] = source
11727 ? he_dup(source, sharekeys, param) : 0;
11732 const struct xpvhv_aux * const saux = HvAUX(sstr);
11733 struct xpvhv_aux * const daux = HvAUX(dstr);
11734 /* This flag isn't copied. */
11735 /* SvOOK_on(hv) attacks the IV flags. */
11736 SvFLAGS(dstr) |= SVf_OOK;
11738 hvname = saux->xhv_name;
11739 if (saux->xhv_name_count) {
11740 HEK ** const sname = (HEK **)saux->xhv_name;
11741 const U32 count = saux->xhv_name_count;
11742 HEK **shekp = sname + count;
11744 Newxc(daux->xhv_name, count, HEK *, HEK);
11745 dhekp = (HEK **)daux->xhv_name + count;
11746 while (shekp-- > sname) {
11748 *dhekp = hek_dup(*shekp, param);
11751 else daux->xhv_name = hek_dup(hvname, param);
11752 daux->xhv_name_count = saux->xhv_name_count;
11754 daux->xhv_riter = saux->xhv_riter;
11755 daux->xhv_eiter = saux->xhv_eiter
11756 ? he_dup(saux->xhv_eiter,
11757 cBOOL(HvSHAREKEYS(sstr)), param) : 0;
11758 /* backref array needs refcnt=2; see sv_add_backref */
11759 daux->xhv_backreferences =
11760 (param->flags & CLONEf_JOIN_IN)
11761 /* when joining, we let the individual GVs and
11762 * CVs add themselves to backref as
11763 * needed. This avoids pulling in stuff
11764 * that isn't required, and simplifies the
11765 * case where stashes aren't cloned back
11766 * if they already exist in the parent
11769 : saux->xhv_backreferences
11770 ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
11771 ? MUTABLE_AV(SvREFCNT_inc(
11772 sv_dup_inc((const SV *)
11773 saux->xhv_backreferences, param)))
11774 : MUTABLE_AV(sv_dup((const SV *)
11775 saux->xhv_backreferences, param))
11778 daux->xhv_mro_meta = saux->xhv_mro_meta
11779 ? mro_meta_dup(saux->xhv_mro_meta, param)
11782 /* Record stashes for possible cloning in Perl_clone(). */
11784 av_push(param->stashes, dstr);
11788 HvARRAY(MUTABLE_HV(dstr)) = NULL;
11791 if (!(param->flags & CLONEf_COPY_STACKS)) {
11796 /* NOTE: not refcounted */
11797 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
11798 if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
11799 Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
11801 if (!CvISXSUB(dstr))
11802 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
11804 if (CvCONST(dstr) && CvISXSUB(dstr)) {
11805 CvXSUBANY(dstr).any_ptr =
11806 sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
11808 /* don't dup if copying back - CvGV isn't refcounted, so the
11809 * duped GV may never be freed. A bit of a hack! DAPM */
11810 SvANY(MUTABLE_CV(dstr))->xcv_gv =
11812 ? gv_dup_inc(CvGV(sstr), param)
11813 : (param->flags & CLONEf_JOIN_IN)
11815 : gv_dup(CvGV(sstr), param);
11817 CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
11819 CvWEAKOUTSIDE(sstr)
11820 ? cv_dup( CvOUTSIDE(dstr), param)
11821 : cv_dup_inc(CvOUTSIDE(dstr), param);
11822 if (!CvISXSUB(dstr))
11823 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
11829 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11836 Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11838 PERL_ARGS_ASSERT_SV_DUP_INC;
11839 return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
11843 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11845 SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
11846 PERL_ARGS_ASSERT_SV_DUP;
11848 /* Track every SV that (at least initially) had a reference count of 0.
11849 We need to do this by holding an actual reference to it in this array.
11850 If we attempt to cheat, turn AvREAL_off(), and store only pointers
11851 (akin to the stashes hash, and the perl stack), we come unstuck if
11852 a weak reference (or other SV legitimately SvREFCNT() == 0 for this
11853 thread) is manipulated in a CLONE method, because CLONE runs before the
11854 unreferenced array is walked to find SVs still with SvREFCNT() == 0
11855 (and fix things up by giving each a reference via the temps stack).
11856 Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
11857 then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
11858 before the walk of unreferenced happens and a reference to that is SV
11859 added to the temps stack. At which point we have the same SV considered
11860 to be in use, and free to be re-used. Not good.
11862 if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
11863 assert(param->unreferenced);
11864 av_push(param->unreferenced, SvREFCNT_inc(dstr));
11870 /* duplicate a context */
11873 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11875 PERL_CONTEXT *ncxs;
11877 PERL_ARGS_ASSERT_CX_DUP;
11880 return (PERL_CONTEXT*)NULL;
11882 /* look for it in the table first */
11883 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11887 /* create anew and remember what it is */
11888 Newx(ncxs, max + 1, PERL_CONTEXT);
11889 ptr_table_store(PL_ptr_table, cxs, ncxs);
11890 Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
11893 PERL_CONTEXT * const ncx = &ncxs[ix];
11894 if (CxTYPE(ncx) == CXt_SUBST) {
11895 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11898 switch (CxTYPE(ncx)) {
11900 ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
11901 ? cv_dup_inc(ncx->blk_sub.cv, param)
11902 : cv_dup(ncx->blk_sub.cv,param));
11903 ncx->blk_sub.argarray = (CxHASARGS(ncx)
11904 ? av_dup_inc(ncx->blk_sub.argarray,
11907 ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
11909 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
11910 ncx->blk_sub.oldcomppad);
11913 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
11915 ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
11917 case CXt_LOOP_LAZYSV:
11918 ncx->blk_loop.state_u.lazysv.end
11919 = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
11920 /* We are taking advantage of av_dup_inc and sv_dup_inc
11921 actually being the same function, and order equivalance of
11923 We can assert the later [but only at run time :-(] */
11924 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
11925 (void *) &ncx->blk_loop.state_u.lazysv.cur);
11927 ncx->blk_loop.state_u.ary.ary
11928 = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
11929 case CXt_LOOP_LAZYIV:
11930 case CXt_LOOP_PLAIN:
11931 if (CxPADLOOP(ncx)) {
11932 ncx->blk_loop.itervar_u.oldcomppad
11933 = (PAD*)ptr_table_fetch(PL_ptr_table,
11934 ncx->blk_loop.itervar_u.oldcomppad);
11936 ncx->blk_loop.itervar_u.gv
11937 = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
11942 ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
11943 ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
11944 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
11957 /* duplicate a stack info structure */
11960 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11964 PERL_ARGS_ASSERT_SI_DUP;
11967 return (PERL_SI*)NULL;
11969 /* look for it in the table first */
11970 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11974 /* create anew and remember what it is */
11975 Newxz(nsi, 1, PERL_SI);
11976 ptr_table_store(PL_ptr_table, si, nsi);
11978 nsi->si_stack = av_dup_inc(si->si_stack, param);
11979 nsi->si_cxix = si->si_cxix;
11980 nsi->si_cxmax = si->si_cxmax;
11981 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11982 nsi->si_type = si->si_type;
11983 nsi->si_prev = si_dup(si->si_prev, param);
11984 nsi->si_next = si_dup(si->si_next, param);
11985 nsi->si_markoff = si->si_markoff;
11990 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
11991 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
11992 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
11993 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
11994 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
11995 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
11996 #define POPUV(ss,ix) ((ss)[--(ix)].any_uv)
11997 #define TOPUV(ss,ix) ((ss)[ix].any_uv)
11998 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
11999 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
12000 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
12001 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
12002 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
12003 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
12004 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
12005 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
12008 #define pv_dup_inc(p) SAVEPV(p)
12009 #define pv_dup(p) SAVEPV(p)
12010 #define svp_dup_inc(p,pp) any_dup(p,pp)
12012 /* map any object to the new equivent - either something in the
12013 * ptr table, or something in the interpreter structure
12017 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
12021 PERL_ARGS_ASSERT_ANY_DUP;
12024 return (void*)NULL;
12026 /* look for it in the table first */
12027 ret = ptr_table_fetch(PL_ptr_table, v);
12031 /* see if it is part of the interpreter structure */
12032 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
12033 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
12041 /* duplicate the save stack */
12044 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
12047 ANY * const ss = proto_perl->Isavestack;
12048 const I32 max = proto_perl->Isavestack_max;
12049 I32 ix = proto_perl->Isavestack_ix;
12062 void (*dptr) (void*);
12063 void (*dxptr) (pTHX_ void*);
12065 PERL_ARGS_ASSERT_SS_DUP;
12067 Newxz(nss, max, ANY);
12070 const UV uv = POPUV(ss,ix);
12071 const U8 type = (U8)uv & SAVE_MASK;
12073 TOPUV(nss,ix) = uv;
12075 case SAVEt_CLEARSV:
12077 case SAVEt_HELEM: /* hash element */
12078 sv = (const SV *)POPPTR(ss,ix);
12079 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12081 case SAVEt_ITEM: /* normal string */
12082 case SAVEt_GVSV: /* scalar slot in GV */
12083 case SAVEt_SV: /* scalar reference */
12084 sv = (const SV *)POPPTR(ss,ix);
12085 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12088 case SAVEt_MORTALIZESV:
12089 sv = (const SV *)POPPTR(ss,ix);
12090 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12092 case SAVEt_SHARED_PVREF: /* char* in shared space */
12093 c = (char*)POPPTR(ss,ix);
12094 TOPPTR(nss,ix) = savesharedpv(c);
12095 ptr = POPPTR(ss,ix);
12096 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12098 case SAVEt_GENERIC_SVREF: /* generic sv */
12099 case SAVEt_SVREF: /* scalar reference */
12100 sv = (const SV *)POPPTR(ss,ix);
12101 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12102 ptr = POPPTR(ss,ix);
12103 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
12105 case SAVEt_HV: /* hash reference */
12106 case SAVEt_AV: /* array reference */
12107 sv = (const SV *) POPPTR(ss,ix);
12108 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12110 case SAVEt_COMPPAD:
12112 sv = (const SV *) POPPTR(ss,ix);
12113 TOPPTR(nss,ix) = sv_dup(sv, param);
12115 case SAVEt_INT: /* int reference */
12116 ptr = POPPTR(ss,ix);
12117 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12118 intval = (int)POPINT(ss,ix);
12119 TOPINT(nss,ix) = intval;
12121 case SAVEt_LONG: /* long reference */
12122 ptr = POPPTR(ss,ix);
12123 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12124 longval = (long)POPLONG(ss,ix);
12125 TOPLONG(nss,ix) = longval;
12127 case SAVEt_I32: /* I32 reference */
12128 case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
12129 ptr = POPPTR(ss,ix);
12130 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12132 TOPINT(nss,ix) = i;
12134 case SAVEt_IV: /* IV reference */
12135 ptr = POPPTR(ss,ix);
12136 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12138 TOPIV(nss,ix) = iv;
12140 case SAVEt_HPTR: /* HV* reference */
12141 case SAVEt_APTR: /* AV* reference */
12142 case SAVEt_SPTR: /* SV* reference */
12143 ptr = POPPTR(ss,ix);
12144 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12145 sv = (const SV *)POPPTR(ss,ix);
12146 TOPPTR(nss,ix) = sv_dup(sv, param);
12148 case SAVEt_VPTR: /* random* reference */
12149 ptr = POPPTR(ss,ix);
12150 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12152 case SAVEt_INT_SMALL:
12153 case SAVEt_I32_SMALL:
12154 case SAVEt_I16: /* I16 reference */
12155 case SAVEt_I8: /* I8 reference */
12157 ptr = POPPTR(ss,ix);
12158 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12160 case SAVEt_GENERIC_PVREF: /* generic char* */
12161 case SAVEt_PPTR: /* char* reference */
12162 ptr = POPPTR(ss,ix);
12163 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12164 c = (char*)POPPTR(ss,ix);
12165 TOPPTR(nss,ix) = pv_dup(c);
12167 case SAVEt_GP: /* scalar reference */
12168 gv = (const GV *)POPPTR(ss,ix);
12169 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
12170 gp = (GP*)POPPTR(ss,ix);
12171 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
12172 (void)GpREFCNT_inc(gp);
12174 TOPINT(nss,ix) = i;
12177 ptr = POPPTR(ss,ix);
12178 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
12179 /* these are assumed to be refcounted properly */
12181 switch (((OP*)ptr)->op_type) {
12183 case OP_LEAVESUBLV:
12187 case OP_LEAVEWRITE:
12188 TOPPTR(nss,ix) = ptr;
12191 (void) OpREFCNT_inc(o);
12195 TOPPTR(nss,ix) = NULL;
12200 TOPPTR(nss,ix) = NULL;
12203 hv = (const HV *)POPPTR(ss,ix);
12204 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12206 TOPINT(nss,ix) = i;
12209 c = (char*)POPPTR(ss,ix);
12210 TOPPTR(nss,ix) = pv_dup_inc(c);
12212 case SAVEt_STACK_POS: /* Position on Perl stack */
12214 TOPINT(nss,ix) = i;
12216 case SAVEt_DESTRUCTOR:
12217 ptr = POPPTR(ss,ix);
12218 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
12219 dptr = POPDPTR(ss,ix);
12220 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
12221 any_dup(FPTR2DPTR(void *, dptr),
12224 case SAVEt_DESTRUCTOR_X:
12225 ptr = POPPTR(ss,ix);
12226 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
12227 dxptr = POPDXPTR(ss,ix);
12228 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
12229 any_dup(FPTR2DPTR(void *, dxptr),
12232 case SAVEt_REGCONTEXT:
12234 ix -= uv >> SAVE_TIGHT_SHIFT;
12236 case SAVEt_AELEM: /* array element */
12237 sv = (const SV *)POPPTR(ss,ix);
12238 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12240 TOPINT(nss,ix) = i;
12241 av = (const AV *)POPPTR(ss,ix);
12242 TOPPTR(nss,ix) = av_dup_inc(av, param);
12245 ptr = POPPTR(ss,ix);
12246 TOPPTR(nss,ix) = ptr;
12249 ptr = POPPTR(ss,ix);
12250 ptr = cophh_copy((COPHH*)ptr);
12251 TOPPTR(nss,ix) = ptr;
12253 TOPINT(nss,ix) = i;
12254 if (i & HINT_LOCALIZE_HH) {
12255 hv = (const HV *)POPPTR(ss,ix);
12256 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12259 case SAVEt_PADSV_AND_MORTALIZE:
12260 longval = (long)POPLONG(ss,ix);
12261 TOPLONG(nss,ix) = longval;
12262 ptr = POPPTR(ss,ix);
12263 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12264 sv = (const SV *)POPPTR(ss,ix);
12265 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12267 case SAVEt_SET_SVFLAGS:
12269 TOPINT(nss,ix) = i;
12271 TOPINT(nss,ix) = i;
12272 sv = (const SV *)POPPTR(ss,ix);
12273 TOPPTR(nss,ix) = sv_dup(sv, param);
12275 case SAVEt_RE_STATE:
12277 const struct re_save_state *const old_state
12278 = (struct re_save_state *)
12279 (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12280 struct re_save_state *const new_state
12281 = (struct re_save_state *)
12282 (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12284 Copy(old_state, new_state, 1, struct re_save_state);
12285 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
12287 new_state->re_state_bostr
12288 = pv_dup(old_state->re_state_bostr);
12289 new_state->re_state_reginput
12290 = pv_dup(old_state->re_state_reginput);
12291 new_state->re_state_regeol
12292 = pv_dup(old_state->re_state_regeol);
12293 new_state->re_state_regoffs
12294 = (regexp_paren_pair*)
12295 any_dup(old_state->re_state_regoffs, proto_perl);
12296 new_state->re_state_reglastparen
12297 = (U32*) any_dup(old_state->re_state_reglastparen,
12299 new_state->re_state_reglastcloseparen
12300 = (U32*)any_dup(old_state->re_state_reglastcloseparen,
12302 /* XXX This just has to be broken. The old save_re_context
12303 code did SAVEGENERICPV(PL_reg_start_tmp);
12304 PL_reg_start_tmp is char **.
12305 Look above to what the dup code does for
12306 SAVEt_GENERIC_PVREF
12307 It can never have worked.
12308 So this is merely a faithful copy of the exiting bug: */
12309 new_state->re_state_reg_start_tmp
12310 = (char **) pv_dup((char *)
12311 old_state->re_state_reg_start_tmp);
12312 /* I assume that it only ever "worked" because no-one called
12313 (pseudo)fork while the regexp engine had re-entered itself.
12315 #ifdef PERL_OLD_COPY_ON_WRITE
12316 new_state->re_state_nrs
12317 = sv_dup(old_state->re_state_nrs, param);
12319 new_state->re_state_reg_magic
12320 = (MAGIC*) any_dup(old_state->re_state_reg_magic,
12322 new_state->re_state_reg_oldcurpm
12323 = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
12325 new_state->re_state_reg_curpm
12326 = (PMOP*) any_dup(old_state->re_state_reg_curpm,
12328 new_state->re_state_reg_oldsaved
12329 = pv_dup(old_state->re_state_reg_oldsaved);
12330 new_state->re_state_reg_poscache
12331 = pv_dup(old_state->re_state_reg_poscache);
12332 new_state->re_state_reg_starttry
12333 = pv_dup(old_state->re_state_reg_starttry);
12336 case SAVEt_COMPILE_WARNINGS:
12337 ptr = POPPTR(ss,ix);
12338 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
12341 ptr = POPPTR(ss,ix);
12342 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
12346 "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
12354 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
12355 * flag to the result. This is done for each stash before cloning starts,
12356 * so we know which stashes want their objects cloned */
12359 do_mark_cloneable_stash(pTHX_ SV *const sv)
12361 const HEK * const hvname = HvNAME_HEK((const HV *)sv);
12363 GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
12364 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
12365 if (cloner && GvCV(cloner)) {
12372 mXPUSHs(newSVhek(hvname));
12374 call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
12381 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
12389 =for apidoc perl_clone
12391 Create and return a new interpreter by cloning the current one.
12393 perl_clone takes these flags as parameters:
12395 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
12396 without it we only clone the data and zero the stacks,
12397 with it we copy the stacks and the new perl interpreter is
12398 ready to run at the exact same point as the previous one.
12399 The pseudo-fork code uses COPY_STACKS while the
12400 threads->create doesn't.
12402 CLONEf_KEEP_PTR_TABLE
12403 perl_clone keeps a ptr_table with the pointer of the old
12404 variable as a key and the new variable as a value,
12405 this allows it to check if something has been cloned and not
12406 clone it again but rather just use the value and increase the
12407 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
12408 the ptr_table using the function
12409 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
12410 reason to keep it around is if you want to dup some of your own
12411 variable who are outside the graph perl scans, example of this
12412 code is in threads.xs create
12415 This is a win32 thing, it is ignored on unix, it tells perls
12416 win32host code (which is c++) to clone itself, this is needed on
12417 win32 if you want to run two threads at the same time,
12418 if you just want to do some stuff in a separate perl interpreter
12419 and then throw it away and return to the original one,
12420 you don't need to do anything.
12425 /* XXX the above needs expanding by someone who actually understands it ! */
12426 EXTERN_C PerlInterpreter *
12427 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
12430 perl_clone(PerlInterpreter *proto_perl, UV flags)
12433 #ifdef PERL_IMPLICIT_SYS
12435 PERL_ARGS_ASSERT_PERL_CLONE;
12437 /* perlhost.h so we need to call into it
12438 to clone the host, CPerlHost should have a c interface, sky */
12440 if (flags & CLONEf_CLONE_HOST) {
12441 return perl_clone_host(proto_perl,flags);
12443 return perl_clone_using(proto_perl, flags,
12445 proto_perl->IMemShared,
12446 proto_perl->IMemParse,
12448 proto_perl->IStdIO,
12452 proto_perl->IProc);
12456 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
12457 struct IPerlMem* ipM, struct IPerlMem* ipMS,
12458 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
12459 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
12460 struct IPerlDir* ipD, struct IPerlSock* ipS,
12461 struct IPerlProc* ipP)
12463 /* XXX many of the string copies here can be optimized if they're
12464 * constants; they need to be allocated as common memory and just
12465 * their pointers copied. */
12468 CLONE_PARAMS clone_params;
12469 CLONE_PARAMS* const param = &clone_params;
12471 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
12473 PERL_ARGS_ASSERT_PERL_CLONE_USING;
12474 #else /* !PERL_IMPLICIT_SYS */
12476 CLONE_PARAMS clone_params;
12477 CLONE_PARAMS* param = &clone_params;
12478 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
12480 PERL_ARGS_ASSERT_PERL_CLONE;
12481 #endif /* PERL_IMPLICIT_SYS */
12483 /* for each stash, determine whether its objects should be cloned */
12484 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
12485 PERL_SET_THX(my_perl);
12488 PoisonNew(my_perl, 1, PerlInterpreter);
12493 PL_scopestack_name = 0;
12495 PL_savestack_ix = 0;
12496 PL_savestack_max = -1;
12497 PL_sig_pending = 0;
12499 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
12500 # ifdef DEBUG_LEAKING_SCALARS
12501 PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
12503 #else /* !DEBUGGING */
12504 Zero(my_perl, 1, PerlInterpreter);
12505 #endif /* DEBUGGING */
12507 #ifdef PERL_IMPLICIT_SYS
12508 /* host pointers */
12510 PL_MemShared = ipMS;
12511 PL_MemParse = ipMP;
12518 #endif /* PERL_IMPLICIT_SYS */
12520 param->flags = flags;
12521 /* Nothing in the core code uses this, but we make it available to
12522 extensions (using mg_dup). */
12523 param->proto_perl = proto_perl;
12524 /* Likely nothing will use this, but it is initialised to be consistent
12525 with Perl_clone_params_new(). */
12526 param->proto_perl = my_perl;
12527 param->unreferenced = NULL;
12529 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
12531 PL_body_arenas = NULL;
12532 Zero(&PL_body_roots, 1, PL_body_roots);
12535 PL_sv_objcount = 0;
12537 PL_sv_arenaroot = NULL;
12539 PL_debug = proto_perl->Idebug;
12541 PL_hash_seed = proto_perl->Ihash_seed;
12542 PL_rehash_seed = proto_perl->Irehash_seed;
12544 #ifdef USE_REENTRANT_API
12545 /* XXX: things like -Dm will segfault here in perlio, but doing
12546 * PERL_SET_CONTEXT(proto_perl);
12547 * breaks too many other things
12549 Perl_reentrant_init(aTHX);
12552 /* create SV map for pointer relocation */
12553 PL_ptr_table = ptr_table_new();
12555 /* initialize these special pointers as early as possible */
12556 SvANY(&PL_sv_undef) = NULL;
12557 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
12558 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
12559 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
12561 SvANY(&PL_sv_no) = new_XPVNV();
12562 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
12563 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12564 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12565 SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
12566 SvCUR_set(&PL_sv_no, 0);
12567 SvLEN_set(&PL_sv_no, 1);
12568 SvIV_set(&PL_sv_no, 0);
12569 SvNV_set(&PL_sv_no, 0);
12570 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
12572 SvANY(&PL_sv_yes) = new_XPVNV();
12573 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
12574 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12575 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12576 SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
12577 SvCUR_set(&PL_sv_yes, 1);
12578 SvLEN_set(&PL_sv_yes, 2);
12579 SvIV_set(&PL_sv_yes, 1);
12580 SvNV_set(&PL_sv_yes, 1);
12581 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
12583 /* dbargs array probably holds garbage */
12586 /* create (a non-shared!) shared string table */
12587 PL_strtab = newHV();
12588 HvSHAREKEYS_off(PL_strtab);
12589 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
12590 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
12592 PL_compiling = proto_perl->Icompiling;
12594 /* These two PVs will be free'd special way so must set them same way op.c does */
12595 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
12596 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
12598 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
12599 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
12601 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
12602 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
12603 CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));
12604 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
12605 #ifdef PERL_DEBUG_READONLY_OPS
12610 /* pseudo environmental stuff */
12611 PL_origargc = proto_perl->Iorigargc;
12612 PL_origargv = proto_perl->Iorigargv;
12614 param->stashes = newAV(); /* Setup array of objects to call clone on */
12615 /* This makes no difference to the implementation, as it always pushes
12616 and shifts pointers to other SVs without changing their reference
12617 count, with the array becoming empty before it is freed. However, it
12618 makes it conceptually clear what is going on, and will avoid some
12619 work inside av.c, filling slots between AvFILL() and AvMAX() with
12620 &PL_sv_undef, and SvREFCNT_dec()ing those. */
12621 AvREAL_off(param->stashes);
12623 if (!(flags & CLONEf_COPY_STACKS)) {
12624 param->unreferenced = newAV();
12627 /* Set tainting stuff before PerlIO_debug can possibly get called */
12628 PL_tainting = proto_perl->Itainting;
12629 PL_taint_warn = proto_perl->Itaint_warn;
12631 #ifdef PERLIO_LAYERS
12632 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
12633 PerlIO_clone(aTHX_ proto_perl, param);
12636 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
12637 PL_incgv = gv_dup(proto_perl->Iincgv, param);
12638 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
12639 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
12640 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
12641 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
12644 PL_minus_c = proto_perl->Iminus_c;
12645 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
12646 PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
12647 PL_localpatches = proto_perl->Ilocalpatches;
12648 PL_splitstr = proto_perl->Isplitstr;
12649 PL_minus_n = proto_perl->Iminus_n;
12650 PL_minus_p = proto_perl->Iminus_p;
12651 PL_minus_l = proto_perl->Iminus_l;
12652 PL_minus_a = proto_perl->Iminus_a;
12653 PL_minus_E = proto_perl->Iminus_E;
12654 PL_minus_F = proto_perl->Iminus_F;
12655 PL_doswitches = proto_perl->Idoswitches;
12656 PL_dowarn = proto_perl->Idowarn;
12657 PL_sawampersand = proto_perl->Isawampersand;
12658 PL_unsafe = proto_perl->Iunsafe;
12659 PL_inplace = SAVEPV(proto_perl->Iinplace);
12660 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
12661 PL_perldb = proto_perl->Iperldb;
12662 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
12663 PL_exit_flags = proto_perl->Iexit_flags;
12665 /* magical thingies */
12666 /* XXX time(&PL_basetime) when asked for? */
12667 PL_basetime = proto_perl->Ibasetime;
12668 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
12670 PL_maxsysfd = proto_perl->Imaxsysfd;
12671 PL_statusvalue = proto_perl->Istatusvalue;
12673 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
12675 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
12677 PL_encoding = sv_dup(proto_perl->Iencoding, param);
12679 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
12680 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
12681 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
12684 /* RE engine related */
12685 Zero(&PL_reg_state, 1, struct re_save_state);
12686 PL_reginterp_cnt = 0;
12687 PL_regmatch_slab = NULL;
12689 /* Clone the regex array */
12690 /* ORANGE FIXME for plugins, probably in the SV dup code.
12691 newSViv(PTR2IV(CALLREGDUPE(
12692 INT2PTR(REGEXP *, SvIVX(regex)), param))))
12694 PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
12695 PL_regex_pad = AvARRAY(PL_regex_padav);
12697 /* shortcuts to various I/O objects */
12698 PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param);
12699 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
12700 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
12701 PL_defgv = gv_dup(proto_perl->Idefgv, param);
12702 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
12703 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
12704 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
12706 /* shortcuts to regexp stuff */
12707 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
12709 /* shortcuts to misc objects */
12710 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
12712 /* shortcuts to debugging objects */
12713 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
12714 PL_DBline = gv_dup(proto_perl->IDBline, param);
12715 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
12716 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
12717 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
12718 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
12720 /* symbol tables */
12721 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
12722 PL_curstash = hv_dup(proto_perl->Icurstash, param);
12723 PL_debstash = hv_dup(proto_perl->Idebstash, param);
12724 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
12725 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
12727 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
12728 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
12729 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
12730 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
12731 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
12732 PL_endav = av_dup_inc(proto_perl->Iendav, param);
12733 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
12734 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
12736 PL_sub_generation = proto_perl->Isub_generation;
12737 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
12739 /* funky return mechanisms */
12740 PL_forkprocess = proto_perl->Iforkprocess;
12742 /* subprocess state */
12743 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
12745 /* internal state */
12746 PL_maxo = proto_perl->Imaxo;
12747 if (proto_perl->Iop_mask)
12748 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
12751 /* PL_asserting = proto_perl->Iasserting; */
12753 /* current interpreter roots */
12754 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
12756 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
12758 PL_main_start = proto_perl->Imain_start;
12759 PL_eval_root = proto_perl->Ieval_root;
12760 PL_eval_start = proto_perl->Ieval_start;
12762 /* runtime control stuff */
12763 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
12765 PL_filemode = proto_perl->Ifilemode;
12766 PL_lastfd = proto_perl->Ilastfd;
12767 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
12770 PL_gensym = proto_perl->Igensym;
12771 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
12772 PL_laststatval = proto_perl->Ilaststatval;
12773 PL_laststype = proto_perl->Ilaststype;
12776 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
12778 /* interpreter atexit processing */
12779 PL_exitlistlen = proto_perl->Iexitlistlen;
12780 if (PL_exitlistlen) {
12781 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12782 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12785 PL_exitlist = (PerlExitListEntry*)NULL;
12787 PL_my_cxt_size = proto_perl->Imy_cxt_size;
12788 if (PL_my_cxt_size) {
12789 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
12790 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
12791 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12792 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
12793 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
12797 PL_my_cxt_list = (void**)NULL;
12798 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12799 PL_my_cxt_keys = (const char**)NULL;
12802 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
12803 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
12804 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
12806 PL_profiledata = NULL;
12808 PL_compcv = cv_dup(proto_perl->Icompcv, param);
12810 PAD_CLONE_VARS(proto_perl, param);
12812 #ifdef HAVE_INTERP_INTERN
12813 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
12816 /* more statics moved here */
12817 PL_generation = proto_perl->Igeneration;
12818 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
12820 PL_in_clean_objs = proto_perl->Iin_clean_objs;
12821 PL_in_clean_all = proto_perl->Iin_clean_all;
12823 PL_uid = proto_perl->Iuid;
12824 PL_euid = proto_perl->Ieuid;
12825 PL_gid = proto_perl->Igid;
12826 PL_egid = proto_perl->Iegid;
12827 PL_nomemok = proto_perl->Inomemok;
12828 PL_an = proto_perl->Ian;
12829 PL_evalseq = proto_perl->Ievalseq;
12830 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
12831 PL_origalen = proto_perl->Iorigalen;
12832 #ifdef PERL_USES_PL_PIDSTATUS
12833 PL_pidstatus = newHV(); /* XXX flag for cloning? */
12835 PL_osname = SAVEPV(proto_perl->Iosname);
12836 PL_sighandlerp = proto_perl->Isighandlerp;
12838 PL_runops = proto_perl->Irunops;
12840 PL_parser = parser_dup(proto_perl->Iparser, param);
12842 /* XXX this only works if the saved cop has already been cloned */
12843 if (proto_perl->Iparser) {
12844 PL_parser->saved_curcop = (COP*)any_dup(
12845 proto_perl->Iparser->saved_curcop,
12849 PL_subline = proto_perl->Isubline;
12850 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
12853 PL_cryptseen = proto_perl->Icryptseen;
12856 PL_hints = proto_perl->Ihints;
12858 PL_amagic_generation = proto_perl->Iamagic_generation;
12860 #ifdef USE_LOCALE_COLLATE
12861 PL_collation_ix = proto_perl->Icollation_ix;
12862 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
12863 PL_collation_standard = proto_perl->Icollation_standard;
12864 PL_collxfrm_base = proto_perl->Icollxfrm_base;
12865 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
12866 #endif /* USE_LOCALE_COLLATE */
12868 #ifdef USE_LOCALE_NUMERIC
12869 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
12870 PL_numeric_standard = proto_perl->Inumeric_standard;
12871 PL_numeric_local = proto_perl->Inumeric_local;
12872 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12873 #endif /* !USE_LOCALE_NUMERIC */
12875 /* utf8 character classes */
12876 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12877 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12878 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12879 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
12880 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12881 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
12882 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
12883 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
12884 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
12885 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
12886 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
12887 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12888 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
12889 PL_utf8_X_begin = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
12890 PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
12891 PL_utf8_X_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
12892 PL_utf8_X_non_hangul = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
12893 PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
12894 PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
12895 PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
12896 PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
12897 PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
12898 PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
12899 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12900 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12901 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12902 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12903 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12904 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12906 /* Did the locale setup indicate UTF-8? */
12907 PL_utf8locale = proto_perl->Iutf8locale;
12908 /* Unicode features (see perlrun/-C) */
12909 PL_unicode = proto_perl->Iunicode;
12911 /* Pre-5.8 signals control */
12912 PL_signals = proto_perl->Isignals;
12914 /* times() ticks per second */
12915 PL_clocktick = proto_perl->Iclocktick;
12917 /* Recursion stopper for PerlIO_find_layer */
12918 PL_in_load_module = proto_perl->Iin_load_module;
12920 /* sort() routine */
12921 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
12923 /* Not really needed/useful since the reenrant_retint is "volatile",
12924 * but do it for consistency's sake. */
12925 PL_reentrant_retint = proto_perl->Ireentrant_retint;
12927 /* Hooks to shared SVs and locks. */
12928 PL_sharehook = proto_perl->Isharehook;
12929 PL_lockhook = proto_perl->Ilockhook;
12930 PL_unlockhook = proto_perl->Iunlockhook;
12931 PL_threadhook = proto_perl->Ithreadhook;
12932 PL_destroyhook = proto_perl->Idestroyhook;
12933 PL_signalhook = proto_perl->Isignalhook;
12935 #ifdef THREADS_HAVE_PIDS
12936 PL_ppid = proto_perl->Ippid;
12940 PL_last_swash_hv = NULL; /* reinits on demand */
12941 PL_last_swash_klen = 0;
12942 PL_last_swash_key[0]= '\0';
12943 PL_last_swash_tmps = (U8*)NULL;
12944 PL_last_swash_slen = 0;
12946 PL_glob_index = proto_perl->Iglob_index;
12947 PL_srand_called = proto_perl->Isrand_called;
12949 if (proto_perl->Ipsig_pend) {
12950 Newxz(PL_psig_pend, SIG_SIZE, int);
12953 PL_psig_pend = (int*)NULL;
12956 if (proto_perl->Ipsig_name) {
12957 Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
12958 sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
12960 PL_psig_ptr = PL_psig_name + SIG_SIZE;
12963 PL_psig_ptr = (SV**)NULL;
12964 PL_psig_name = (SV**)NULL;
12967 /* intrpvar.h stuff */
12969 if (flags & CLONEf_COPY_STACKS) {
12970 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12971 PL_tmps_ix = proto_perl->Itmps_ix;
12972 PL_tmps_max = proto_perl->Itmps_max;
12973 PL_tmps_floor = proto_perl->Itmps_floor;
12974 Newx(PL_tmps_stack, PL_tmps_max, SV*);
12975 sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
12976 PL_tmps_ix+1, param);
12978 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12979 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
12980 Newxz(PL_markstack, i, I32);
12981 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
12982 - proto_perl->Imarkstack);
12983 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
12984 - proto_perl->Imarkstack);
12985 Copy(proto_perl->Imarkstack, PL_markstack,
12986 PL_markstack_ptr - PL_markstack + 1, I32);
12988 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12989 * NOTE: unlike the others! */
12990 PL_scopestack_ix = proto_perl->Iscopestack_ix;
12991 PL_scopestack_max = proto_perl->Iscopestack_max;
12992 Newxz(PL_scopestack, PL_scopestack_max, I32);
12993 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
12996 Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
12997 Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
12999 /* NOTE: si_dup() looks at PL_markstack */
13000 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
13002 /* PL_curstack = PL_curstackinfo->si_stack; */
13003 PL_curstack = av_dup(proto_perl->Icurstack, param);
13004 PL_mainstack = av_dup(proto_perl->Imainstack, param);
13006 /* next PUSHs() etc. set *(PL_stack_sp+1) */
13007 PL_stack_base = AvARRAY(PL_curstack);
13008 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
13009 - proto_perl->Istack_base);
13010 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
13012 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
13013 * NOTE: unlike the others! */
13014 PL_savestack_ix = proto_perl->Isavestack_ix;
13015 PL_savestack_max = proto_perl->Isavestack_max;
13016 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
13017 PL_savestack = ss_dup(proto_perl, param);
13021 ENTER; /* perl_destruct() wants to LEAVE; */
13024 PL_start_env = proto_perl->Istart_env; /* XXXXXX */
13025 PL_top_env = &PL_start_env;
13027 PL_op = proto_perl->Iop;
13030 PL_Xpv = (XPV*)NULL;
13031 my_perl->Ina = proto_perl->Ina;
13033 PL_statbuf = proto_perl->Istatbuf;
13034 PL_statcache = proto_perl->Istatcache;
13035 PL_statgv = gv_dup(proto_perl->Istatgv, param);
13036 PL_statname = sv_dup_inc(proto_perl->Istatname, param);
13038 PL_timesbuf = proto_perl->Itimesbuf;
13041 PL_tainted = proto_perl->Itainted;
13042 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
13043 PL_rs = sv_dup_inc(proto_perl->Irs, param);
13044 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
13045 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
13046 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
13047 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
13048 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
13049 PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
13051 PL_restartjmpenv = proto_perl->Irestartjmpenv;
13052 PL_restartop = proto_perl->Irestartop;
13053 PL_in_eval = proto_perl->Iin_eval;
13054 PL_delaymagic = proto_perl->Idelaymagic;
13055 PL_dirty = proto_perl->Idirty;
13056 PL_localizing = proto_perl->Ilocalizing;
13058 PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
13059 PL_hv_fetch_ent_mh = NULL;
13060 PL_modcount = proto_perl->Imodcount;
13061 PL_lastgotoprobe = NULL;
13062 PL_dumpindent = proto_perl->Idumpindent;
13064 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
13065 PL_sortstash = hv_dup(proto_perl->Isortstash, param);
13066 PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
13067 PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
13068 PL_efloatbuf = NULL; /* reinits on demand */
13069 PL_efloatsize = 0; /* reinits on demand */
13073 PL_screamfirst = NULL;
13074 PL_screamnext = NULL;
13075 PL_maxscream = -1; /* reinits on demand */
13076 PL_lastscream = NULL;
13079 PL_regdummy = proto_perl->Iregdummy;
13080 PL_colorset = 0; /* reinits PL_colors[] */
13081 /*PL_colors[6] = {0,0,0,0,0,0};*/
13085 /* Pluggable optimizer */
13086 PL_peepp = proto_perl->Ipeepp;
13087 PL_rpeepp = proto_perl->Irpeepp;
13088 /* op_free() hook */
13089 PL_opfreehook = proto_perl->Iopfreehook;
13091 PL_stashcache = newHV();
13093 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
13094 proto_perl->Iwatchaddr);
13095 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
13096 if (PL_debug && PL_watchaddr) {
13097 PerlIO_printf(Perl_debug_log,
13098 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
13099 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
13100 PTR2UV(PL_watchok));
13103 PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
13104 PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param);
13106 /* Call the ->CLONE method, if it exists, for each of the stashes
13107 identified by sv_dup() above.
13109 while(av_len(param->stashes) != -1) {
13110 HV* const stash = MUTABLE_HV(av_shift(param->stashes));
13111 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
13112 if (cloner && GvCV(cloner)) {
13117 mXPUSHs(newSVhek(HvNAME_HEK(stash)));
13119 call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
13125 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
13126 ptr_table_free(PL_ptr_table);
13127 PL_ptr_table = NULL;
13130 if (!(flags & CLONEf_COPY_STACKS)) {
13131 unreferenced_to_tmp_stack(param->unreferenced);
13134 SvREFCNT_dec(param->stashes);
13136 /* orphaned? eg threads->new inside BEGIN or use */
13137 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
13138 SvREFCNT_inc_simple_void(PL_compcv);
13139 SAVEFREESV(PL_compcv);
13146 S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
13148 PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
13150 if (AvFILLp(unreferenced) > -1) {
13151 SV **svp = AvARRAY(unreferenced);
13152 SV **const last = svp + AvFILLp(unreferenced);
13156 if (SvREFCNT(*svp) == 1)
13158 } while (++svp <= last);
13160 EXTEND_MORTAL(count);
13161 svp = AvARRAY(unreferenced);
13164 if (SvREFCNT(*svp) == 1) {
13165 /* Our reference is the only one to this SV. This means that
13166 in this thread, the scalar effectively has a 0 reference.
13167 That doesn't work (cleanup never happens), so donate our
13168 reference to it onto the save stack. */
13169 PL_tmps_stack[++PL_tmps_ix] = *svp;
13171 /* As an optimisation, because we are already walking the
13172 entire array, instead of above doing either
13173 SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
13174 release our reference to the scalar, so that at the end of
13175 the array owns zero references to the scalars it happens to
13176 point to. We are effectively converting the array from
13177 AvREAL() on to AvREAL() off. This saves the av_clear()
13178 (triggered by the SvREFCNT_dec(unreferenced) below) from
13179 walking the array a second time. */
13180 SvREFCNT_dec(*svp);
13183 } while (++svp <= last);
13184 AvREAL_off(unreferenced);
13186 SvREFCNT_dec(unreferenced);
13190 Perl_clone_params_del(CLONE_PARAMS *param)
13192 /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
13194 PerlInterpreter *const to = param->new_perl;
13196 PerlInterpreter *const was = PERL_GET_THX;
13198 PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
13204 SvREFCNT_dec(param->stashes);
13205 if (param->unreferenced)
13206 unreferenced_to_tmp_stack(param->unreferenced);
13216 Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
13219 /* Need to play this game, as newAV() can call safesysmalloc(), and that
13220 does a dTHX; to get the context from thread local storage.
13221 FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
13222 a version that passes in my_perl. */
13223 PerlInterpreter *const was = PERL_GET_THX;
13224 CLONE_PARAMS *param;
13226 PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
13232 /* Given that we've set the context, we can do this unshared. */
13233 Newx(param, 1, CLONE_PARAMS);
13236 param->proto_perl = from;
13237 param->new_perl = to;
13238 param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
13239 AvREAL_off(param->stashes);
13240 param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
13248 #endif /* USE_ITHREADS */
13251 =head1 Unicode Support
13253 =for apidoc sv_recode_to_utf8
13255 The encoding is assumed to be an Encode object, on entry the PV
13256 of the sv is assumed to be octets in that encoding, and the sv
13257 will be converted into Unicode (and UTF-8).
13259 If the sv already is UTF-8 (or if it is not POK), or if the encoding
13260 is not a reference, nothing is done to the sv. If the encoding is not
13261 an C<Encode::XS> Encoding object, bad things will happen.
13262 (See F<lib/encoding.pm> and L<Encode>).
13264 The PV of the sv is returned.
13269 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
13273 PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
13275 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
13289 Passing sv_yes is wrong - it needs to be or'ed set of constants
13290 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
13291 remove converted chars from source.
13293 Both will default the value - let them.
13295 XPUSHs(&PL_sv_yes);
13298 call_method("decode", G_SCALAR);
13302 s = SvPV_const(uni, len);
13303 if (s != SvPVX_const(sv)) {
13304 SvGROW(sv, len + 1);
13305 Move(s, SvPVX(sv), len + 1, char);
13306 SvCUR_set(sv, len);
13313 return SvPOKp(sv) ? SvPVX(sv) : NULL;
13317 =for apidoc sv_cat_decode
13319 The encoding is assumed to be an Encode object, the PV of the ssv is
13320 assumed to be octets in that encoding and decoding the input starts
13321 from the position which (PV + *offset) pointed to. The dsv will be
13322 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
13323 when the string tstr appears in decoding output or the input ends on
13324 the PV of the ssv. The value which the offset points will be modified
13325 to the last input position on the ssv.
13327 Returns TRUE if the terminator was found, else returns FALSE.
13332 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
13333 SV *ssv, int *offset, char *tstr, int tlen)
13338 PERL_ARGS_ASSERT_SV_CAT_DECODE;
13340 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
13351 offsv = newSViv(*offset);
13353 mXPUSHp(tstr, tlen);
13355 call_method("cat_decode", G_SCALAR);
13357 ret = SvTRUE(TOPs);
13358 *offset = SvIV(offsv);
13364 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
13369 /* ---------------------------------------------------------------------
13371 * support functions for report_uninit()
13374 /* the maxiumum size of array or hash where we will scan looking
13375 * for the undefined element that triggered the warning */
13377 #define FUV_MAX_SEARCH_SIZE 1000
13379 /* Look for an entry in the hash whose value has the same SV as val;
13380 * If so, return a mortal copy of the key. */
13383 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
13386 register HE **array;
13389 PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
13391 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
13392 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
13395 array = HvARRAY(hv);
13397 for (i=HvMAX(hv); i>0; i--) {
13398 register HE *entry;
13399 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
13400 if (HeVAL(entry) != val)
13402 if ( HeVAL(entry) == &PL_sv_undef ||
13403 HeVAL(entry) == &PL_sv_placeholder)
13407 if (HeKLEN(entry) == HEf_SVKEY)
13408 return sv_mortalcopy(HeKEY_sv(entry));
13409 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
13415 /* Look for an entry in the array whose value has the same SV as val;
13416 * If so, return the index, otherwise return -1. */
13419 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
13423 PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
13425 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
13426 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
13429 if (val != &PL_sv_undef) {
13430 SV ** const svp = AvARRAY(av);
13433 for (i=AvFILLp(av); i>=0; i--)
13440 /* S_varname(): return the name of a variable, optionally with a subscript.
13441 * If gv is non-zero, use the name of that global, along with gvtype (one
13442 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
13443 * targ. Depending on the value of the subscript_type flag, return:
13446 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
13447 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
13448 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
13449 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
13452 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
13453 const SV *const keyname, I32 aindex, int subscript_type)
13456 SV * const name = sv_newmortal();
13459 buffer[0] = gvtype;
13462 /* as gv_fullname4(), but add literal '^' for $^FOO names */
13464 gv_fullname4(name, gv, buffer, 0);
13466 if ((unsigned int)SvPVX(name)[1] <= 26) {
13468 buffer[1] = SvPVX(name)[1] + 'A' - 1;
13470 /* Swap the 1 unprintable control character for the 2 byte pretty
13471 version - ie substr($name, 1, 1) = $buffer; */
13472 sv_insert(name, 1, 1, buffer, 2);
13476 CV * const cv = find_runcv(NULL);
13480 if (!cv || !CvPADLIST(cv))
13482 av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
13483 sv = *av_fetch(av, targ, FALSE);
13484 sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
13487 if (subscript_type == FUV_SUBSCRIPT_HASH) {
13488 SV * const sv = newSV(0);
13489 *SvPVX(name) = '$';
13490 Perl_sv_catpvf(aTHX_ name, "{%s}",
13491 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
13494 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
13495 *SvPVX(name) = '$';
13496 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
13498 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
13499 /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
13500 Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
13508 =for apidoc find_uninit_var
13510 Find the name of the undefined variable (if any) that caused the operator o
13511 to issue a "Use of uninitialized value" warning.
13512 If match is true, only return a name if it's value matches uninit_sv.
13513 So roughly speaking, if a unary operator (such as OP_COS) generates a
13514 warning, then following the direct child of the op may yield an
13515 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
13516 other hand, with OP_ADD there are two branches to follow, so we only print
13517 the variable name if we get an exact match.
13519 The name is returned as a mortal SV.
13521 Assumes that PL_op is the op that originally triggered the error, and that
13522 PL_comppad/PL_curpad points to the currently executing pad.
13528 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
13534 const OP *o, *o2, *kid;
13536 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
13537 uninit_sv == &PL_sv_placeholder)))
13540 switch (obase->op_type) {
13547 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
13548 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
13551 int subscript_type = FUV_SUBSCRIPT_WITHIN;
13553 if (pad) { /* @lex, %lex */
13554 sv = PAD_SVl(obase->op_targ);
13558 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
13559 /* @global, %global */
13560 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
13563 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
13565 else /* @{expr}, %{expr} */
13566 return find_uninit_var(cUNOPx(obase)->op_first,
13570 /* attempt to find a match within the aggregate */
13572 keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13574 subscript_type = FUV_SUBSCRIPT_HASH;
13577 index = find_array_subscript((const AV *)sv, uninit_sv);
13579 subscript_type = FUV_SUBSCRIPT_ARRAY;
13582 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
13585 return varname(gv, hash ? '%' : '@', obase->op_targ,
13586 keysv, index, subscript_type);
13590 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
13592 return varname(NULL, '$', obase->op_targ,
13593 NULL, 0, FUV_SUBSCRIPT_NONE);
13596 gv = cGVOPx_gv(obase);
13597 if (!gv || (match && GvSV(gv) != uninit_sv))
13599 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
13602 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
13605 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
13606 if (!av || SvRMAGICAL(av))
13608 svp = av_fetch(av, (I32)obase->op_private, FALSE);
13609 if (!svp || *svp != uninit_sv)
13612 return varname(NULL, '$', obase->op_targ,
13613 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
13616 gv = cGVOPx_gv(obase);
13621 AV *const av = GvAV(gv);
13622 if (!av || SvRMAGICAL(av))
13624 svp = av_fetch(av, (I32)obase->op_private, FALSE);
13625 if (!svp || *svp != uninit_sv)
13628 return varname(gv, '$', 0,
13629 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
13634 o = cUNOPx(obase)->op_first;
13635 if (!o || o->op_type != OP_NULL ||
13636 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
13638 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
13642 if (PL_op == obase)
13643 /* $a[uninit_expr] or $h{uninit_expr} */
13644 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
13647 o = cBINOPx(obase)->op_first;
13648 kid = cBINOPx(obase)->op_last;
13650 /* get the av or hv, and optionally the gv */
13652 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
13653 sv = PAD_SV(o->op_targ);
13655 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
13656 && cUNOPo->op_first->op_type == OP_GV)
13658 gv = cGVOPx_gv(cUNOPo->op_first);
13662 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
13667 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
13668 /* index is constant */
13672 if (obase->op_type == OP_HELEM) {
13673 HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
13674 if (!he || HeVAL(he) != uninit_sv)
13678 SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
13679 if (!svp || *svp != uninit_sv)
13683 if (obase->op_type == OP_HELEM)
13684 return varname(gv, '%', o->op_targ,
13685 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
13687 return varname(gv, '@', o->op_targ, NULL,
13688 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
13691 /* index is an expression;
13692 * attempt to find a match within the aggregate */
13693 if (obase->op_type == OP_HELEM) {
13694 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13696 return varname(gv, '%', o->op_targ,
13697 keysv, 0, FUV_SUBSCRIPT_HASH);
13701 = find_array_subscript((const AV *)sv, uninit_sv);
13703 return varname(gv, '@', o->op_targ,
13704 NULL, index, FUV_SUBSCRIPT_ARRAY);
13709 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
13711 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
13716 /* only examine RHS */
13717 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
13720 o = cUNOPx(obase)->op_first;
13721 if (o->op_type == OP_PUSHMARK)
13724 if (!o->op_sibling) {
13725 /* one-arg version of open is highly magical */
13727 if (o->op_type == OP_GV) { /* open FOO; */
13729 if (match && GvSV(gv) != uninit_sv)
13731 return varname(gv, '$', 0,
13732 NULL, 0, FUV_SUBSCRIPT_NONE);
13734 /* other possibilities not handled are:
13735 * open $x; or open my $x; should return '${*$x}'
13736 * open expr; should return '$'.expr ideally
13742 /* ops where $_ may be an implicit arg */
13746 if ( !(obase->op_flags & OPf_STACKED)) {
13747 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
13748 ? PAD_SVl(obase->op_targ)
13751 sv = sv_newmortal();
13752 sv_setpvs(sv, "$_");
13761 match = 1; /* print etc can return undef on defined args */
13762 /* skip filehandle as it can't produce 'undef' warning */
13763 o = cUNOPx(obase)->op_first;
13764 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
13765 o = o->op_sibling->op_sibling;
13769 case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
13771 case OP_CUSTOM: /* XS or custom code could trigger random warnings */
13773 /* the following ops are capable of returning PL_sv_undef even for
13774 * defined arg(s) */
13793 case OP_GETPEERNAME:
13841 case OP_SMARTMATCH:
13850 /* XXX tmp hack: these two may call an XS sub, and currently
13851 XS subs don't have a SUB entry on the context stack, so CV and
13852 pad determination goes wrong, and BAD things happen. So, just
13853 don't try to determine the value under those circumstances.
13854 Need a better fix at dome point. DAPM 11/2007 */
13860 GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
13861 if (gv && GvSV(gv) == uninit_sv)
13862 return newSVpvs_flags("$.", SVs_TEMP);
13867 /* def-ness of rval pos() is independent of the def-ness of its arg */
13868 if ( !(obase->op_flags & OPf_MOD))
13873 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
13874 return newSVpvs_flags("${$/}", SVs_TEMP);
13879 if (!(obase->op_flags & OPf_KIDS))
13881 o = cUNOPx(obase)->op_first;
13887 /* if all except one arg are constant, or have no side-effects,
13888 * or are optimized away, then it's unambiguous */
13890 for (kid=o; kid; kid = kid->op_sibling) {
13892 const OPCODE type = kid->op_type;
13893 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
13894 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
13895 || (type == OP_PUSHMARK)
13899 if (o2) { /* more than one found */
13906 return find_uninit_var(o2, uninit_sv, match);
13908 /* scan all args */
13910 sv = find_uninit_var(o, uninit_sv, 1);
13922 =for apidoc report_uninit
13924 Print appropriate "Use of uninitialized variable" warning
13930 Perl_report_uninit(pTHX_ const SV *uninit_sv)
13934 SV* varname = NULL;
13936 varname = find_uninit_var(PL_op, uninit_sv,0);
13938 sv_insert(varname, 0, 0, " ", 1);
13940 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13941 varname ? SvPV_nolen_const(varname) : "",
13942 " in ", OP_DESC(PL_op));
13945 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
13951 * c-indentation-style: bsd
13952 * c-basic-offset: 4
13953 * indent-tabs-mode: t
13956 * ex: set ts=8 sts=4 sw=4 noet: