3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'I wonder what the Entish is for "yes" and "no",' he thought.
16 * [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
22 * This file contains the code that creates, manipulates and destroys
23 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
24 * structure of an SV, so their creation and destruction is handled
25 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
26 * level functions (eg. substr, split, join) for each of the types are
38 /* Missing proto on LynxOS */
39 char *gconvert(double, int, int, char *);
42 #ifdef PERL_UTF8_CACHE_ASSERT
43 /* if adding more checks watch out for the following tests:
44 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
45 * lib/utf8.t lib/Unicode/Collate/t/index.t
48 # define ASSERT_UTF8_CACHE(cache) \
49 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
50 assert((cache)[2] <= (cache)[3]); \
51 assert((cache)[3] <= (cache)[1]);} \
54 # define ASSERT_UTF8_CACHE(cache) NOOP
57 #ifdef PERL_OLD_COPY_ON_WRITE
58 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
59 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
60 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
64 /* ============================================================================
66 =head1 Allocation and deallocation of SVs.
68 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
69 sv, av, hv...) contains type and reference count information, and for
70 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
71 contains fields specific to each type. Some types store all they need
72 in the head, so don't have a body.
74 In all but the most memory-paranoid configuations (ex: PURIFY), heads
75 and bodies are allocated out of arenas, which by default are
76 approximately 4K chunks of memory parcelled up into N heads or bodies.
77 Sv-bodies are allocated by their sv-type, guaranteeing size
78 consistency needed to allocate safely from arrays.
80 For SV-heads, the first slot in each arena is reserved, and holds a
81 link to the next arena, some flags, and a note of the number of slots.
82 Snaked through each arena chain is a linked list of free items; when
83 this becomes empty, an extra arena is allocated and divided up into N
84 items which are threaded into the free list.
86 SV-bodies are similar, but they use arena-sets by default, which
87 separate the link and info from the arena itself, and reclaim the 1st
88 slot in the arena. SV-bodies are further described later.
90 The following global variables are associated with arenas:
92 PL_sv_arenaroot pointer to list of SV arenas
93 PL_sv_root pointer to list of free SV structures
95 PL_body_arenas head of linked-list of body arenas
96 PL_body_roots[] array of pointers to list of free bodies of svtype
97 arrays are indexed by the svtype needed
99 A few special SV heads are not allocated from an arena, but are
100 instead directly created in the interpreter structure, eg PL_sv_undef.
101 The size of arenas can be changed from the default by setting
102 PERL_ARENA_SIZE appropriately at compile time.
104 The SV arena serves the secondary purpose of allowing still-live SVs
105 to be located and destroyed during final cleanup.
107 At the lowest level, the macros new_SV() and del_SV() grab and free
108 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
109 to return the SV to the free list with error checking.) new_SV() calls
110 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
111 SVs in the free list have their SvTYPE field set to all ones.
113 At the time of very final cleanup, sv_free_arenas() is called from
114 perl_destruct() to physically free all the arenas allocated since the
115 start of the interpreter.
117 The function visit() scans the SV arenas list, and calls a specified
118 function for each SV it finds which is still live - ie which has an SvTYPE
119 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
120 following functions (specified as [function that calls visit()] / [function
121 called by visit() for each SV]):
123 sv_report_used() / do_report_used()
124 dump all remaining SVs (debugging aid)
126 sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
127 do_clean_named_io_objs()
128 Attempt to free all objects pointed to by RVs,
129 and try to do the same for all objects indirectly
130 referenced by typeglobs too. Called once from
131 perl_destruct(), prior to calling sv_clean_all()
134 sv_clean_all() / do_clean_all()
135 SvREFCNT_dec(sv) each remaining SV, possibly
136 triggering an sv_free(). It also sets the
137 SVf_BREAK flag on the SV to indicate that the
138 refcnt has been artificially lowered, and thus
139 stopping sv_free() from giving spurious warnings
140 about SVs which unexpectedly have a refcnt
141 of zero. called repeatedly from perl_destruct()
142 until there are no SVs left.
144 =head2 Arena allocator API Summary
146 Private API to rest of sv.c
150 new_XPVNV(), del_XPVGV(),
155 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
159 * ========================================================================= */
162 * "A time to plant, and a time to uproot what was planted..."
166 # define MEM_LOG_NEW_SV(sv, file, line, func) \
167 Perl_mem_log_new_sv(sv, file, line, func)
168 # define MEM_LOG_DEL_SV(sv, file, line, func) \
169 Perl_mem_log_del_sv(sv, file, line, func)
171 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
172 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
175 #ifdef DEBUG_LEAKING_SCALARS
176 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
177 # define DEBUG_SV_SERIAL(sv) \
178 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
179 PTR2UV(sv), (long)(sv)->sv_debug_serial))
181 # define FREE_SV_DEBUG_FILE(sv)
182 # define DEBUG_SV_SERIAL(sv) NOOP
186 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
187 # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
188 /* Whilst I'd love to do this, it seems that things like to check on
190 # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
192 # define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
193 PoisonNew(&SvREFCNT(sv), 1, U32)
195 # define SvARENA_CHAIN(sv) SvANY(sv)
196 # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
197 # define POSION_SV_HEAD(sv)
200 /* Mark an SV head as unused, and add to free list.
202 * If SVf_BREAK is set, skip adding it to the free list, as this SV had
203 * its refcount artificially decremented during global destruction, so
204 * there may be dangling pointers to it. The last thing we want in that
205 * case is for it to be reused. */
207 #define plant_SV(p) \
209 const U32 old_flags = SvFLAGS(p); \
210 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
211 DEBUG_SV_SERIAL(p); \
212 FREE_SV_DEBUG_FILE(p); \
214 SvFLAGS(p) = SVTYPEMASK; \
215 if (!(old_flags & SVf_BREAK)) { \
216 SvARENA_CHAIN_SET(p, PL_sv_root); \
222 #define uproot_SV(p) \
225 PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
230 /* make some more SVs by adding another arena */
237 char *chunk; /* must use New here to match call to */
238 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
239 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
244 /* new_SV(): return a new, empty SV head */
246 #ifdef DEBUG_LEAKING_SCALARS
247 /* provide a real function for a debugger to play with */
249 S_new_SV(pTHX_ const char *file, int line, const char *func)
256 sv = S_more_sv(aTHX);
260 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
261 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
267 sv->sv_debug_inpad = 0;
268 sv->sv_debug_parent = NULL;
269 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
271 sv->sv_debug_serial = PL_sv_serial++;
273 MEM_LOG_NEW_SV(sv, file, line, func);
274 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
275 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
279 # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
287 (p) = S_more_sv(aTHX); \
291 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
296 /* del_SV(): return an empty SV head to the free list */
309 S_del_sv(pTHX_ SV *p)
313 PERL_ARGS_ASSERT_DEL_SV;
318 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
319 const SV * const sv = sva + 1;
320 const SV * const svend = &sva[SvREFCNT(sva)];
321 if (p >= sv && p < svend) {
327 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
328 "Attempt to free non-arena SV: 0x%"UVxf
329 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
336 #else /* ! DEBUGGING */
338 #define del_SV(p) plant_SV(p)
340 #endif /* DEBUGGING */
344 =head1 SV Manipulation Functions
346 =for apidoc sv_add_arena
348 Given a chunk of memory, link it to the head of the list of arenas,
349 and split it into a list of free SVs.
355 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
358 SV *const sva = MUTABLE_SV(ptr);
362 PERL_ARGS_ASSERT_SV_ADD_ARENA;
364 /* The first SV in an arena isn't an SV. */
365 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
366 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
367 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
369 PL_sv_arenaroot = sva;
370 PL_sv_root = sva + 1;
372 svend = &sva[SvREFCNT(sva) - 1];
375 SvARENA_CHAIN_SET(sv, (sv + 1));
379 /* Must always set typemask because it's always checked in on cleanup
380 when the arenas are walked looking for objects. */
381 SvFLAGS(sv) = SVTYPEMASK;
384 SvARENA_CHAIN_SET(sv, 0);
388 SvFLAGS(sv) = SVTYPEMASK;
391 /* visit(): call the named function for each non-free SV in the arenas
392 * whose flags field matches the flags/mask args. */
395 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
401 PERL_ARGS_ASSERT_VISIT;
403 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
404 register const SV * const svend = &sva[SvREFCNT(sva)];
406 for (sv = sva + 1; sv < svend; ++sv) {
407 if (SvTYPE(sv) != SVTYPEMASK
408 && (sv->sv_flags & mask) == flags
421 /* called by sv_report_used() for each live SV */
424 do_report_used(pTHX_ SV *const sv)
426 if (SvTYPE(sv) != SVTYPEMASK) {
427 PerlIO_printf(Perl_debug_log, "****\n");
434 =for apidoc sv_report_used
436 Dump the contents of all SVs not yet freed. (Debugging aid).
442 Perl_sv_report_used(pTHX)
445 visit(do_report_used, 0, 0);
451 /* called by sv_clean_objs() for each live SV */
454 do_clean_objs(pTHX_ SV *const ref)
459 SV * const target = SvRV(ref);
460 if (SvOBJECT(target)) {
461 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
462 if (SvWEAKREF(ref)) {
463 sv_del_backref(target, ref);
469 SvREFCNT_dec(target);
474 /* XXX Might want to check arrays, etc. */
478 /* clear any slots in a GV which hold objects - except IO;
479 * called by sv_clean_objs() for each live GV */
482 do_clean_named_objs(pTHX_ SV *const sv)
486 assert(SvTYPE(sv) == SVt_PVGV);
487 assert(isGV_with_GP(sv));
491 /* freeing GP entries may indirectly free the current GV;
492 * hold onto it while we mess with the GP slots */
495 if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
496 DEBUG_D((PerlIO_printf(Perl_debug_log,
497 "Cleaning named glob SV object:\n "), sv_dump(obj)));
501 if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
502 DEBUG_D((PerlIO_printf(Perl_debug_log,
503 "Cleaning named glob AV object:\n "), sv_dump(obj)));
507 if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
508 DEBUG_D((PerlIO_printf(Perl_debug_log,
509 "Cleaning named glob HV object:\n "), sv_dump(obj)));
513 if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
514 DEBUG_D((PerlIO_printf(Perl_debug_log,
515 "Cleaning named glob CV object:\n "), sv_dump(obj)));
519 SvREFCNT_dec(sv); /* undo the inc above */
522 /* clear any IO slots in a GV which hold objects (except stderr, defout);
523 * called by sv_clean_objs() for each live GV */
526 do_clean_named_io_objs(pTHX_ SV *const sv)
530 assert(SvTYPE(sv) == SVt_PVGV);
531 assert(isGV_with_GP(sv));
532 if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
536 if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
537 DEBUG_D((PerlIO_printf(Perl_debug_log,
538 "Cleaning named glob IO object:\n "), sv_dump(obj)));
542 SvREFCNT_dec(sv); /* undo the inc above */
546 =for apidoc sv_clean_objs
548 Attempt to destroy all objects not yet freed
554 Perl_sv_clean_objs(pTHX)
558 PL_in_clean_objs = TRUE;
559 visit(do_clean_objs, SVf_ROK, SVf_ROK);
560 /* Some barnacles may yet remain, clinging to typeglobs.
561 * Run the non-IO destructors first: they may want to output
562 * error messages, close files etc */
563 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
564 visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
565 olddef = PL_defoutgv;
566 PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
567 if (olddef && isGV_with_GP(olddef))
568 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
569 olderr = PL_stderrgv;
570 PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
571 if (olderr && isGV_with_GP(olderr))
572 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
573 SvREFCNT_dec(olddef);
574 PL_in_clean_objs = FALSE;
577 /* called by sv_clean_all() for each live SV */
580 do_clean_all(pTHX_ SV *const sv)
583 if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
584 /* don't clean pid table and strtab */
587 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
588 SvFLAGS(sv) |= SVf_BREAK;
593 =for apidoc sv_clean_all
595 Decrement the refcnt of each remaining SV, possibly triggering a
596 cleanup. This function may have to be called multiple times to free
597 SVs which are in complex self-referential hierarchies.
603 Perl_sv_clean_all(pTHX)
607 PL_in_clean_all = TRUE;
608 cleaned = visit(do_clean_all, 0,0);
613 ARENASETS: a meta-arena implementation which separates arena-info
614 into struct arena_set, which contains an array of struct
615 arena_descs, each holding info for a single arena. By separating
616 the meta-info from the arena, we recover the 1st slot, formerly
617 borrowed for list management. The arena_set is about the size of an
618 arena, avoiding the needless malloc overhead of a naive linked-list.
620 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
621 memory in the last arena-set (1/2 on average). In trade, we get
622 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
623 smaller types). The recovery of the wasted space allows use of
624 small arenas for large, rare body types, by changing array* fields
625 in body_details_by_type[] below.
628 char *arena; /* the raw storage, allocated aligned */
629 size_t size; /* its size ~4k typ */
630 svtype utype; /* bodytype stored in arena */
635 /* Get the maximum number of elements in set[] such that struct arena_set
636 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
637 therefore likely to be 1 aligned memory page. */
639 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
640 - 2 * sizeof(int)) / sizeof (struct arena_desc))
643 struct arena_set* next;
644 unsigned int set_size; /* ie ARENAS_PER_SET */
645 unsigned int curr; /* index of next available arena-desc */
646 struct arena_desc set[ARENAS_PER_SET];
650 =for apidoc sv_free_arenas
652 Deallocate the memory used by all arenas. Note that all the individual SV
653 heads and bodies within the arenas must already have been freed.
658 Perl_sv_free_arenas(pTHX)
665 /* Free arenas here, but be careful about fake ones. (We assume
666 contiguity of the fake ones with the corresponding real ones.) */
668 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
669 svanext = MUTABLE_SV(SvANY(sva));
670 while (svanext && SvFAKE(svanext))
671 svanext = MUTABLE_SV(SvANY(svanext));
678 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
681 struct arena_set *current = aroot;
684 assert(aroot->set[i].arena);
685 Safefree(aroot->set[i].arena);
693 i = PERL_ARENA_ROOTS_SIZE;
695 PL_body_roots[i] = 0;
702 Here are mid-level routines that manage the allocation of bodies out
703 of the various arenas. There are 5 kinds of arenas:
705 1. SV-head arenas, which are discussed and handled above
706 2. regular body arenas
707 3. arenas for reduced-size bodies
710 Arena types 2 & 3 are chained by body-type off an array of
711 arena-root pointers, which is indexed by svtype. Some of the
712 larger/less used body types are malloced singly, since a large
713 unused block of them is wasteful. Also, several svtypes dont have
714 bodies; the data fits into the sv-head itself. The arena-root
715 pointer thus has a few unused root-pointers (which may be hijacked
716 later for arena types 4,5)
718 3 differs from 2 as an optimization; some body types have several
719 unused fields in the front of the structure (which are kept in-place
720 for consistency). These bodies can be allocated in smaller chunks,
721 because the leading fields arent accessed. Pointers to such bodies
722 are decremented to point at the unused 'ghost' memory, knowing that
723 the pointers are used with offsets to the real memory.
726 =head1 SV-Body Allocation
728 Allocation of SV-bodies is similar to SV-heads, differing as follows;
729 the allocation mechanism is used for many body types, so is somewhat
730 more complicated, it uses arena-sets, and has no need for still-live
733 At the outermost level, (new|del)_X*V macros return bodies of the
734 appropriate type. These macros call either (new|del)_body_type or
735 (new|del)_body_allocated macro pairs, depending on specifics of the
736 type. Most body types use the former pair, the latter pair is used to
737 allocate body types with "ghost fields".
739 "ghost fields" are fields that are unused in certain types, and
740 consequently don't need to actually exist. They are declared because
741 they're part of a "base type", which allows use of functions as
742 methods. The simplest examples are AVs and HVs, 2 aggregate types
743 which don't use the fields which support SCALAR semantics.
745 For these types, the arenas are carved up into appropriately sized
746 chunks, we thus avoid wasted memory for those unaccessed members.
747 When bodies are allocated, we adjust the pointer back in memory by the
748 size of the part not allocated, so it's as if we allocated the full
749 structure. (But things will all go boom if you write to the part that
750 is "not there", because you'll be overwriting the last members of the
751 preceding structure in memory.)
753 We calculate the correction using the STRUCT_OFFSET macro on the first
754 member present. If the allocated structure is smaller (no initial NV
755 actually allocated) then the net effect is to subtract the size of the NV
756 from the pointer, to return a new pointer as if an initial NV were actually
757 allocated. (We were using structures named *_allocated for this, but
758 this turned out to be a subtle bug, because a structure without an NV
759 could have a lower alignment constraint, but the compiler is allowed to
760 optimised accesses based on the alignment constraint of the actual pointer
761 to the full structure, for example, using a single 64 bit load instruction
762 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
764 This is the same trick as was used for NV and IV bodies. Ironically it
765 doesn't need to be used for NV bodies any more, because NV is now at
766 the start of the structure. IV bodies don't need it either, because
767 they are no longer allocated.
769 In turn, the new_body_* allocators call S_new_body(), which invokes
770 new_body_inline macro, which takes a lock, and takes a body off the
771 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
772 necessary to refresh an empty list. Then the lock is released, and
773 the body is returned.
775 Perl_more_bodies allocates a new arena, and carves it up into an array of N
776 bodies, which it strings into a linked list. It looks up arena-size
777 and body-size from the body_details table described below, thus
778 supporting the multiple body-types.
780 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
781 the (new|del)_X*V macros are mapped directly to malloc/free.
783 For each sv-type, struct body_details bodies_by_type[] carries
784 parameters which control these aspects of SV handling:
786 Arena_size determines whether arenas are used for this body type, and if
787 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
788 zero, forcing individual mallocs and frees.
790 Body_size determines how big a body is, and therefore how many fit into
791 each arena. Offset carries the body-pointer adjustment needed for
792 "ghost fields", and is used in *_allocated macros.
794 But its main purpose is to parameterize info needed in
795 Perl_sv_upgrade(). The info here dramatically simplifies the function
796 vs the implementation in 5.8.8, making it table-driven. All fields
797 are used for this, except for arena_size.
799 For the sv-types that have no bodies, arenas are not used, so those
800 PL_body_roots[sv_type] are unused, and can be overloaded. In
801 something of a special case, SVt_NULL is borrowed for HE arenas;
802 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
803 bodies_by_type[SVt_NULL] slot is not used, as the table is not
808 struct body_details {
809 U8 body_size; /* Size to allocate */
810 U8 copy; /* Size of structure to copy (may be shorter) */
812 unsigned int type : 4; /* We have space for a sanity check. */
813 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
814 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
815 unsigned int arena : 1; /* Allocated from an arena */
816 size_t arena_size; /* Size of arena to allocate */
824 /* With -DPURFIY we allocate everything directly, and don't use arenas.
825 This seems a rather elegant way to simplify some of the code below. */
826 #define HASARENA FALSE
828 #define HASARENA TRUE
830 #define NOARENA FALSE
832 /* Size the arenas to exactly fit a given number of bodies. A count
833 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
834 simplifying the default. If count > 0, the arena is sized to fit
835 only that many bodies, allowing arenas to be used for large, rare
836 bodies (XPVFM, XPVIO) without undue waste. The arena size is
837 limited by PERL_ARENA_SIZE, so we can safely oversize the
840 #define FIT_ARENA0(body_size) \
841 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
842 #define FIT_ARENAn(count,body_size) \
843 ( count * body_size <= PERL_ARENA_SIZE) \
844 ? count * body_size \
845 : FIT_ARENA0 (body_size)
846 #define FIT_ARENA(count,body_size) \
848 ? FIT_ARENAn (count, body_size) \
849 : FIT_ARENA0 (body_size)
851 /* Calculate the length to copy. Specifically work out the length less any
852 final padding the compiler needed to add. See the comment in sv_upgrade
853 for why copying the padding proved to be a bug. */
855 #define copy_length(type, last_member) \
856 STRUCT_OFFSET(type, last_member) \
857 + sizeof (((type*)SvANY((const SV *)0))->last_member)
859 static const struct body_details bodies_by_type[] = {
860 /* HEs use this offset for their arena. */
861 { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
863 /* The bind placeholder pretends to be an RV for now.
864 Also it's marked as "can't upgrade" to stop anyone using it before it's
866 { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
868 /* IVs are in the head, so the allocation size is 0. */
870 sizeof(IV), /* This is used to copy out the IV body. */
871 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
872 NOARENA /* IVS don't need an arena */, 0
875 /* 8 bytes on most ILP32 with IEEE doubles */
876 { sizeof(NV), sizeof(NV),
877 STRUCT_OFFSET(XPVNV, xnv_u),
878 SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
880 /* 8 bytes on most ILP32 with IEEE doubles */
881 { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
882 copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
883 + STRUCT_OFFSET(XPV, xpv_cur),
884 SVt_PV, FALSE, NONV, HASARENA,
885 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
888 { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
889 copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
890 + STRUCT_OFFSET(XPV, xpv_cur),
891 SVt_PVIV, FALSE, NONV, HASARENA,
892 FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
895 { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
896 copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
897 + STRUCT_OFFSET(XPV, xpv_cur),
898 SVt_PVNV, FALSE, HADNV, HASARENA,
899 FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
902 { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
903 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
909 SVt_REGEXP, FALSE, NONV, HASARENA,
910 FIT_ARENA(0, sizeof(regexp))
914 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
915 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
918 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
919 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
922 copy_length(XPVAV, xav_alloc),
924 SVt_PVAV, TRUE, NONV, HASARENA,
925 FIT_ARENA(0, sizeof(XPVAV)) },
928 copy_length(XPVHV, xhv_max),
930 SVt_PVHV, TRUE, NONV, HASARENA,
931 FIT_ARENA(0, sizeof(XPVHV)) },
937 SVt_PVCV, TRUE, NONV, HASARENA,
938 FIT_ARENA(0, sizeof(XPVCV)) },
943 SVt_PVFM, TRUE, NONV, NOARENA,
944 FIT_ARENA(20, sizeof(XPVFM)) },
946 /* XPVIO is 84 bytes, fits 48x */
950 SVt_PVIO, TRUE, NONV, HASARENA,
951 FIT_ARENA(24, sizeof(XPVIO)) },
954 #define new_body_allocated(sv_type) \
955 (void *)((char *)S_new_body(aTHX_ sv_type) \
956 - bodies_by_type[sv_type].offset)
958 /* return a thing to the free list */
960 #define del_body(thing, root) \
962 void ** const thing_copy = (void **)thing; \
963 *thing_copy = *root; \
964 *root = (void*)thing_copy; \
969 #define new_XNV() safemalloc(sizeof(XPVNV))
970 #define new_XPVNV() safemalloc(sizeof(XPVNV))
971 #define new_XPVMG() safemalloc(sizeof(XPVMG))
973 #define del_XPVGV(p) safefree(p)
977 #define new_XNV() new_body_allocated(SVt_NV)
978 #define new_XPVNV() new_body_allocated(SVt_PVNV)
979 #define new_XPVMG() new_body_allocated(SVt_PVMG)
981 #define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \
982 &PL_body_roots[SVt_PVGV])
986 /* no arena for you! */
988 #define new_NOARENA(details) \
989 safemalloc((details)->body_size + (details)->offset)
990 #define new_NOARENAZ(details) \
991 safecalloc((details)->body_size + (details)->offset, 1)
994 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
995 const size_t arena_size)
998 void ** const root = &PL_body_roots[sv_type];
999 struct arena_desc *adesc;
1000 struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1004 const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1005 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1006 static bool done_sanity_check;
1008 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1009 * variables like done_sanity_check. */
1010 if (!done_sanity_check) {
1011 unsigned int i = SVt_LAST;
1013 done_sanity_check = TRUE;
1016 assert (bodies_by_type[i].type == i);
1022 /* may need new arena-set to hold new arena */
1023 if (!aroot || aroot->curr >= aroot->set_size) {
1024 struct arena_set *newroot;
1025 Newxz(newroot, 1, struct arena_set);
1026 newroot->set_size = ARENAS_PER_SET;
1027 newroot->next = aroot;
1029 PL_body_arenas = (void *) newroot;
1030 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1033 /* ok, now have arena-set with at least 1 empty/available arena-desc */
1034 curr = aroot->curr++;
1035 adesc = &(aroot->set[curr]);
1036 assert(!adesc->arena);
1038 Newx(adesc->arena, good_arena_size, char);
1039 adesc->size = good_arena_size;
1040 adesc->utype = sv_type;
1041 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
1042 curr, (void*)adesc->arena, (UV)good_arena_size));
1044 start = (char *) adesc->arena;
1046 /* Get the address of the byte after the end of the last body we can fit.
1047 Remember, this is integer division: */
1048 end = start + good_arena_size / body_size * body_size;
1050 /* computed count doesnt reflect the 1st slot reservation */
1051 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1052 DEBUG_m(PerlIO_printf(Perl_debug_log,
1053 "arena %p end %p arena-size %d (from %d) type %d "
1055 (void*)start, (void*)end, (int)good_arena_size,
1056 (int)arena_size, sv_type, (int)body_size,
1057 (int)good_arena_size / (int)body_size));
1059 DEBUG_m(PerlIO_printf(Perl_debug_log,
1060 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1061 (void*)start, (void*)end,
1062 (int)arena_size, sv_type, (int)body_size,
1063 (int)good_arena_size / (int)body_size));
1065 *root = (void *)start;
1068 /* Where the next body would start: */
1069 char * const next = start + body_size;
1072 /* This is the last body: */
1073 assert(next == end);
1075 *(void **)start = 0;
1079 *(void**) start = (void *)next;
1084 /* grab a new thing from the free list, allocating more if necessary.
1085 The inline version is used for speed in hot routines, and the
1086 function using it serves the rest (unless PURIFY).
1088 #define new_body_inline(xpv, sv_type) \
1090 void ** const r3wt = &PL_body_roots[sv_type]; \
1091 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1092 ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1093 bodies_by_type[sv_type].body_size,\
1094 bodies_by_type[sv_type].arena_size)); \
1095 *(r3wt) = *(void**)(xpv); \
1101 S_new_body(pTHX_ const svtype sv_type)
1105 new_body_inline(xpv, sv_type);
1111 static const struct body_details fake_rv =
1112 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1115 =for apidoc sv_upgrade
1117 Upgrade an SV to a more complex form. Generally adds a new body type to the
1118 SV, then copies across as much information as possible from the old body.
1119 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1125 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1130 const svtype old_type = SvTYPE(sv);
1131 const struct body_details *new_type_details;
1132 const struct body_details *old_type_details
1133 = bodies_by_type + old_type;
1134 SV *referant = NULL;
1136 PERL_ARGS_ASSERT_SV_UPGRADE;
1138 if (old_type == new_type)
1141 /* This clause was purposefully added ahead of the early return above to
1142 the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1143 inference by Nick I-S that it would fix other troublesome cases. See
1144 changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1146 Given that shared hash key scalars are no longer PVIV, but PV, there is
1147 no longer need to unshare so as to free up the IVX slot for its proper
1148 purpose. So it's safe to move the early return earlier. */
1150 if (new_type != SVt_PV && SvIsCOW(sv)) {
1151 sv_force_normal_flags(sv, 0);
1154 old_body = SvANY(sv);
1156 /* Copying structures onto other structures that have been neatly zeroed
1157 has a subtle gotcha. Consider XPVMG
1159 +------+------+------+------+------+-------+-------+
1160 | NV | CUR | LEN | IV | MAGIC | STASH |
1161 +------+------+------+------+------+-------+-------+
1162 0 4 8 12 16 20 24 28
1164 where NVs are aligned to 8 bytes, so that sizeof that structure is
1165 actually 32 bytes long, with 4 bytes of padding at the end:
1167 +------+------+------+------+------+-------+-------+------+
1168 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1169 +------+------+------+------+------+-------+-------+------+
1170 0 4 8 12 16 20 24 28 32
1172 so what happens if you allocate memory for this structure:
1174 +------+------+------+------+------+-------+-------+------+------+...
1175 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1176 +------+------+------+------+------+-------+-------+------+------+...
1177 0 4 8 12 16 20 24 28 32 36
1179 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1180 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1181 started out as zero once, but it's quite possible that it isn't. So now,
1182 rather than a nicely zeroed GP, you have it pointing somewhere random.
1185 (In fact, GP ends up pointing at a previous GP structure, because the
1186 principle cause of the padding in XPVMG getting garbage is a copy of
1187 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1188 this happens to be moot because XPVGV has been re-ordered, with GP
1189 no longer after STASH)
1191 So we are careful and work out the size of used parts of all the
1199 referant = SvRV(sv);
1200 old_type_details = &fake_rv;
1201 if (new_type == SVt_NV)
1202 new_type = SVt_PVNV;
1204 if (new_type < SVt_PVIV) {
1205 new_type = (new_type == SVt_NV)
1206 ? SVt_PVNV : SVt_PVIV;
1211 if (new_type < SVt_PVNV) {
1212 new_type = SVt_PVNV;
1216 assert(new_type > SVt_PV);
1217 assert(SVt_IV < SVt_PV);
1218 assert(SVt_NV < SVt_PV);
1225 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1226 there's no way that it can be safely upgraded, because perl.c
1227 expects to Safefree(SvANY(PL_mess_sv)) */
1228 assert(sv != PL_mess_sv);
1229 /* This flag bit is used to mean other things in other scalar types.
1230 Given that it only has meaning inside the pad, it shouldn't be set
1231 on anything that can get upgraded. */
1232 assert(!SvPAD_TYPED(sv));
1235 if (old_type_details->cant_upgrade)
1236 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1237 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1240 if (old_type > new_type)
1241 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1242 (int)old_type, (int)new_type);
1244 new_type_details = bodies_by_type + new_type;
1246 SvFLAGS(sv) &= ~SVTYPEMASK;
1247 SvFLAGS(sv) |= new_type;
1249 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1250 the return statements above will have triggered. */
1251 assert (new_type != SVt_NULL);
1254 assert(old_type == SVt_NULL);
1255 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1259 assert(old_type == SVt_NULL);
1260 SvANY(sv) = new_XNV();
1265 assert(new_type_details->body_size);
1268 assert(new_type_details->arena);
1269 assert(new_type_details->arena_size);
1270 /* This points to the start of the allocated area. */
1271 new_body_inline(new_body, new_type);
1272 Zero(new_body, new_type_details->body_size, char);
1273 new_body = ((char *)new_body) - new_type_details->offset;
1275 /* We always allocated the full length item with PURIFY. To do this
1276 we fake things so that arena is false for all 16 types.. */
1277 new_body = new_NOARENAZ(new_type_details);
1279 SvANY(sv) = new_body;
1280 if (new_type == SVt_PVAV) {
1284 if (old_type_details->body_size) {
1287 /* It will have been zeroed when the new body was allocated.
1288 Lets not write to it, in case it confuses a write-back
1294 #ifndef NODEFAULT_SHAREKEYS
1295 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1297 HvMAX(sv) = 7; /* (start with 8 buckets) */
1300 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1301 The target created by newSVrv also is, and it can have magic.
1302 However, it never has SvPVX set.
1304 if (old_type == SVt_IV) {
1306 } else if (old_type >= SVt_PV) {
1307 assert(SvPVX_const(sv) == 0);
1310 if (old_type >= SVt_PVMG) {
1311 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1312 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1314 sv->sv_u.svu_array = NULL; /* or svu_hash */
1320 /* This ensures that SvTHINKFIRST(sv) is true, and hence that
1321 sv_force_normal_flags(sv) is called. */
1324 /* XXX Is this still needed? Was it ever needed? Surely as there is
1325 no route from NV to PVIV, NOK can never be true */
1326 assert(!SvNOKp(sv));
1337 assert(new_type_details->body_size);
1338 /* We always allocated the full length item with PURIFY. To do this
1339 we fake things so that arena is false for all 16 types.. */
1340 if(new_type_details->arena) {
1341 /* This points to the start of the allocated area. */
1342 new_body_inline(new_body, new_type);
1343 Zero(new_body, new_type_details->body_size, char);
1344 new_body = ((char *)new_body) - new_type_details->offset;
1346 new_body = new_NOARENAZ(new_type_details);
1348 SvANY(sv) = new_body;
1350 if (old_type_details->copy) {
1351 /* There is now the potential for an upgrade from something without
1352 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1353 int offset = old_type_details->offset;
1354 int length = old_type_details->copy;
1356 if (new_type_details->offset > old_type_details->offset) {
1357 const int difference
1358 = new_type_details->offset - old_type_details->offset;
1359 offset += difference;
1360 length -= difference;
1362 assert (length >= 0);
1364 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1368 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1369 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1370 * correct 0.0 for us. Otherwise, if the old body didn't have an
1371 * NV slot, but the new one does, then we need to initialise the
1372 * freshly created NV slot with whatever the correct bit pattern is
1374 if (old_type_details->zero_nv && !new_type_details->zero_nv
1375 && !isGV_with_GP(sv))
1379 if (new_type == SVt_PVIO) {
1380 IO * const io = MUTABLE_IO(sv);
1381 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1384 /* Clear the stashcache because a new IO could overrule a package
1386 hv_clear(PL_stashcache);
1388 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1389 IoPAGE_LEN(sv) = 60;
1391 if (old_type < SVt_PV) {
1392 /* referant will be NULL unless the old type was SVt_IV emulating
1394 sv->sv_u.svu_rv = referant;
1398 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1399 (unsigned long)new_type);
1402 if (old_type > SVt_IV) {
1406 /* Note that there is an assumption that all bodies of types that
1407 can be upgraded came from arenas. Only the more complex non-
1408 upgradable types are allowed to be directly malloc()ed. */
1409 assert(old_type_details->arena);
1410 del_body((void*)((char*)old_body + old_type_details->offset),
1411 &PL_body_roots[old_type]);
1417 =for apidoc sv_backoff
1419 Remove any string offset. You should normally use the C<SvOOK_off> macro
1426 Perl_sv_backoff(pTHX_ register SV *const sv)
1429 const char * const s = SvPVX_const(sv);
1431 PERL_ARGS_ASSERT_SV_BACKOFF;
1432 PERL_UNUSED_CONTEXT;
1435 assert(SvTYPE(sv) != SVt_PVHV);
1436 assert(SvTYPE(sv) != SVt_PVAV);
1438 SvOOK_offset(sv, delta);
1440 SvLEN_set(sv, SvLEN(sv) + delta);
1441 SvPV_set(sv, SvPVX(sv) - delta);
1442 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1443 SvFLAGS(sv) &= ~SVf_OOK;
1450 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1451 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1452 Use the C<SvGROW> wrapper instead.
1458 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1462 PERL_ARGS_ASSERT_SV_GROW;
1464 if (PL_madskills && newlen >= 0x100000) {
1465 PerlIO_printf(Perl_debug_log,
1466 "Allocation too large: %"UVxf"\n", (UV)newlen);
1468 #ifdef HAS_64K_LIMIT
1469 if (newlen >= 0x10000) {
1470 PerlIO_printf(Perl_debug_log,
1471 "Allocation too large: %"UVxf"\n", (UV)newlen);
1474 #endif /* HAS_64K_LIMIT */
1477 if (SvTYPE(sv) < SVt_PV) {
1478 sv_upgrade(sv, SVt_PV);
1479 s = SvPVX_mutable(sv);
1481 else if (SvOOK(sv)) { /* pv is offset? */
1483 s = SvPVX_mutable(sv);
1484 if (newlen > SvLEN(sv))
1485 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1486 #ifdef HAS_64K_LIMIT
1487 if (newlen >= 0x10000)
1492 s = SvPVX_mutable(sv);
1494 if (newlen > SvLEN(sv)) { /* need more room? */
1495 STRLEN minlen = SvCUR(sv);
1496 minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1497 if (newlen < minlen)
1499 #ifndef Perl_safesysmalloc_size
1500 newlen = PERL_STRLEN_ROUNDUP(newlen);
1502 if (SvLEN(sv) && s) {
1503 s = (char*)saferealloc(s, newlen);
1506 s = (char*)safemalloc(newlen);
1507 if (SvPVX_const(sv) && SvCUR(sv)) {
1508 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1512 #ifdef Perl_safesysmalloc_size
1513 /* Do this here, do it once, do it right, and then we will never get
1514 called back into sv_grow() unless there really is some growing
1516 SvLEN_set(sv, Perl_safesysmalloc_size(s));
1518 SvLEN_set(sv, newlen);
1525 =for apidoc sv_setiv
1527 Copies an integer into the given SV, upgrading first if necessary.
1528 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1534 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1538 PERL_ARGS_ASSERT_SV_SETIV;
1540 SV_CHECK_THINKFIRST_COW_DROP(sv);
1541 switch (SvTYPE(sv)) {
1544 sv_upgrade(sv, SVt_IV);
1547 sv_upgrade(sv, SVt_PVIV);
1551 if (!isGV_with_GP(sv))
1558 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1562 (void)SvIOK_only(sv); /* validate number */
1568 =for apidoc sv_setiv_mg
1570 Like C<sv_setiv>, but also handles 'set' magic.
1576 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1578 PERL_ARGS_ASSERT_SV_SETIV_MG;
1585 =for apidoc sv_setuv
1587 Copies an unsigned integer into the given SV, upgrading first if necessary.
1588 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1594 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1596 PERL_ARGS_ASSERT_SV_SETUV;
1598 /* With these two if statements:
1599 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1602 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1604 If you wish to remove them, please benchmark to see what the effect is
1606 if (u <= (UV)IV_MAX) {
1607 sv_setiv(sv, (IV)u);
1616 =for apidoc sv_setuv_mg
1618 Like C<sv_setuv>, but also handles 'set' magic.
1624 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1626 PERL_ARGS_ASSERT_SV_SETUV_MG;
1633 =for apidoc sv_setnv
1635 Copies a double into the given SV, upgrading first if necessary.
1636 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1642 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1646 PERL_ARGS_ASSERT_SV_SETNV;
1648 SV_CHECK_THINKFIRST_COW_DROP(sv);
1649 switch (SvTYPE(sv)) {
1652 sv_upgrade(sv, SVt_NV);
1656 sv_upgrade(sv, SVt_PVNV);
1660 if (!isGV_with_GP(sv))
1667 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1672 (void)SvNOK_only(sv); /* validate number */
1677 =for apidoc sv_setnv_mg
1679 Like C<sv_setnv>, but also handles 'set' magic.
1685 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1687 PERL_ARGS_ASSERT_SV_SETNV_MG;
1693 /* Print an "isn't numeric" warning, using a cleaned-up,
1694 * printable version of the offending string
1698 S_not_a_number(pTHX_ SV *const sv)
1705 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1708 dsv = newSVpvs_flags("", SVs_TEMP);
1709 pv = sv_uni_display(dsv, sv, 10, 0);
1712 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1713 /* each *s can expand to 4 chars + "...\0",
1714 i.e. need room for 8 chars */
1716 const char *s = SvPVX_const(sv);
1717 const char * const end = s + SvCUR(sv);
1718 for ( ; s < end && d < limit; s++ ) {
1720 if (ch & 128 && !isPRINT_LC(ch)) {
1729 else if (ch == '\r') {
1733 else if (ch == '\f') {
1737 else if (ch == '\\') {
1741 else if (ch == '\0') {
1745 else if (isPRINT_LC(ch))
1762 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1763 "Argument \"%s\" isn't numeric in %s", pv,
1766 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1767 "Argument \"%s\" isn't numeric", pv);
1771 =for apidoc looks_like_number
1773 Test if the content of an SV looks like a number (or is a number).
1774 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1775 non-numeric warning), even if your atof() doesn't grok them.
1781 Perl_looks_like_number(pTHX_ SV *const sv)
1783 register const char *sbegin;
1786 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1789 sbegin = SvPVX_const(sv);
1792 else if (SvPOKp(sv))
1793 sbegin = SvPV_const(sv, len);
1795 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1796 return grok_number(sbegin, len, NULL);
1800 S_glob_2number(pTHX_ GV * const gv)
1802 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1803 SV *const buffer = sv_newmortal();
1805 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1807 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1810 gv_efullname3(buffer, gv, "*");
1811 SvFLAGS(gv) |= wasfake;
1813 /* We know that all GVs stringify to something that is not-a-number,
1814 so no need to test that. */
1815 if (ckWARN(WARN_NUMERIC))
1816 not_a_number(buffer);
1817 /* We just want something true to return, so that S_sv_2iuv_common
1818 can tail call us and return true. */
1822 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1823 until proven guilty, assume that things are not that bad... */
1828 As 64 bit platforms often have an NV that doesn't preserve all bits of
1829 an IV (an assumption perl has been based on to date) it becomes necessary
1830 to remove the assumption that the NV always carries enough precision to
1831 recreate the IV whenever needed, and that the NV is the canonical form.
1832 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1833 precision as a side effect of conversion (which would lead to insanity
1834 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1835 1) to distinguish between IV/UV/NV slots that have cached a valid
1836 conversion where precision was lost and IV/UV/NV slots that have a
1837 valid conversion which has lost no precision
1838 2) to ensure that if a numeric conversion to one form is requested that
1839 would lose precision, the precise conversion (or differently
1840 imprecise conversion) is also performed and cached, to prevent
1841 requests for different numeric formats on the same SV causing
1842 lossy conversion chains. (lossless conversion chains are perfectly
1847 SvIOKp is true if the IV slot contains a valid value
1848 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1849 SvNOKp is true if the NV slot contains a valid value
1850 SvNOK is true only if the NV value is accurate
1853 while converting from PV to NV, check to see if converting that NV to an
1854 IV(or UV) would lose accuracy over a direct conversion from PV to
1855 IV(or UV). If it would, cache both conversions, return NV, but mark
1856 SV as IOK NOKp (ie not NOK).
1858 While converting from PV to IV, check to see if converting that IV to an
1859 NV would lose accuracy over a direct conversion from PV to NV. If it
1860 would, cache both conversions, flag similarly.
1862 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1863 correctly because if IV & NV were set NV *always* overruled.
1864 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1865 changes - now IV and NV together means that the two are interchangeable:
1866 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1868 The benefit of this is that operations such as pp_add know that if
1869 SvIOK is true for both left and right operands, then integer addition
1870 can be used instead of floating point (for cases where the result won't
1871 overflow). Before, floating point was always used, which could lead to
1872 loss of precision compared with integer addition.
1874 * making IV and NV equal status should make maths accurate on 64 bit
1876 * may speed up maths somewhat if pp_add and friends start to use
1877 integers when possible instead of fp. (Hopefully the overhead in
1878 looking for SvIOK and checking for overflow will not outweigh the
1879 fp to integer speedup)
1880 * will slow down integer operations (callers of SvIV) on "inaccurate"
1881 values, as the change from SvIOK to SvIOKp will cause a call into
1882 sv_2iv each time rather than a macro access direct to the IV slot
1883 * should speed up number->string conversion on integers as IV is
1884 favoured when IV and NV are equally accurate
1886 ####################################################################
1887 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1888 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1889 On the other hand, SvUOK is true iff UV.
1890 ####################################################################
1892 Your mileage will vary depending your CPU's relative fp to integer
1896 #ifndef NV_PRESERVES_UV
1897 # define IS_NUMBER_UNDERFLOW_IV 1
1898 # define IS_NUMBER_UNDERFLOW_UV 2
1899 # define IS_NUMBER_IV_AND_UV 2
1900 # define IS_NUMBER_OVERFLOW_IV 4
1901 # define IS_NUMBER_OVERFLOW_UV 5
1903 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1905 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1907 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1915 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1917 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
1918 if (SvNVX(sv) < (NV)IV_MIN) {
1919 (void)SvIOKp_on(sv);
1921 SvIV_set(sv, IV_MIN);
1922 return IS_NUMBER_UNDERFLOW_IV;
1924 if (SvNVX(sv) > (NV)UV_MAX) {
1925 (void)SvIOKp_on(sv);
1928 SvUV_set(sv, UV_MAX);
1929 return IS_NUMBER_OVERFLOW_UV;
1931 (void)SvIOKp_on(sv);
1933 /* Can't use strtol etc to convert this string. (See truth table in
1935 if (SvNVX(sv) <= (UV)IV_MAX) {
1936 SvIV_set(sv, I_V(SvNVX(sv)));
1937 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1938 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1940 /* Integer is imprecise. NOK, IOKp */
1942 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1945 SvUV_set(sv, U_V(SvNVX(sv)));
1946 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1947 if (SvUVX(sv) == UV_MAX) {
1948 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1949 possibly be preserved by NV. Hence, it must be overflow.
1951 return IS_NUMBER_OVERFLOW_UV;
1953 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1955 /* Integer is imprecise. NOK, IOKp */
1957 return IS_NUMBER_OVERFLOW_IV;
1959 #endif /* !NV_PRESERVES_UV*/
1962 S_sv_2iuv_common(pTHX_ SV *const sv)
1966 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
1969 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1970 * without also getting a cached IV/UV from it at the same time
1971 * (ie PV->NV conversion should detect loss of accuracy and cache
1972 * IV or UV at same time to avoid this. */
1973 /* IV-over-UV optimisation - choose to cache IV if possible */
1975 if (SvTYPE(sv) == SVt_NV)
1976 sv_upgrade(sv, SVt_PVNV);
1978 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1979 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1980 certainly cast into the IV range at IV_MAX, whereas the correct
1981 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1983 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1984 if (Perl_isnan(SvNVX(sv))) {
1990 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1991 SvIV_set(sv, I_V(SvNVX(sv)));
1992 if (SvNVX(sv) == (NV) SvIVX(sv)
1993 #ifndef NV_PRESERVES_UV
1994 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1995 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1996 /* Don't flag it as "accurately an integer" if the number
1997 came from a (by definition imprecise) NV operation, and
1998 we're outside the range of NV integer precision */
2002 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2004 /* scalar has trailing garbage, eg "42a" */
2006 DEBUG_c(PerlIO_printf(Perl_debug_log,
2007 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2013 /* IV not precise. No need to convert from PV, as NV
2014 conversion would already have cached IV if it detected
2015 that PV->IV would be better than PV->NV->IV
2016 flags already correct - don't set public IOK. */
2017 DEBUG_c(PerlIO_printf(Perl_debug_log,
2018 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2023 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2024 but the cast (NV)IV_MIN rounds to a the value less (more
2025 negative) than IV_MIN which happens to be equal to SvNVX ??
2026 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2027 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2028 (NV)UVX == NVX are both true, but the values differ. :-(
2029 Hopefully for 2s complement IV_MIN is something like
2030 0x8000000000000000 which will be exact. NWC */
2033 SvUV_set(sv, U_V(SvNVX(sv)));
2035 (SvNVX(sv) == (NV) SvUVX(sv))
2036 #ifndef NV_PRESERVES_UV
2037 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2038 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2039 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2040 /* Don't flag it as "accurately an integer" if the number
2041 came from a (by definition imprecise) NV operation, and
2042 we're outside the range of NV integer precision */
2048 DEBUG_c(PerlIO_printf(Perl_debug_log,
2049 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2055 else if (SvPOKp(sv) && SvLEN(sv)) {
2057 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2058 /* We want to avoid a possible problem when we cache an IV/ a UV which
2059 may be later translated to an NV, and the resulting NV is not
2060 the same as the direct translation of the initial string
2061 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2062 be careful to ensure that the value with the .456 is around if the
2063 NV value is requested in the future).
2065 This means that if we cache such an IV/a UV, we need to cache the
2066 NV as well. Moreover, we trade speed for space, and do not
2067 cache the NV if we are sure it's not needed.
2070 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2071 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2072 == IS_NUMBER_IN_UV) {
2073 /* It's definitely an integer, only upgrade to PVIV */
2074 if (SvTYPE(sv) < SVt_PVIV)
2075 sv_upgrade(sv, SVt_PVIV);
2077 } else if (SvTYPE(sv) < SVt_PVNV)
2078 sv_upgrade(sv, SVt_PVNV);
2080 /* If NVs preserve UVs then we only use the UV value if we know that
2081 we aren't going to call atof() below. If NVs don't preserve UVs
2082 then the value returned may have more precision than atof() will
2083 return, even though value isn't perfectly accurate. */
2084 if ((numtype & (IS_NUMBER_IN_UV
2085 #ifdef NV_PRESERVES_UV
2088 )) == IS_NUMBER_IN_UV) {
2089 /* This won't turn off the public IOK flag if it was set above */
2090 (void)SvIOKp_on(sv);
2092 if (!(numtype & IS_NUMBER_NEG)) {
2094 if (value <= (UV)IV_MAX) {
2095 SvIV_set(sv, (IV)value);
2097 /* it didn't overflow, and it was positive. */
2098 SvUV_set(sv, value);
2102 /* 2s complement assumption */
2103 if (value <= (UV)IV_MIN) {
2104 SvIV_set(sv, -(IV)value);
2106 /* Too negative for an IV. This is a double upgrade, but
2107 I'm assuming it will be rare. */
2108 if (SvTYPE(sv) < SVt_PVNV)
2109 sv_upgrade(sv, SVt_PVNV);
2113 SvNV_set(sv, -(NV)value);
2114 SvIV_set(sv, IV_MIN);
2118 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2119 will be in the previous block to set the IV slot, and the next
2120 block to set the NV slot. So no else here. */
2122 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2123 != IS_NUMBER_IN_UV) {
2124 /* It wasn't an (integer that doesn't overflow the UV). */
2125 SvNV_set(sv, Atof(SvPVX_const(sv)));
2127 if (! numtype && ckWARN(WARN_NUMERIC))
2130 #if defined(USE_LONG_DOUBLE)
2131 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2132 PTR2UV(sv), SvNVX(sv)));
2134 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2135 PTR2UV(sv), SvNVX(sv)));
2138 #ifdef NV_PRESERVES_UV
2139 (void)SvIOKp_on(sv);
2141 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2142 SvIV_set(sv, I_V(SvNVX(sv)));
2143 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2146 NOOP; /* Integer is imprecise. NOK, IOKp */
2148 /* UV will not work better than IV */
2150 if (SvNVX(sv) > (NV)UV_MAX) {
2152 /* Integer is inaccurate. NOK, IOKp, is UV */
2153 SvUV_set(sv, UV_MAX);
2155 SvUV_set(sv, U_V(SvNVX(sv)));
2156 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2157 NV preservse UV so can do correct comparison. */
2158 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2161 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
2166 #else /* NV_PRESERVES_UV */
2167 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2168 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2169 /* The IV/UV slot will have been set from value returned by
2170 grok_number above. The NV slot has just been set using
2173 assert (SvIOKp(sv));
2175 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2176 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2177 /* Small enough to preserve all bits. */
2178 (void)SvIOKp_on(sv);
2180 SvIV_set(sv, I_V(SvNVX(sv)));
2181 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2183 /* Assumption: first non-preserved integer is < IV_MAX,
2184 this NV is in the preserved range, therefore: */
2185 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2187 Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2191 0 0 already failed to read UV.
2192 0 1 already failed to read UV.
2193 1 0 you won't get here in this case. IV/UV
2194 slot set, public IOK, Atof() unneeded.
2195 1 1 already read UV.
2196 so there's no point in sv_2iuv_non_preserve() attempting
2197 to use atol, strtol, strtoul etc. */
2199 sv_2iuv_non_preserve (sv, numtype);
2201 sv_2iuv_non_preserve (sv);
2205 #endif /* NV_PRESERVES_UV */
2206 /* It might be more code efficient to go through the entire logic above
2207 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2208 gets complex and potentially buggy, so more programmer efficient
2209 to do it this way, by turning off the public flags: */
2211 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2215 if (isGV_with_GP(sv))
2216 return glob_2number(MUTABLE_GV(sv));
2218 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2219 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2222 if (SvTYPE(sv) < SVt_IV)
2223 /* Typically the caller expects that sv_any is not NULL now. */
2224 sv_upgrade(sv, SVt_IV);
2225 /* Return 0 from the caller. */
2232 =for apidoc sv_2iv_flags
2234 Return the integer value of an SV, doing any necessary string
2235 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2236 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2242 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2247 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2248 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2249 cache IVs just in case. In practice it seems that they never
2250 actually anywhere accessible by user Perl code, let alone get used
2251 in anything other than a string context. */
2252 if (flags & SV_GMAGIC)
2257 return I_V(SvNVX(sv));
2259 if (SvPOKp(sv) && SvLEN(sv)) {
2262 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2264 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2265 == IS_NUMBER_IN_UV) {
2266 /* It's definitely an integer */
2267 if (numtype & IS_NUMBER_NEG) {
2268 if (value < (UV)IV_MIN)
2271 if (value < (UV)IV_MAX)
2276 if (ckWARN(WARN_NUMERIC))
2279 return I_V(Atof(SvPVX_const(sv)));
2284 assert(SvTYPE(sv) >= SVt_PVMG);
2285 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2286 } else if (SvTHINKFIRST(sv)) {
2291 if (flags & SV_SKIP_OVERLOAD)
2293 tmpstr=AMG_CALLun(sv,numer);
2294 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2295 return SvIV(tmpstr);
2298 return PTR2IV(SvRV(sv));
2301 sv_force_normal_flags(sv, 0);
2303 if (SvREADONLY(sv) && !SvOK(sv)) {
2304 if (ckWARN(WARN_UNINITIALIZED))
2310 if (S_sv_2iuv_common(aTHX_ sv))
2313 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2314 PTR2UV(sv),SvIVX(sv)));
2315 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2319 =for apidoc sv_2uv_flags
2321 Return the unsigned integer value of an SV, doing any necessary string
2322 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2323 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2329 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2334 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2335 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2336 cache IVs just in case. */
2337 if (flags & SV_GMAGIC)
2342 return U_V(SvNVX(sv));
2343 if (SvPOKp(sv) && SvLEN(sv)) {
2346 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2348 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2349 == IS_NUMBER_IN_UV) {
2350 /* It's definitely an integer */
2351 if (!(numtype & IS_NUMBER_NEG))
2355 if (ckWARN(WARN_NUMERIC))
2358 return U_V(Atof(SvPVX_const(sv)));
2363 assert(SvTYPE(sv) >= SVt_PVMG);
2364 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2365 } else if (SvTHINKFIRST(sv)) {
2370 if (flags & SV_SKIP_OVERLOAD)
2372 tmpstr = AMG_CALLun(sv,numer);
2373 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2374 return SvUV(tmpstr);
2377 return PTR2UV(SvRV(sv));
2380 sv_force_normal_flags(sv, 0);
2382 if (SvREADONLY(sv) && !SvOK(sv)) {
2383 if (ckWARN(WARN_UNINITIALIZED))
2389 if (S_sv_2iuv_common(aTHX_ sv))
2393 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2394 PTR2UV(sv),SvUVX(sv)));
2395 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2399 =for apidoc sv_2nv_flags
2401 Return the num value of an SV, doing any necessary string or integer
2402 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2403 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2409 Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
2414 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2415 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2416 cache IVs just in case. */
2417 if (flags & SV_GMAGIC)
2421 if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2422 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2423 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2425 return Atof(SvPVX_const(sv));
2429 return (NV)SvUVX(sv);
2431 return (NV)SvIVX(sv);
2436 assert(SvTYPE(sv) >= SVt_PVMG);
2437 /* This falls through to the report_uninit near the end of the
2439 } else if (SvTHINKFIRST(sv)) {
2444 if (flags & SV_SKIP_OVERLOAD)
2446 tmpstr = AMG_CALLun(sv,numer);
2447 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2448 return SvNV(tmpstr);
2451 return PTR2NV(SvRV(sv));
2454 sv_force_normal_flags(sv, 0);
2456 if (SvREADONLY(sv) && !SvOK(sv)) {
2457 if (ckWARN(WARN_UNINITIALIZED))
2462 if (SvTYPE(sv) < SVt_NV) {
2463 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2464 sv_upgrade(sv, SVt_NV);
2465 #ifdef USE_LONG_DOUBLE
2467 STORE_NUMERIC_LOCAL_SET_STANDARD();
2468 PerlIO_printf(Perl_debug_log,
2469 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2470 PTR2UV(sv), SvNVX(sv));
2471 RESTORE_NUMERIC_LOCAL();
2475 STORE_NUMERIC_LOCAL_SET_STANDARD();
2476 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2477 PTR2UV(sv), SvNVX(sv));
2478 RESTORE_NUMERIC_LOCAL();
2482 else if (SvTYPE(sv) < SVt_PVNV)
2483 sv_upgrade(sv, SVt_PVNV);
2488 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2489 #ifdef NV_PRESERVES_UV
2495 /* Only set the public NV OK flag if this NV preserves the IV */
2496 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2498 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2499 : (SvIVX(sv) == I_V(SvNVX(sv))))
2505 else if (SvPOKp(sv) && SvLEN(sv)) {
2507 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2508 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2510 #ifdef NV_PRESERVES_UV
2511 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2512 == IS_NUMBER_IN_UV) {
2513 /* It's definitely an integer */
2514 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2516 SvNV_set(sv, Atof(SvPVX_const(sv)));
2522 SvNV_set(sv, Atof(SvPVX_const(sv)));
2523 /* Only set the public NV OK flag if this NV preserves the value in
2524 the PV at least as well as an IV/UV would.
2525 Not sure how to do this 100% reliably. */
2526 /* if that shift count is out of range then Configure's test is
2527 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2529 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2530 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2531 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2532 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2533 /* Can't use strtol etc to convert this string, so don't try.
2534 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2537 /* value has been set. It may not be precise. */
2538 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2539 /* 2s complement assumption for (UV)IV_MIN */
2540 SvNOK_on(sv); /* Integer is too negative. */
2545 if (numtype & IS_NUMBER_NEG) {
2546 SvIV_set(sv, -(IV)value);
2547 } else if (value <= (UV)IV_MAX) {
2548 SvIV_set(sv, (IV)value);
2550 SvUV_set(sv, value);
2554 if (numtype & IS_NUMBER_NOT_INT) {
2555 /* I believe that even if the original PV had decimals,
2556 they are lost beyond the limit of the FP precision.
2557 However, neither is canonical, so both only get p
2558 flags. NWC, 2000/11/25 */
2559 /* Both already have p flags, so do nothing */
2561 const NV nv = SvNVX(sv);
2562 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2563 if (SvIVX(sv) == I_V(nv)) {
2566 /* It had no "." so it must be integer. */
2570 /* between IV_MAX and NV(UV_MAX).
2571 Could be slightly > UV_MAX */
2573 if (numtype & IS_NUMBER_NOT_INT) {
2574 /* UV and NV both imprecise. */
2576 const UV nv_as_uv = U_V(nv);
2578 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2587 /* It might be more code efficient to go through the entire logic above
2588 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2589 gets complex and potentially buggy, so more programmer efficient
2590 to do it this way, by turning off the public flags: */
2592 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2593 #endif /* NV_PRESERVES_UV */
2596 if (isGV_with_GP(sv)) {
2597 glob_2number(MUTABLE_GV(sv));
2601 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2603 assert (SvTYPE(sv) >= SVt_NV);
2604 /* Typically the caller expects that sv_any is not NULL now. */
2605 /* XXX Ilya implies that this is a bug in callers that assume this
2606 and ideally should be fixed. */
2609 #if defined(USE_LONG_DOUBLE)
2611 STORE_NUMERIC_LOCAL_SET_STANDARD();
2612 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2613 PTR2UV(sv), SvNVX(sv));
2614 RESTORE_NUMERIC_LOCAL();
2618 STORE_NUMERIC_LOCAL_SET_STANDARD();
2619 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2620 PTR2UV(sv), SvNVX(sv));
2621 RESTORE_NUMERIC_LOCAL();
2630 Return an SV with the numeric value of the source SV, doing any necessary
2631 reference or overload conversion. You must use the C<SvNUM(sv)> macro to
2632 access this function.
2638 Perl_sv_2num(pTHX_ register SV *const sv)
2640 PERL_ARGS_ASSERT_SV_2NUM;
2645 SV * const tmpsv = AMG_CALLun(sv,numer);
2646 TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2647 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2648 return sv_2num(tmpsv);
2650 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2653 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2654 * UV as a string towards the end of buf, and return pointers to start and
2657 * We assume that buf is at least TYPE_CHARS(UV) long.
2661 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2663 char *ptr = buf + TYPE_CHARS(UV);
2664 char * const ebuf = ptr;
2667 PERL_ARGS_ASSERT_UIV_2BUF;
2679 *--ptr = '0' + (char)(uv % 10);
2688 =for apidoc sv_2pv_flags
2690 Returns a pointer to the string value of an SV, and sets *lp to its length.
2691 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2693 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2694 usually end up here too.
2700 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2710 if (SvGMAGICAL(sv)) {
2711 if (flags & SV_GMAGIC)
2716 if (flags & SV_MUTABLE_RETURN)
2717 return SvPVX_mutable(sv);
2718 if (flags & SV_CONST_RETURN)
2719 return (char *)SvPVX_const(sv);
2722 if (SvIOKp(sv) || SvNOKp(sv)) {
2723 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2728 ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2729 : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2730 } else if(SvNVX(sv) == 0.0) {
2735 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2742 SvUPGRADE(sv, SVt_PV);
2745 s = SvGROW_mutable(sv, len + 1);
2748 return (char*)memcpy(s, tbuf, len + 1);
2754 assert(SvTYPE(sv) >= SVt_PVMG);
2755 /* This falls through to the report_uninit near the end of the
2757 } else if (SvTHINKFIRST(sv)) {
2762 if (flags & SV_SKIP_OVERLOAD)
2764 tmpstr = AMG_CALLun(sv,string);
2765 TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2766 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2768 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2772 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2773 if (flags & SV_CONST_RETURN) {
2774 pv = (char *) SvPVX_const(tmpstr);
2776 pv = (flags & SV_MUTABLE_RETURN)
2777 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2780 *lp = SvCUR(tmpstr);
2782 pv = sv_2pv_flags(tmpstr, lp, flags);
2795 SV *const referent = SvRV(sv);
2799 retval = buffer = savepvn("NULLREF", len);
2800 } else if (SvTYPE(referent) == SVt_REGEXP) {
2801 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2806 /* If the regex is UTF-8 we want the containing scalar to
2807 have an UTF-8 flag too */
2813 if ((seen_evals = RX_SEEN_EVALS(re)))
2814 PL_reginterp_cnt += seen_evals;
2817 *lp = RX_WRAPLEN(re);
2819 return RX_WRAPPED(re);
2821 const char *const typestr = sv_reftype(referent, 0);
2822 const STRLEN typelen = strlen(typestr);
2823 UV addr = PTR2UV(referent);
2824 const char *stashname = NULL;
2825 STRLEN stashnamelen = 0; /* hush, gcc */
2826 const char *buffer_end;
2828 if (SvOBJECT(referent)) {
2829 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2832 stashname = HEK_KEY(name);
2833 stashnamelen = HEK_LEN(name);
2835 if (HEK_UTF8(name)) {
2841 stashname = "__ANON__";
2844 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2845 + 2 * sizeof(UV) + 2 /* )\0 */;
2847 len = typelen + 3 /* (0x */
2848 + 2 * sizeof(UV) + 2 /* )\0 */;
2851 Newx(buffer, len, char);
2852 buffer_end = retval = buffer + len;
2854 /* Working backwards */
2858 *--retval = PL_hexdigit[addr & 15];
2859 } while (addr >>= 4);
2865 memcpy(retval, typestr, typelen);
2869 retval -= stashnamelen;
2870 memcpy(retval, stashname, stashnamelen);
2872 /* retval may not neccesarily have reached the start of the
2874 assert (retval >= buffer);
2876 len = buffer_end - retval - 1; /* -1 for that \0 */
2884 if (SvREADONLY(sv) && !SvOK(sv)) {
2887 if (flags & SV_UNDEF_RETURNS_NULL)
2889 if (ckWARN(WARN_UNINITIALIZED))
2894 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2895 /* I'm assuming that if both IV and NV are equally valid then
2896 converting the IV is going to be more efficient */
2897 const U32 isUIOK = SvIsUV(sv);
2898 char buf[TYPE_CHARS(UV)];
2902 if (SvTYPE(sv) < SVt_PVIV)
2903 sv_upgrade(sv, SVt_PVIV);
2904 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2906 /* inlined from sv_setpvn */
2907 s = SvGROW_mutable(sv, len + 1);
2908 Move(ptr, s, len, char);
2912 else if (SvNOKp(sv)) {
2913 if (SvTYPE(sv) < SVt_PVNV)
2914 sv_upgrade(sv, SVt_PVNV);
2915 if (SvNVX(sv) == 0.0) {
2916 s = SvGROW_mutable(sv, 2);
2921 /* The +20 is pure guesswork. Configure test needed. --jhi */
2922 s = SvGROW_mutable(sv, NV_DIG + 20);
2923 /* some Xenix systems wipe out errno here */
2924 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2934 if (isGV_with_GP(sv)) {
2935 GV *const gv = MUTABLE_GV(sv);
2936 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
2937 SV *const buffer = sv_newmortal();
2939 /* FAKE globs can get coerced, so need to turn this off temporarily
2942 gv_efullname3(buffer, gv, "*");
2943 SvFLAGS(gv) |= wasfake;
2945 if (SvPOK(buffer)) {
2947 *lp = SvCUR(buffer);
2949 return SvPVX(buffer);
2960 if (flags & SV_UNDEF_RETURNS_NULL)
2962 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2964 if (SvTYPE(sv) < SVt_PV)
2965 /* Typically the caller expects that sv_any is not NULL now. */
2966 sv_upgrade(sv, SVt_PV);
2970 const STRLEN len = s - SvPVX_const(sv);
2976 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2977 PTR2UV(sv),SvPVX_const(sv)));
2978 if (flags & SV_CONST_RETURN)
2979 return (char *)SvPVX_const(sv);
2980 if (flags & SV_MUTABLE_RETURN)
2981 return SvPVX_mutable(sv);
2986 =for apidoc sv_copypv
2988 Copies a stringified representation of the source SV into the
2989 destination SV. Automatically performs any necessary mg_get and
2990 coercion of numeric values into strings. Guaranteed to preserve
2991 UTF8 flag even from overloaded objects. Similar in nature to
2992 sv_2pv[_flags] but operates directly on an SV instead of just the
2993 string. Mostly uses sv_2pv_flags to do its work, except when that
2994 would lose the UTF-8'ness of the PV.
3000 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3003 const char * const s = SvPV_const(ssv,len);
3005 PERL_ARGS_ASSERT_SV_COPYPV;
3007 sv_setpvn(dsv,s,len);
3015 =for apidoc sv_2pvbyte
3017 Return a pointer to the byte-encoded representation of the SV, and set *lp
3018 to its length. May cause the SV to be downgraded from UTF-8 as a
3021 Usually accessed via the C<SvPVbyte> macro.
3027 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3029 PERL_ARGS_ASSERT_SV_2PVBYTE;
3032 sv_utf8_downgrade(sv,0);
3033 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3037 =for apidoc sv_2pvutf8
3039 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3040 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3042 Usually accessed via the C<SvPVutf8> macro.
3048 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3050 PERL_ARGS_ASSERT_SV_2PVUTF8;
3052 sv_utf8_upgrade(sv);
3053 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3058 =for apidoc sv_2bool
3060 This macro is only used by sv_true() or its macro equivalent, and only if
3061 the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3062 It calls sv_2bool_flags with the SV_GMAGIC flag.
3064 =for apidoc sv_2bool_flags
3066 This function is only used by sv_true() and friends, and only if
3067 the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
3068 contain SV_GMAGIC, then it does an mg_get() first.
3075 Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags)
3079 PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3081 if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3087 SV * const tmpsv = AMG_CALLun(sv,bool_);
3088 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3089 return cBOOL(SvTRUE(tmpsv));
3091 return SvRV(sv) != 0;
3094 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3096 (*sv->sv_u.svu_pv > '0' ||
3097 Xpvtmp->xpv_cur > 1 ||
3098 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3105 return SvIVX(sv) != 0;
3108 return SvNVX(sv) != 0.0;
3110 if (isGV_with_GP(sv))
3120 =for apidoc sv_utf8_upgrade
3122 Converts the PV of an SV to its UTF-8-encoded form.
3123 Forces the SV to string form if it is not already.
3124 Will C<mg_get> on C<sv> if appropriate.
3125 Always sets the SvUTF8 flag to avoid future validity checks even
3126 if the whole string is the same in UTF-8 as not.
3127 Returns the number of bytes in the converted string
3129 This is not as a general purpose byte encoding to Unicode interface:
3130 use the Encode extension for that.
3132 =for apidoc sv_utf8_upgrade_nomg
3134 Like sv_utf8_upgrade, but doesn't do magic on C<sv>
3136 =for apidoc sv_utf8_upgrade_flags
3138 Converts the PV of an SV to its UTF-8-encoded form.
3139 Forces the SV to string form if it is not already.
3140 Always sets the SvUTF8 flag to avoid future validity checks even
3141 if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
3142 will C<mg_get> on C<sv> if appropriate, else not.
3143 Returns the number of bytes in the converted string
3144 C<sv_utf8_upgrade> and
3145 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3147 This is not as a general purpose byte encoding to Unicode interface:
3148 use the Encode extension for that.
3152 The grow version is currently not externally documented. It adds a parameter,
3153 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3154 have free after it upon return. This allows the caller to reserve extra space
3155 that it intends to fill, to avoid extra grows.
3157 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3158 which can be used to tell this function to not first check to see if there are
3159 any characters that are different in UTF-8 (variant characters) which would
3160 force it to allocate a new string to sv, but to assume there are. Typically
3161 this flag is used by a routine that has already parsed the string to find that
3162 there are such characters, and passes this information on so that the work
3163 doesn't have to be repeated.
3165 (One might think that the calling routine could pass in the position of the
3166 first such variant, so it wouldn't have to be found again. But that is not the
3167 case, because typically when the caller is likely to use this flag, it won't be
3168 calling this routine unless it finds something that won't fit into a byte.
3169 Otherwise it tries to not upgrade and just use bytes. But some things that
3170 do fit into a byte are variants in utf8, and the caller may not have been
3171 keeping track of these.)
3173 If the routine itself changes the string, it adds a trailing NUL. Such a NUL
3174 isn't guaranteed due to having other routines do the work in some input cases,
3175 or if the input is already flagged as being in utf8.
3177 The speed of this could perhaps be improved for many cases if someone wanted to
3178 write a fast function that counts the number of variant characters in a string,
3179 especially if it could return the position of the first one.
3184 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
3188 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3190 if (sv == &PL_sv_undef)
3194 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3195 (void) sv_2pv_flags(sv,&len, flags);
3197 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3201 (void) SvPV_force(sv,len);
3206 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3211 sv_force_normal_flags(sv, 0);
3214 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3215 sv_recode_to_utf8(sv, PL_encoding);
3216 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3220 if (SvCUR(sv) == 0) {
3221 if (extra) SvGROW(sv, extra);
3222 } else { /* Assume Latin-1/EBCDIC */
3223 /* This function could be much more efficient if we
3224 * had a FLAG in SVs to signal if there are any variant
3225 * chars in the PV. Given that there isn't such a flag
3226 * make the loop as fast as possible (although there are certainly ways
3227 * to speed this up, eg. through vectorization) */
3228 U8 * s = (U8 *) SvPVX_const(sv);
3229 U8 * e = (U8 *) SvEND(sv);
3231 STRLEN two_byte_count = 0;
3233 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3235 /* See if really will need to convert to utf8. We mustn't rely on our
3236 * incoming SV being well formed and having a trailing '\0', as certain
3237 * code in pp_formline can send us partially built SVs. */
3241 if (NATIVE_IS_INVARIANT(ch)) continue;
3243 t--; /* t already incremented; re-point to first variant */
3248 /* utf8 conversion not needed because all are invariants. Mark as
3249 * UTF-8 even if no variant - saves scanning loop */
3255 /* Here, the string should be converted to utf8, either because of an
3256 * input flag (two_byte_count = 0), or because a character that
3257 * requires 2 bytes was found (two_byte_count = 1). t points either to
3258 * the beginning of the string (if we didn't examine anything), or to
3259 * the first variant. In either case, everything from s to t - 1 will
3260 * occupy only 1 byte each on output.
3262 * There are two main ways to convert. One is to create a new string
3263 * and go through the input starting from the beginning, appending each
3264 * converted value onto the new string as we go along. It's probably
3265 * best to allocate enough space in the string for the worst possible
3266 * case rather than possibly running out of space and having to
3267 * reallocate and then copy what we've done so far. Since everything
3268 * from s to t - 1 is invariant, the destination can be initialized
3269 * with these using a fast memory copy
3271 * The other way is to figure out exactly how big the string should be
3272 * by parsing the entire input. Then you don't have to make it big
3273 * enough to handle the worst possible case, and more importantly, if
3274 * the string you already have is large enough, you don't have to
3275 * allocate a new string, you can copy the last character in the input
3276 * string to the final position(s) that will be occupied by the
3277 * converted string and go backwards, stopping at t, since everything
3278 * before that is invariant.
3280 * There are advantages and disadvantages to each method.
3282 * In the first method, we can allocate a new string, do the memory
3283 * copy from the s to t - 1, and then proceed through the rest of the
3284 * string byte-by-byte.
3286 * In the second method, we proceed through the rest of the input
3287 * string just calculating how big the converted string will be. Then
3288 * there are two cases:
3289 * 1) if the string has enough extra space to handle the converted
3290 * value. We go backwards through the string, converting until we
3291 * get to the position we are at now, and then stop. If this
3292 * position is far enough along in the string, this method is
3293 * faster than the other method. If the memory copy were the same
3294 * speed as the byte-by-byte loop, that position would be about
3295 * half-way, as at the half-way mark, parsing to the end and back
3296 * is one complete string's parse, the same amount as starting
3297 * over and going all the way through. Actually, it would be
3298 * somewhat less than half-way, as it's faster to just count bytes
3299 * than to also copy, and we don't have the overhead of allocating
3300 * a new string, changing the scalar to use it, and freeing the
3301 * existing one. But if the memory copy is fast, the break-even
3302 * point is somewhere after half way. The counting loop could be
3303 * sped up by vectorization, etc, to move the break-even point
3304 * further towards the beginning.
3305 * 2) if the string doesn't have enough space to handle the converted
3306 * value. A new string will have to be allocated, and one might
3307 * as well, given that, start from the beginning doing the first
3308 * method. We've spent extra time parsing the string and in
3309 * exchange all we've gotten is that we know precisely how big to
3310 * make the new one. Perl is more optimized for time than space,
3311 * so this case is a loser.
3312 * So what I've decided to do is not use the 2nd method unless it is
3313 * guaranteed that a new string won't have to be allocated, assuming
3314 * the worst case. I also decided not to put any more conditions on it
3315 * than this, for now. It seems likely that, since the worst case is
3316 * twice as big as the unknown portion of the string (plus 1), we won't
3317 * be guaranteed enough space, causing us to go to the first method,
3318 * unless the string is short, or the first variant character is near
3319 * the end of it. In either of these cases, it seems best to use the
3320 * 2nd method. The only circumstance I can think of where this would
3321 * be really slower is if the string had once had much more data in it
3322 * than it does now, but there is still a substantial amount in it */
3325 STRLEN invariant_head = t - s;
3326 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3327 if (SvLEN(sv) < size) {
3329 /* Here, have decided to allocate a new string */
3334 Newx(dst, size, U8);
3336 /* If no known invariants at the beginning of the input string,
3337 * set so starts from there. Otherwise, can use memory copy to
3338 * get up to where we are now, and then start from here */
3340 if (invariant_head <= 0) {
3343 Copy(s, dst, invariant_head, char);
3344 d = dst + invariant_head;
3348 const UV uv = NATIVE8_TO_UNI(*t++);
3349 if (UNI_IS_INVARIANT(uv))
3350 *d++ = (U8)UNI_TO_NATIVE(uv);
3352 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3353 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3357 SvPV_free(sv); /* No longer using pre-existing string */
3358 SvPV_set(sv, (char*)dst);
3359 SvCUR_set(sv, d - dst);
3360 SvLEN_set(sv, size);
3363 /* Here, have decided to get the exact size of the string.
3364 * Currently this happens only when we know that there is
3365 * guaranteed enough space to fit the converted string, so
3366 * don't have to worry about growing. If two_byte_count is 0,
3367 * then t points to the first byte of the string which hasn't
3368 * been examined yet. Otherwise two_byte_count is 1, and t
3369 * points to the first byte in the string that will expand to
3370 * two. Depending on this, start examining at t or 1 after t.
3373 U8 *d = t + two_byte_count;
3376 /* Count up the remaining bytes that expand to two */
3379 const U8 chr = *d++;
3380 if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3383 /* The string will expand by just the number of bytes that
3384 * occupy two positions. But we are one afterwards because of
3385 * the increment just above. This is the place to put the
3386 * trailing NUL, and to set the length before we decrement */
3388 d += two_byte_count;
3389 SvCUR_set(sv, d - s);
3393 /* Having decremented d, it points to the position to put the
3394 * very last byte of the expanded string. Go backwards through
3395 * the string, copying and expanding as we go, stopping when we
3396 * get to the part that is invariant the rest of the way down */
3400 const U8 ch = NATIVE8_TO_UNI(*e--);
3401 if (UNI_IS_INVARIANT(ch)) {
3402 *d-- = UNI_TO_NATIVE(ch);
3404 *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3405 *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3412 /* Mark as UTF-8 even if no variant - saves scanning loop */
3418 =for apidoc sv_utf8_downgrade
3420 Attempts to convert the PV of an SV from characters to bytes.
3421 If the PV contains a character that cannot fit
3422 in a byte, this conversion will fail;
3423 in this case, either returns false or, if C<fail_ok> is not
3426 This is not as a general purpose Unicode to byte encoding interface:
3427 use the Encode extension for that.
3433 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3437 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3439 if (SvPOKp(sv) && SvUTF8(sv)) {
3445 sv_force_normal_flags(sv, 0);
3447 s = (U8 *) SvPV(sv, len);
3448 if (!utf8_to_bytes(s, &len)) {
3453 Perl_croak(aTHX_ "Wide character in %s",
3456 Perl_croak(aTHX_ "Wide character");
3467 =for apidoc sv_utf8_encode
3469 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3470 flag off so that it looks like octets again.
3476 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3478 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3481 sv_force_normal_flags(sv, 0);
3483 if (SvREADONLY(sv)) {
3484 Perl_croak_no_modify(aTHX);
3486 (void) sv_utf8_upgrade(sv);
3491 =for apidoc sv_utf8_decode
3493 If the PV of the SV is an octet sequence in UTF-8
3494 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3495 so that it looks like a character. If the PV contains only single-byte
3496 characters, the C<SvUTF8> flag stays being off.
3497 Scans PV for validity and returns false if the PV is invalid UTF-8.
3503 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3505 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3511 /* The octets may have got themselves encoded - get them back as
3514 if (!sv_utf8_downgrade(sv, TRUE))
3517 /* it is actually just a matter of turning the utf8 flag on, but
3518 * we want to make sure everything inside is valid utf8 first.
3520 c = (const U8 *) SvPVX_const(sv);
3521 if (!is_utf8_string(c, SvCUR(sv)+1))
3523 e = (const U8 *) SvEND(sv);
3526 if (!UTF8_IS_INVARIANT(ch)) {
3536 =for apidoc sv_setsv
3538 Copies the contents of the source SV C<ssv> into the destination SV
3539 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3540 function if the source SV needs to be reused. Does not handle 'set' magic.
3541 Loosely speaking, it performs a copy-by-value, obliterating any previous
3542 content of the destination.
3544 You probably want to use one of the assortment of wrappers, such as
3545 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3546 C<SvSetMagicSV_nosteal>.
3548 =for apidoc sv_setsv_flags
3550 Copies the contents of the source SV C<ssv> into the destination SV
3551 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3552 function if the source SV needs to be reused. Does not handle 'set' magic.
3553 Loosely speaking, it performs a copy-by-value, obliterating any previous
3554 content of the destination.
3555 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3556 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3557 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3558 and C<sv_setsv_nomg> are implemented in terms of this function.
3560 You probably want to use one of the assortment of wrappers, such as
3561 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3562 C<SvSetMagicSV_nosteal>.
3564 This is the primary function for copying scalars, and most other
3565 copy-ish functions and macros use this underneath.
3571 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3573 I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3574 HV *old_stash = NULL;
3576 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3578 if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3579 const char * const name = GvNAME(sstr);
3580 const STRLEN len = GvNAMELEN(sstr);
3582 if (dtype >= SVt_PV) {
3588 SvUPGRADE(dstr, SVt_PVGV);
3589 (void)SvOK_off(dstr);
3590 /* FIXME - why are we doing this, then turning it off and on again
3592 isGV_with_GP_on(dstr);
3594 GvSTASH(dstr) = GvSTASH(sstr);
3596 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3597 gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
3598 SvFAKE_on(dstr); /* can coerce to non-glob */
3601 if(GvGP(MUTABLE_GV(sstr))) {
3602 /* If source has method cache entry, clear it */
3604 SvREFCNT_dec(GvCV(sstr));
3608 /* If source has a real method, then a method is
3611 GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3617 /* If dest already had a real method, that's a change as well */
3619 !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3620 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3625 /* We don’t need to check the name of the destination if it was not a
3626 glob to begin with. */
3627 if(dtype == SVt_PVGV) {
3628 const char * const name = GvNAME((const GV *)dstr);
3631 /* The stash may have been detached from the symbol table, so
3633 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3634 && GvAV((const GV *)sstr)
3638 const STRLEN len = GvNAMELEN(dstr);
3639 if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
3642 /* Set aside the old stash, so we can reset isa caches on
3644 if((old_stash = GvHV(dstr)))
3645 /* Make sure we do not lose it early. */
3646 SvREFCNT_inc_simple_void_NN(
3647 sv_2mortal((SV *)old_stash)
3653 gp_free(MUTABLE_GV(dstr));
3654 isGV_with_GP_off(dstr);
3655 (void)SvOK_off(dstr);
3656 isGV_with_GP_on(dstr);
3657 GvINTRO_off(dstr); /* one-shot flag */
3658 GvGP(dstr) = gp_ref(GvGP(sstr));
3659 if (SvTAINTED(sstr))
3661 if (GvIMPORTED(dstr) != GVf_IMPORTED
3662 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3664 GvIMPORTED_on(dstr);
3667 if(mro_changes == 2) {
3669 SV * const sref = (SV *)GvAV((const GV *)dstr);
3670 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3671 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3672 AV * const ary = newAV();
3673 av_push(ary, mg->mg_obj); /* takes the refcount */
3674 mg->mg_obj = (SV *)ary;
3676 av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3678 else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3679 mro_isa_changed_in(GvSTASH(dstr));
3681 else if(mro_changes == 3) {
3682 HV * const stash = GvHV(dstr);
3683 if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3689 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3694 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3696 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3698 const int intro = GvINTRO(dstr);
3701 const U32 stype = SvTYPE(sref);
3703 PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3706 GvINTRO_off(dstr); /* one-shot flag */
3707 GvLINE(dstr) = CopLINE(PL_curcop);
3708 GvEGV(dstr) = MUTABLE_GV(dstr);
3713 location = (SV **) &GvCV(dstr);
3714 import_flag = GVf_IMPORTED_CV;
3717 location = (SV **) &GvHV(dstr);
3718 import_flag = GVf_IMPORTED_HV;
3721 location = (SV **) &GvAV(dstr);
3722 import_flag = GVf_IMPORTED_AV;
3725 location = (SV **) &GvIOp(dstr);
3728 location = (SV **) &GvFORM(dstr);
3731 location = &GvSV(dstr);
3732 import_flag = GVf_IMPORTED_SV;
3735 if (stype == SVt_PVCV) {
3736 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3737 if (GvCVGEN(dstr)) {
3738 SvREFCNT_dec(GvCV(dstr));
3740 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3743 SAVEGENERICSV(*location);
3747 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3748 CV* const cv = MUTABLE_CV(*location);
3750 if (!GvCVGEN((const GV *)dstr) &&
3751 (CvROOT(cv) || CvXSUB(cv)))
3753 /* Redefining a sub - warning is mandatory if
3754 it was a const and its value changed. */
3755 if (CvCONST(cv) && CvCONST((const CV *)sref)
3757 == cv_const_sv((const CV *)sref)) {
3759 /* They are 2 constant subroutines generated from
3760 the same constant. This probably means that
3761 they are really the "same" proxy subroutine
3762 instantiated in 2 places. Most likely this is
3763 when a constant is exported twice. Don't warn.
3766 else if (ckWARN(WARN_REDEFINE)
3768 && (!CvCONST((const CV *)sref)
3769 || sv_cmp(cv_const_sv(cv),
3770 cv_const_sv((const CV *)
3772 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3775 ? "Constant subroutine %s::%s redefined"
3776 : "Subroutine %s::%s redefined"),
3777 HvNAME_get(GvSTASH((const GV *)dstr)),
3778 GvENAME(MUTABLE_GV(dstr)));
3782 cv_ckproto_len(cv, (const GV *)dstr,
3783 SvPOK(sref) ? SvPVX_const(sref) : NULL,
3784 SvPOK(sref) ? SvCUR(sref) : 0);
3786 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3787 GvASSUMECV_on(dstr);
3788 if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3791 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3792 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3793 GvFLAGS(dstr) |= import_flag;
3795 if (stype == SVt_PVHV) {
3796 const char * const name = GvNAME((GV*)dstr);
3797 const STRLEN len = GvNAMELEN(dstr);
3799 len > 1 && name[len-2] == ':' && name[len-1] == ':'
3800 && (!dref || HvENAME_get(dref))
3803 (HV *)sref, (HV *)dref,
3809 stype == SVt_PVAV && sref != dref
3810 && strEQ(GvNAME((GV*)dstr), "ISA")
3811 /* The stash may have been detached from the symbol table, so
3812 check its name before doing anything. */
3813 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3816 MAGIC * const omg = dref && SvSMAGICAL(dref)
3817 ? mg_find(dref, PERL_MAGIC_isa)
3819 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3820 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3821 AV * const ary = newAV();
3822 av_push(ary, mg->mg_obj); /* takes the refcount */
3823 mg->mg_obj = (SV *)ary;
3826 if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
3827 SV **svp = AvARRAY((AV *)omg->mg_obj);
3828 I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
3832 SvREFCNT_inc_simple_NN(*svp++)
3838 SvREFCNT_inc_simple_NN(omg->mg_obj)
3842 av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
3847 sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
3849 mg = mg_find(sref, PERL_MAGIC_isa);
3851 /* Since the *ISA assignment could have affected more than
3852 one stash, don’t call mro_isa_changed_in directly, but let
3853 magic_clearisa do it for us, as it already has the logic for
3854 dealing with globs vs arrays of globs. */
3856 Perl_magic_clearisa(aTHX_ NULL, mg);
3861 if (SvTAINTED(sstr))
3867 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3870 register U32 sflags;
3872 register svtype stype;
3874 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3879 if (SvIS_FREED(dstr)) {
3880 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3881 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3883 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3885 sstr = &PL_sv_undef;
3886 if (SvIS_FREED(sstr)) {
3887 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3888 (void*)sstr, (void*)dstr);
3890 stype = SvTYPE(sstr);
3891 dtype = SvTYPE(dstr);
3893 (void)SvAMAGIC_off(dstr);
3896 /* need to nuke the magic */
3900 /* There's a lot of redundancy below but we're going for speed here */
3905 if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
3906 (void)SvOK_off(dstr);
3914 sv_upgrade(dstr, SVt_IV);
3918 sv_upgrade(dstr, SVt_PVIV);
3922 goto end_of_first_switch;
3924 (void)SvIOK_only(dstr);
3925 SvIV_set(dstr, SvIVX(sstr));
3928 /* SvTAINTED can only be true if the SV has taint magic, which in
3929 turn means that the SV type is PVMG (or greater). This is the
3930 case statement for SVt_IV, so this cannot be true (whatever gcov
3932 assert(!SvTAINTED(sstr));
3937 if (dtype < SVt_PV && dtype != SVt_IV)
3938 sv_upgrade(dstr, SVt_IV);
3946 sv_upgrade(dstr, SVt_NV);
3950 sv_upgrade(dstr, SVt_PVNV);
3954 goto end_of_first_switch;
3956 SvNV_set(dstr, SvNVX(sstr));
3957 (void)SvNOK_only(dstr);
3958 /* SvTAINTED can only be true if the SV has taint magic, which in
3959 turn means that the SV type is PVMG (or greater). This is the
3960 case statement for SVt_NV, so this cannot be true (whatever gcov
3962 assert(!SvTAINTED(sstr));
3968 #ifdef PERL_OLD_COPY_ON_WRITE
3969 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3970 if (dtype < SVt_PVIV)
3971 sv_upgrade(dstr, SVt_PVIV);
3978 sv_upgrade(dstr, SVt_PV);
3981 if (dtype < SVt_PVIV)
3982 sv_upgrade(dstr, SVt_PVIV);
3985 if (dtype < SVt_PVNV)
3986 sv_upgrade(dstr, SVt_PVNV);
3990 const char * const type = sv_reftype(sstr,0);
3992 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
3994 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3999 if (dtype < SVt_REGEXP)
4000 sv_upgrade(dstr, SVt_REGEXP);
4003 /* case SVt_BIND: */
4006 /* SvVALID means that this PVGV is playing at being an FBM. */
4009 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4011 if (SvTYPE(sstr) != stype)
4012 stype = SvTYPE(sstr);
4014 if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4015 glob_assign_glob(dstr, sstr, dtype);
4018 if (stype == SVt_PVLV)
4019 SvUPGRADE(dstr, SVt_PVNV);
4021 SvUPGRADE(dstr, (svtype)stype);
4023 end_of_first_switch:
4025 /* dstr may have been upgraded. */
4026 dtype = SvTYPE(dstr);
4027 sflags = SvFLAGS(sstr);
4029 if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
4030 /* Assigning to a subroutine sets the prototype. */
4033 const char *const ptr = SvPV_const(sstr, len);
4035 SvGROW(dstr, len + 1);
4036 Copy(ptr, SvPVX(dstr), len + 1, char);
4037 SvCUR_set(dstr, len);
4039 SvFLAGS(dstr) |= sflags & SVf_UTF8;
4043 } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
4044 const char * const type = sv_reftype(dstr,0);
4046 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4048 Perl_croak(aTHX_ "Cannot copy to %s", type);
4049 } else if (sflags & SVf_ROK) {
4050 if (isGV_with_GP(dstr)
4051 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4054 if (GvIMPORTED(dstr) != GVf_IMPORTED
4055 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4057 GvIMPORTED_on(dstr);
4062 glob_assign_glob(dstr, sstr, dtype);
4066 if (dtype >= SVt_PV) {
4067 if (isGV_with_GP(dstr)) {
4068 glob_assign_ref(dstr, sstr);
4071 if (SvPVX_const(dstr)) {
4077 (void)SvOK_off(dstr);
4078 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4079 SvFLAGS(dstr) |= sflags & SVf_ROK;
4080 assert(!(sflags & SVp_NOK));
4081 assert(!(sflags & SVp_IOK));
4082 assert(!(sflags & SVf_NOK));
4083 assert(!(sflags & SVf_IOK));
4085 else if (isGV_with_GP(dstr)) {
4086 if (!(sflags & SVf_OK)) {
4087 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4088 "Undefined value assigned to typeglob");
4091 GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
4092 if (dstr != (const SV *)gv) {
4093 const char * const name = GvNAME((const GV *)dstr);
4094 const STRLEN len = GvNAMELEN(dstr);
4095 HV *old_stash = NULL;
4096 bool reset_isa = FALSE;
4097 if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
4098 /* Set aside the old stash, so we can reset isa caches
4099 on its subclasses. */
4100 if((old_stash = GvHV(dstr))) {
4101 /* Make sure we do not lose it early. */
4102 SvREFCNT_inc_simple_void_NN(
4103 sv_2mortal((SV *)old_stash)
4110 gp_free(MUTABLE_GV(dstr));
4111 GvGP(dstr) = gp_ref(GvGP(gv));
4114 HV * const stash = GvHV(dstr);
4116 old_stash ? (HV *)HvENAME_get(old_stash) : stash
4126 else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
4127 reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4129 else if (sflags & SVp_POK) {
4133 * Check to see if we can just swipe the string. If so, it's a
4134 * possible small lose on short strings, but a big win on long ones.
4135 * It might even be a win on short strings if SvPVX_const(dstr)
4136 * has to be allocated and SvPVX_const(sstr) has to be freed.
4137 * Likewise if we can set up COW rather than doing an actual copy, we
4138 * drop to the else clause, as the swipe code and the COW setup code
4139 * have much in common.
4142 /* Whichever path we take through the next code, we want this true,
4143 and doing it now facilitates the COW check. */
4144 (void)SvPOK_only(dstr);
4147 /* If we're already COW then this clause is not true, and if COW
4148 is allowed then we drop down to the else and make dest COW
4149 with us. If caller hasn't said that we're allowed to COW
4150 shared hash keys then we don't do the COW setup, even if the
4151 source scalar is a shared hash key scalar. */
4152 (((flags & SV_COW_SHARED_HASH_KEYS)
4153 ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4154 : 1 /* If making a COW copy is forbidden then the behaviour we
4155 desire is as if the source SV isn't actually already
4156 COW, even if it is. So we act as if the source flags
4157 are not COW, rather than actually testing them. */
4159 #ifndef PERL_OLD_COPY_ON_WRITE
4160 /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4161 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4162 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4163 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4164 but in turn, it's somewhat dead code, never expected to go
4165 live, but more kept as a placeholder on how to do it better
4166 in a newer implementation. */
4167 /* If we are COW and dstr is a suitable target then we drop down
4168 into the else and make dest a COW of us. */
4169 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4174 (sflags & SVs_TEMP) && /* slated for free anyway? */
4175 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4176 (!(flags & SV_NOSTEAL)) &&
4177 /* and we're allowed to steal temps */
4178 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4179 SvLEN(sstr)) /* and really is a string */
4180 #ifdef PERL_OLD_COPY_ON_WRITE
4181 && ((flags & SV_COW_SHARED_HASH_KEYS)
4182 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4183 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4184 && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4188 /* Failed the swipe test, and it's not a shared hash key either.
4189 Have to copy the string. */
4190 STRLEN len = SvCUR(sstr);
4191 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4192 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4193 SvCUR_set(dstr, len);
4194 *SvEND(dstr) = '\0';
4196 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4198 /* Either it's a shared hash key, or it's suitable for
4199 copy-on-write or we can swipe the string. */
4201 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4205 #ifdef PERL_OLD_COPY_ON_WRITE
4207 if ((sflags & (SVf_FAKE | SVf_READONLY))
4208 != (SVf_FAKE | SVf_READONLY)) {
4209 SvREADONLY_on(sstr);
4211 /* Make the source SV into a loop of 1.
4212 (about to become 2) */
4213 SV_COW_NEXT_SV_SET(sstr, sstr);
4217 /* Initial code is common. */
4218 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4223 /* making another shared SV. */
4224 STRLEN cur = SvCUR(sstr);
4225 STRLEN len = SvLEN(sstr);
4226 #ifdef PERL_OLD_COPY_ON_WRITE
4228 assert (SvTYPE(dstr) >= SVt_PVIV);
4229 /* SvIsCOW_normal */
4230 /* splice us in between source and next-after-source. */
4231 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4232 SV_COW_NEXT_SV_SET(sstr, dstr);
4233 SvPV_set(dstr, SvPVX_mutable(sstr));
4237 /* SvIsCOW_shared_hash */
4238 DEBUG_C(PerlIO_printf(Perl_debug_log,
4239 "Copy on write: Sharing hash\n"));
4241 assert (SvTYPE(dstr) >= SVt_PV);
4243 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4245 SvLEN_set(dstr, len);
4246 SvCUR_set(dstr, cur);
4247 SvREADONLY_on(dstr);
4251 { /* Passes the swipe test. */
4252 SvPV_set(dstr, SvPVX_mutable(sstr));
4253 SvLEN_set(dstr, SvLEN(sstr));
4254 SvCUR_set(dstr, SvCUR(sstr));
4257 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4258 SvPV_set(sstr, NULL);
4264 if (sflags & SVp_NOK) {
4265 SvNV_set(dstr, SvNVX(sstr));
4267 if (sflags & SVp_IOK) {
4268 SvIV_set(dstr, SvIVX(sstr));
4269 /* Must do this otherwise some other overloaded use of 0x80000000
4270 gets confused. I guess SVpbm_VALID */
4271 if (sflags & SVf_IVisUV)
4274 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4276 const MAGIC * const smg = SvVSTRING_mg(sstr);
4278 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4279 smg->mg_ptr, smg->mg_len);
4280 SvRMAGICAL_on(dstr);
4284 else if (sflags & (SVp_IOK|SVp_NOK)) {
4285 (void)SvOK_off(dstr);
4286 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4287 if (sflags & SVp_IOK) {
4288 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4289 SvIV_set(dstr, SvIVX(sstr));
4291 if (sflags & SVp_NOK) {
4292 SvNV_set(dstr, SvNVX(sstr));
4296 if (isGV_with_GP(sstr)) {
4297 /* This stringification rule for globs is spread in 3 places.
4298 This feels bad. FIXME. */
4299 const U32 wasfake = sflags & SVf_FAKE;
4301 /* FAKE globs can get coerced, so need to turn this off
4302 temporarily if it is on. */
4304 gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4305 SvFLAGS(sstr) |= wasfake;
4308 (void)SvOK_off(dstr);
4310 if (SvTAINTED(sstr))
4315 =for apidoc sv_setsv_mg
4317 Like C<sv_setsv>, but also handles 'set' magic.
4323 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4325 PERL_ARGS_ASSERT_SV_SETSV_MG;
4327 sv_setsv(dstr,sstr);
4331 #ifdef PERL_OLD_COPY_ON_WRITE
4333 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4335 STRLEN cur = SvCUR(sstr);
4336 STRLEN len = SvLEN(sstr);
4337 register char *new_pv;
4339 PERL_ARGS_ASSERT_SV_SETSV_COW;
4342 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4343 (void*)sstr, (void*)dstr);
4350 if (SvTHINKFIRST(dstr))
4351 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4352 else if (SvPVX_const(dstr))
4353 Safefree(SvPVX_const(dstr));
4357 SvUPGRADE(dstr, SVt_PVIV);
4359 assert (SvPOK(sstr));
4360 assert (SvPOKp(sstr));
4361 assert (!SvIOK(sstr));
4362 assert (!SvIOKp(sstr));
4363 assert (!SvNOK(sstr));
4364 assert (!SvNOKp(sstr));
4366 if (SvIsCOW(sstr)) {
4368 if (SvLEN(sstr) == 0) {
4369 /* source is a COW shared hash key. */
4370 DEBUG_C(PerlIO_printf(Perl_debug_log,
4371 "Fast copy on write: Sharing hash\n"));
4372 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4375 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4377 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4378 SvUPGRADE(sstr, SVt_PVIV);
4379 SvREADONLY_on(sstr);
4381 DEBUG_C(PerlIO_printf(Perl_debug_log,
4382 "Fast copy on write: Converting sstr to COW\n"));
4383 SV_COW_NEXT_SV_SET(dstr, sstr);
4385 SV_COW_NEXT_SV_SET(sstr, dstr);
4386 new_pv = SvPVX_mutable(sstr);
4389 SvPV_set(dstr, new_pv);
4390 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4393 SvLEN_set(dstr, len);
4394 SvCUR_set(dstr, cur);
4403 =for apidoc sv_setpvn
4405 Copies a string into an SV. The C<len> parameter indicates the number of
4406 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4407 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4413 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4416 register char *dptr;
4418 PERL_ARGS_ASSERT_SV_SETPVN;
4420 SV_CHECK_THINKFIRST_COW_DROP(sv);
4426 /* len is STRLEN which is unsigned, need to copy to signed */
4429 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4431 SvUPGRADE(sv, SVt_PV);
4433 dptr = SvGROW(sv, len + 1);
4434 Move(ptr,dptr,len,char);
4437 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4442 =for apidoc sv_setpvn_mg
4444 Like C<sv_setpvn>, but also handles 'set' magic.
4450 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4452 PERL_ARGS_ASSERT_SV_SETPVN_MG;
4454 sv_setpvn(sv,ptr,len);
4459 =for apidoc sv_setpv
4461 Copies a string into an SV. The string must be null-terminated. Does not
4462 handle 'set' magic. See C<sv_setpv_mg>.
4468 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4471 register STRLEN len;
4473 PERL_ARGS_ASSERT_SV_SETPV;
4475 SV_CHECK_THINKFIRST_COW_DROP(sv);
4481 SvUPGRADE(sv, SVt_PV);
4483 SvGROW(sv, len + 1);
4484 Move(ptr,SvPVX(sv),len+1,char);
4486 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4491 =for apidoc sv_setpv_mg
4493 Like C<sv_setpv>, but also handles 'set' magic.
4499 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4501 PERL_ARGS_ASSERT_SV_SETPV_MG;
4508 =for apidoc sv_usepvn_flags
4510 Tells an SV to use C<ptr> to find its string value. Normally the
4511 string is stored inside the SV but sv_usepvn allows the SV to use an
4512 outside string. The C<ptr> should point to memory that was allocated
4513 by C<malloc>. The string length, C<len>, must be supplied. By default
4514 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4515 so that pointer should not be freed or used by the programmer after
4516 giving it to sv_usepvn, and neither should any pointers from "behind"
4517 that pointer (e.g. ptr + 1) be used.
4519 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4520 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4521 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4522 C<len>, and already meets the requirements for storing in C<SvPVX>)
4528 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4533 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4535 SV_CHECK_THINKFIRST_COW_DROP(sv);
4536 SvUPGRADE(sv, SVt_PV);
4539 if (flags & SV_SMAGIC)
4543 if (SvPVX_const(sv))
4547 if (flags & SV_HAS_TRAILING_NUL)
4548 assert(ptr[len] == '\0');
4551 allocate = (flags & SV_HAS_TRAILING_NUL)
4553 #ifdef Perl_safesysmalloc_size
4556 PERL_STRLEN_ROUNDUP(len + 1);
4558 if (flags & SV_HAS_TRAILING_NUL) {
4559 /* It's long enough - do nothing.
4560 Specfically Perl_newCONSTSUB is relying on this. */
4563 /* Force a move to shake out bugs in callers. */
4564 char *new_ptr = (char*)safemalloc(allocate);
4565 Copy(ptr, new_ptr, len, char);
4566 PoisonFree(ptr,len,char);
4570 ptr = (char*) saferealloc (ptr, allocate);
4573 #ifdef Perl_safesysmalloc_size
4574 SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4576 SvLEN_set(sv, allocate);
4580 if (!(flags & SV_HAS_TRAILING_NUL)) {
4583 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4585 if (flags & SV_SMAGIC)
4589 #ifdef PERL_OLD_COPY_ON_WRITE
4590 /* Need to do this *after* making the SV normal, as we need the buffer
4591 pointer to remain valid until after we've copied it. If we let go too early,
4592 another thread could invalidate it by unsharing last of the same hash key
4593 (which it can do by means other than releasing copy-on-write Svs)
4594 or by changing the other copy-on-write SVs in the loop. */
4596 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4598 PERL_ARGS_ASSERT_SV_RELEASE_COW;
4600 { /* this SV was SvIsCOW_normal(sv) */
4601 /* we need to find the SV pointing to us. */
4602 SV *current = SV_COW_NEXT_SV(after);
4604 if (current == sv) {
4605 /* The SV we point to points back to us (there were only two of us
4607 Hence other SV is no longer copy on write either. */
4609 SvREADONLY_off(after);
4611 /* We need to follow the pointers around the loop. */
4613 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4616 /* don't loop forever if the structure is bust, and we have
4617 a pointer into a closed loop. */
4618 assert (current != after);
4619 assert (SvPVX_const(current) == pvx);
4621 /* Make the SV before us point to the SV after us. */
4622 SV_COW_NEXT_SV_SET(current, after);
4628 =for apidoc sv_force_normal_flags
4630 Undo various types of fakery on an SV: if the PV is a shared string, make
4631 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4632 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4633 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4634 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4635 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4636 set to some other value.) In addition, the C<flags> parameter gets passed to
4637 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4638 with flags set to 0.
4644 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4648 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4650 #ifdef PERL_OLD_COPY_ON_WRITE
4651 if (SvREADONLY(sv)) {
4653 const char * const pvx = SvPVX_const(sv);
4654 const STRLEN len = SvLEN(sv);
4655 const STRLEN cur = SvCUR(sv);
4656 /* next COW sv in the loop. If len is 0 then this is a shared-hash
4657 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4658 we'll fail an assertion. */
4659 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4662 PerlIO_printf(Perl_debug_log,
4663 "Copy on write: Force normal %ld\n",
4669 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4672 if (flags & SV_COW_DROP_PV) {
4673 /* OK, so we don't need to copy our buffer. */
4676 SvGROW(sv, cur + 1);
4677 Move(pvx,SvPVX(sv),cur,char);
4682 sv_release_COW(sv, pvx, next);
4684 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4690 else if (IN_PERL_RUNTIME)
4691 Perl_croak_no_modify(aTHX);
4694 if (SvREADONLY(sv)) {
4696 const char * const pvx = SvPVX_const(sv);
4697 const STRLEN len = SvCUR(sv);
4702 SvGROW(sv, len + 1);
4703 Move(pvx,SvPVX(sv),len,char);
4705 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4707 else if (IN_PERL_RUNTIME)
4708 Perl_croak_no_modify(aTHX);
4712 sv_unref_flags(sv, flags);
4713 else if (SvFAKE(sv) && isGV_with_GP(sv))
4715 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
4716 /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous
4717 to sv_unglob. We only need it here, so inline it. */
4718 const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
4719 SV *const temp = newSV_type(new_type);
4720 void *const temp_p = SvANY(sv);
4722 if (new_type == SVt_PVMG) {
4723 SvMAGIC_set(temp, SvMAGIC(sv));
4724 SvMAGIC_set(sv, NULL);
4725 SvSTASH_set(temp, SvSTASH(sv));
4726 SvSTASH_set(sv, NULL);
4728 SvCUR_set(temp, SvCUR(sv));
4729 /* Remember that SvPVX is in the head, not the body. */
4731 SvLEN_set(temp, SvLEN(sv));
4732 /* This signals "buffer is owned by someone else" in sv_clear,
4733 which is the least effort way to stop it freeing the buffer.
4735 SvLEN_set(sv, SvLEN(sv)+1);
4737 /* Their buffer is already owned by someone else. */
4738 SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
4739 SvLEN_set(temp, SvCUR(sv)+1);
4742 /* Now swap the rest of the bodies. */
4744 SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
4745 SvFLAGS(sv) |= new_type;
4746 SvANY(sv) = SvANY(temp);
4748 SvFLAGS(temp) &= ~(SVTYPEMASK);
4749 SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
4750 SvANY(temp) = temp_p;
4759 Efficient removal of characters from the beginning of the string buffer.
4760 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4761 the string buffer. The C<ptr> becomes the first character of the adjusted
4762 string. Uses the "OOK hack".
4763 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4764 refer to the same chunk of data.
4770 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4776 const U8 *real_start;
4780 PERL_ARGS_ASSERT_SV_CHOP;
4782 if (!ptr || !SvPOKp(sv))
4784 delta = ptr - SvPVX_const(sv);
4786 /* Nothing to do. */
4789 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4790 nothing uses the value of ptr any more. */
4791 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4792 if (ptr <= SvPVX_const(sv))
4793 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4794 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4795 SV_CHECK_THINKFIRST(sv);
4796 if (delta > max_delta)
4797 Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4798 SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4799 SvPVX_const(sv) + max_delta);
4802 if (!SvLEN(sv)) { /* make copy of shared string */
4803 const char *pvx = SvPVX_const(sv);
4804 const STRLEN len = SvCUR(sv);
4805 SvGROW(sv, len + 1);
4806 Move(pvx,SvPVX(sv),len,char);
4809 SvFLAGS(sv) |= SVf_OOK;
4812 SvOOK_offset(sv, old_delta);
4814 SvLEN_set(sv, SvLEN(sv) - delta);
4815 SvCUR_set(sv, SvCUR(sv) - delta);
4816 SvPV_set(sv, SvPVX(sv) + delta);
4818 p = (U8 *)SvPVX_const(sv);
4823 real_start = p - delta;
4827 if (delta < 0x100) {
4831 p -= sizeof(STRLEN);
4832 Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4836 /* Fill the preceding buffer with sentinals to verify that no-one is
4838 while (p > real_start) {
4846 =for apidoc sv_catpvn
4848 Concatenates the string onto the end of the string which is in the SV. The
4849 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4850 status set, then the bytes appended should be valid UTF-8.
4851 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4853 =for apidoc sv_catpvn_flags
4855 Concatenates the string onto the end of the string which is in the SV. The
4856 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4857 status set, then the bytes appended should be valid UTF-8.
4858 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4859 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4860 in terms of this function.
4866 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4870 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4872 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4874 SvGROW(dsv, dlen + slen + 1);
4876 sstr = SvPVX_const(dsv);
4877 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4878 SvCUR_set(dsv, SvCUR(dsv) + slen);
4880 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4882 if (flags & SV_SMAGIC)
4887 =for apidoc sv_catsv
4889 Concatenates the string from SV C<ssv> onto the end of the string in
4890 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4891 not 'set' magic. See C<sv_catsv_mg>.
4893 =for apidoc sv_catsv_flags
4895 Concatenates the string from SV C<ssv> onto the end of the string in
4896 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4897 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4898 and C<sv_catsv_nomg> are implemented in terms of this function.
4903 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4907 PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4911 const char *spv = SvPV_flags_const(ssv, slen, flags);
4913 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4914 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4915 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4916 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4917 dsv->sv_flags doesn't have that bit set.
4918 Andy Dougherty 12 Oct 2001
4920 const I32 sutf8 = DO_UTF8(ssv);
4923 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4925 dutf8 = DO_UTF8(dsv);
4927 if (dutf8 != sutf8) {
4929 /* Not modifying source SV, so taking a temporary copy. */
4930 SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4932 sv_utf8_upgrade(csv);
4933 spv = SvPV_const(csv, slen);
4936 /* Leave enough space for the cat that's about to happen */
4937 sv_utf8_upgrade_flags_grow(dsv, 0, slen);
4939 sv_catpvn_nomg(dsv, spv, slen);
4942 if (flags & SV_SMAGIC)
4947 =for apidoc sv_catpv
4949 Concatenates the string onto the end of the string which is in the SV.
4950 If the SV has the UTF-8 status set, then the bytes appended should be
4951 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4956 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4959 register STRLEN len;
4963 PERL_ARGS_ASSERT_SV_CATPV;
4967 junk = SvPV_force(sv, tlen);
4969 SvGROW(sv, tlen + len + 1);
4971 ptr = SvPVX_const(sv);
4972 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4973 SvCUR_set(sv, SvCUR(sv) + len);
4974 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4979 =for apidoc sv_catpv_flags
4981 Concatenates the string onto the end of the string which is in the SV.
4982 If the SV has the UTF-8 status set, then the bytes appended should
4983 be valid UTF-8. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get>
4984 on the SVs if appropriate, else not.
4990 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
4992 PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
4993 sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
4997 =for apidoc sv_catpv_mg
4999 Like C<sv_catpv>, but also handles 'set' magic.
5005 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
5007 PERL_ARGS_ASSERT_SV_CATPV_MG;
5016 Creates a new SV. A non-zero C<len> parameter indicates the number of
5017 bytes of preallocated string space the SV should have. An extra byte for a
5018 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
5019 space is allocated.) The reference count for the new SV is set to 1.
5021 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
5022 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5023 This aid has been superseded by a new build option, PERL_MEM_LOG (see
5024 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
5025 modules supporting older perls.
5031 Perl_newSV(pTHX_ const STRLEN len)
5038 sv_upgrade(sv, SVt_PV);
5039 SvGROW(sv, len + 1);
5044 =for apidoc sv_magicext
5046 Adds magic to an SV, upgrading it if necessary. Applies the
5047 supplied vtable and returns a pointer to the magic added.
5049 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5050 In particular, you can add magic to SvREADONLY SVs, and add more than
5051 one instance of the same 'how'.
5053 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5054 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5055 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5056 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5058 (This is now used as a subroutine by C<sv_magic>.)
5063 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
5064 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5069 PERL_ARGS_ASSERT_SV_MAGICEXT;
5071 SvUPGRADE(sv, SVt_PVMG);
5072 Newxz(mg, 1, MAGIC);
5073 mg->mg_moremagic = SvMAGIC(sv);
5074 SvMAGIC_set(sv, mg);
5076 /* Sometimes a magic contains a reference loop, where the sv and
5077 object refer to each other. To prevent a reference loop that
5078 would prevent such objects being freed, we look for such loops
5079 and if we find one we avoid incrementing the object refcount.
5081 Note we cannot do this to avoid self-tie loops as intervening RV must
5082 have its REFCNT incremented to keep it in existence.
5085 if (!obj || obj == sv ||
5086 how == PERL_MAGIC_arylen ||
5087 how == PERL_MAGIC_symtab ||
5088 (SvTYPE(obj) == SVt_PVGV &&
5089 (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5090 || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5091 || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5096 mg->mg_obj = SvREFCNT_inc_simple(obj);
5097 mg->mg_flags |= MGf_REFCOUNTED;
5100 /* Normal self-ties simply pass a null object, and instead of
5101 using mg_obj directly, use the SvTIED_obj macro to produce a
5102 new RV as needed. For glob "self-ties", we are tieing the PVIO
5103 with an RV obj pointing to the glob containing the PVIO. In
5104 this case, to avoid a reference loop, we need to weaken the
5108 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5109 obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5115 mg->mg_len = namlen;
5118 mg->mg_ptr = savepvn(name, namlen);
5119 else if (namlen == HEf_SVKEY) {
5120 /* Yes, this is casting away const. This is only for the case of
5121 HEf_SVKEY. I think we need to document this abberation of the
5122 constness of the API, rather than making name non-const, as
5123 that change propagating outwards a long way. */
5124 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5126 mg->mg_ptr = (char *) name;
5128 mg->mg_virtual = (MGVTBL *) vtable;
5132 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5137 =for apidoc sv_magic
5139 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5140 then adds a new magic item of type C<how> to the head of the magic list.
5142 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5143 handling of the C<name> and C<namlen> arguments.
5145 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5146 to add more than one instance of the same 'how'.
5152 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
5153 const char *const name, const I32 namlen)
5156 const MGVTBL *vtable;
5159 PERL_ARGS_ASSERT_SV_MAGIC;
5161 #ifdef PERL_OLD_COPY_ON_WRITE
5163 sv_force_normal_flags(sv, 0);
5165 if (SvREADONLY(sv)) {
5167 /* its okay to attach magic to shared strings; the subsequent
5168 * upgrade to PVMG will unshare the string */
5169 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
5172 && how != PERL_MAGIC_regex_global
5173 && how != PERL_MAGIC_bm
5174 && how != PERL_MAGIC_fm
5175 && how != PERL_MAGIC_sv
5176 && how != PERL_MAGIC_backref
5179 Perl_croak_no_modify(aTHX);
5182 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5183 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5184 /* sv_magic() refuses to add a magic of the same 'how' as an
5187 if (how == PERL_MAGIC_taint) {
5189 /* Any scalar which already had taint magic on which someone
5190 (erroneously?) did SvIOK_on() or similar will now be
5191 incorrectly sporting public "OK" flags. */
5192 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5200 vtable = &PL_vtbl_sv;
5202 case PERL_MAGIC_overload:
5203 vtable = &PL_vtbl_amagic;
5205 case PERL_MAGIC_overload_elem:
5206 vtable = &PL_vtbl_amagicelem;
5208 case PERL_MAGIC_overload_table:
5209 vtable = &PL_vtbl_ovrld;
5212 vtable = &PL_vtbl_bm;
5214 case PERL_MAGIC_regdata:
5215 vtable = &PL_vtbl_regdata;
5217 case PERL_MAGIC_regdatum:
5218 vtable = &PL_vtbl_regdatum;
5220 case PERL_MAGIC_env:
5221 vtable = &PL_vtbl_env;
5224 vtable = &PL_vtbl_fm;
5226 case PERL_MAGIC_envelem:
5227 vtable = &PL_vtbl_envelem;
5229 case PERL_MAGIC_regex_global:
5230 vtable = &PL_vtbl_mglob;
5232 case PERL_MAGIC_isa:
5233 vtable = &PL_vtbl_isa;
5235 case PERL_MAGIC_isaelem:
5236 vtable = &PL_vtbl_isaelem;
5238 case PERL_MAGIC_nkeys:
5239 vtable = &PL_vtbl_nkeys;
5241 case PERL_MAGIC_dbfile:
5244 case PERL_MAGIC_dbline:
5245 vtable = &PL_vtbl_dbline;
5247 #ifdef USE_LOCALE_COLLATE
5248 case PERL_MAGIC_collxfrm:
5249 vtable = &PL_vtbl_collxfrm;
5251 #endif /* USE_LOCALE_COLLATE */
5252 case PERL_MAGIC_tied:
5253 vtable = &PL_vtbl_pack;
5255 case PERL_MAGIC_tiedelem:
5256 case PERL_MAGIC_tiedscalar:
5257 vtable = &PL_vtbl_packelem;
5260 vtable = &PL_vtbl_regexp;
5262 case PERL_MAGIC_sig:
5263 vtable = &PL_vtbl_sig;
5265 case PERL_MAGIC_sigelem:
5266 vtable = &PL_vtbl_sigelem;
5268 case PERL_MAGIC_taint:
5269 vtable = &PL_vtbl_taint;
5271 case PERL_MAGIC_uvar:
5272 vtable = &PL_vtbl_uvar;
5274 case PERL_MAGIC_vec:
5275 vtable = &PL_vtbl_vec;
5277 case PERL_MAGIC_arylen_p:
5278 case PERL_MAGIC_rhash:
5279 case PERL_MAGIC_symtab:
5280 case PERL_MAGIC_vstring:
5281 case PERL_MAGIC_checkcall:
5284 case PERL_MAGIC_utf8:
5285 vtable = &PL_vtbl_utf8;
5287 case PERL_MAGIC_substr:
5288 vtable = &PL_vtbl_substr;
5290 case PERL_MAGIC_defelem:
5291 vtable = &PL_vtbl_defelem;
5293 case PERL_MAGIC_arylen:
5294 vtable = &PL_vtbl_arylen;
5296 case PERL_MAGIC_pos:
5297 vtable = &PL_vtbl_pos;
5299 case PERL_MAGIC_backref:
5300 vtable = &PL_vtbl_backref;
5302 case PERL_MAGIC_hintselem:
5303 vtable = &PL_vtbl_hintselem;
5305 case PERL_MAGIC_hints:
5306 vtable = &PL_vtbl_hints;
5308 case PERL_MAGIC_ext:
5309 /* Reserved for use by extensions not perl internals. */
5310 /* Useful for attaching extension internal data to perl vars. */
5311 /* Note that multiple extensions may clash if magical scalars */
5312 /* etc holding private data from one are passed to another. */
5316 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5319 /* Rest of work is done else where */
5320 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5323 case PERL_MAGIC_taint:
5326 case PERL_MAGIC_ext:
5327 case PERL_MAGIC_dbfile:
5334 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
5341 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5343 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5344 for (mg = *mgp; mg; mg = *mgp) {
5345 const MGVTBL* const virt = mg->mg_virtual;
5346 if (mg->mg_type == type && (!flags || virt == vtbl)) {
5347 *mgp = mg->mg_moremagic;
5348 if (virt && virt->svt_free)
5349 virt->svt_free(aTHX_ sv, mg);
5350 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5352 Safefree(mg->mg_ptr);
5353 else if (mg->mg_len == HEf_SVKEY)
5354 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5355 else if (mg->mg_type == PERL_MAGIC_utf8)
5356 Safefree(mg->mg_ptr);
5358 if (mg->mg_flags & MGf_REFCOUNTED)
5359 SvREFCNT_dec(mg->mg_obj);
5363 mgp = &mg->mg_moremagic;
5366 if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
5367 mg_magical(sv); /* else fix the flags now */
5371 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5377 =for apidoc sv_unmagic
5379 Removes all magic of type C<type> from an SV.
5385 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5387 PERL_ARGS_ASSERT_SV_UNMAGIC;
5388 return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5392 =for apidoc sv_unmagicext
5394 Removes all magic of type C<type> with the specified C<vtbl> from an SV.
5400 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
5402 PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5403 return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5407 =for apidoc sv_rvweaken
5409 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5410 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5411 push a back-reference to this RV onto the array of backreferences
5412 associated with that magic. If the RV is magical, set magic will be
5413 called after the RV is cleared.
5419 Perl_sv_rvweaken(pTHX_ SV *const sv)
5423 PERL_ARGS_ASSERT_SV_RVWEAKEN;
5425 if (!SvOK(sv)) /* let undefs pass */
5428 Perl_croak(aTHX_ "Can't weaken a nonreference");
5429 else if (SvWEAKREF(sv)) {
5430 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5434 Perl_sv_add_backref(aTHX_ tsv, sv);
5440 /* Give tsv backref magic if it hasn't already got it, then push a
5441 * back-reference to sv onto the array associated with the backref magic.
5443 * As an optimisation, if there's only one backref and it's not an AV,
5444 * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5445 * allocate an AV. (Whether the slot holds an AV tells us whether this is
5448 * If an HV's backref is stored in magic, it is moved back to HvAUX.
5451 /* A discussion about the backreferences array and its refcount:
5453 * The AV holding the backreferences is pointed to either as the mg_obj of
5454 * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
5455 * structure, from the xhv_backreferences field. (A HV without hv_aux will
5456 * have the standard magic instead.) The array is created with a refcount
5457 * of 2. This means that if during global destruction the array gets
5458 * picked on before its parent to have its refcount decremented by the
5459 * random zapper, it won't actually be freed, meaning it's still there for
5460 * when its parent gets freed.
5462 * When the parent SV is freed, the extra ref is killed by
5463 * Perl_sv_kill_backrefs. The other ref is killed, in the case of magic,
5464 * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5466 * When a single backref SV is stored directly, it is not reference
5471 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5478 PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5480 /* find slot to store array or singleton backref */
5482 if (SvTYPE(tsv) == SVt_PVHV) {
5483 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5486 if ((mg = mg_find(tsv, PERL_MAGIC_backref))) {
5487 /* Aha. They've got it stowed in magic instead.
5488 * Move it back to xhv_backreferences */
5490 /* Stop mg_free decreasing the reference count. */
5492 /* Stop mg_free even calling the destructor, given that
5493 there's no AV to free up. */
5495 sv_unmagic(tsv, PERL_MAGIC_backref);
5501 (SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
5503 sv_magic(tsv, NULL, PERL_MAGIC_backref, NULL, 0);
5504 mg = mg_find(tsv, PERL_MAGIC_backref);
5506 svp = &(mg->mg_obj);
5509 /* create or retrieve the array */
5511 if ( (!*svp && SvTYPE(sv) == SVt_PVAV)
5512 || (*svp && SvTYPE(*svp) != SVt_PVAV)
5517 SvREFCNT_inc_simple_void(av);
5518 /* av now has a refcnt of 2; see discussion above */
5520 /* move single existing backref to the array */
5522 AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5526 mg->mg_flags |= MGf_REFCOUNTED;
5529 av = MUTABLE_AV(*svp);
5532 /* optimisation: store single backref directly in HvAUX or mg_obj */
5536 /* push new backref */
5537 assert(SvTYPE(av) == SVt_PVAV);
5538 if (AvFILLp(av) >= AvMAX(av)) {
5539 av_extend(av, AvFILLp(av)+1);
5541 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5544 /* delete a back-reference to ourselves from the backref magic associated
5545 * with the SV we point to.
5549 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5554 PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5556 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5557 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5559 if (!svp || !*svp) {
5561 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5562 svp = mg ? &(mg->mg_obj) : NULL;
5566 Perl_croak(aTHX_ "panic: del_backref");
5568 if (SvTYPE(*svp) == SVt_PVAV) {
5572 AV * const av = (AV*)*svp;
5574 assert(!SvIS_FREED(av));
5578 /* for an SV with N weak references to it, if all those
5579 * weak refs are deleted, then sv_del_backref will be called
5580 * N times and O(N^2) compares will be done within the backref
5581 * array. To ameliorate this potential slowness, we:
5582 * 1) make sure this code is as tight as possible;
5583 * 2) when looking for SV, look for it at both the head and tail of the
5584 * array first before searching the rest, since some create/destroy
5585 * patterns will cause the backrefs to be freed in order.
5592 SV **p = &svp[fill];
5593 SV *const topsv = *p;
5600 /* We weren't the last entry.
5601 An unordered list has this property that you
5602 can take the last element off the end to fill
5603 the hole, and it's still an unordered list :-)
5609 break; /* should only be one */
5616 AvFILLp(av) = fill-1;
5619 /* optimisation: only a single backref, stored directly */
5621 Perl_croak(aTHX_ "panic: del_backref");
5628 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5634 PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5639 is_array = (SvTYPE(av) == SVt_PVAV);
5641 assert(!SvIS_FREED(av));
5644 last = svp + AvFILLp(av);
5647 /* optimisation: only a single backref, stored directly */
5653 while (svp <= last) {
5655 SV *const referrer = *svp;
5656 if (SvWEAKREF(referrer)) {
5657 /* XXX Should we check that it hasn't changed? */
5658 assert(SvROK(referrer));
5659 SvRV_set(referrer, 0);
5661 SvWEAKREF_off(referrer);
5662 SvSETMAGIC(referrer);
5663 } else if (SvTYPE(referrer) == SVt_PVGV ||
5664 SvTYPE(referrer) == SVt_PVLV) {
5665 assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
5666 /* You lookin' at me? */
5667 assert(GvSTASH(referrer));
5668 assert(GvSTASH(referrer) == (const HV *)sv);
5669 GvSTASH(referrer) = 0;
5670 } else if (SvTYPE(referrer) == SVt_PVCV ||
5671 SvTYPE(referrer) == SVt_PVFM) {
5672 if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
5673 /* You lookin' at me? */
5674 assert(CvSTASH(referrer));
5675 assert(CvSTASH(referrer) == (const HV *)sv);
5676 SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
5679 assert(SvTYPE(sv) == SVt_PVGV);
5680 /* You lookin' at me? */
5681 assert(CvGV(referrer));
5682 assert(CvGV(referrer) == (const GV *)sv);
5683 anonymise_cv_maybe(MUTABLE_GV(sv),
5684 MUTABLE_CV(referrer));
5689 "panic: magic_killbackrefs (flags=%"UVxf")",
5690 (UV)SvFLAGS(referrer));
5701 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5707 =for apidoc sv_insert
5709 Inserts a string at the specified offset/length within the SV. Similar to
5710 the Perl substr() function. Handles get magic.
5712 =for apidoc sv_insert_flags
5714 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5720 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5725 register char *midend;
5726 register char *bigend;
5730 PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5733 Perl_croak(aTHX_ "Can't modify non-existent substring");
5734 SvPV_force_flags(bigstr, curlen, flags);
5735 (void)SvPOK_only_UTF8(bigstr);
5736 if (offset + len > curlen) {
5737 SvGROW(bigstr, offset+len+1);
5738 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5739 SvCUR_set(bigstr, offset+len);
5743 i = littlelen - len;
5744 if (i > 0) { /* string might grow */
5745 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5746 mid = big + offset + len;
5747 midend = bigend = big + SvCUR(bigstr);
5750 while (midend > mid) /* shove everything down */
5751 *--bigend = *--midend;
5752 Move(little,big+offset,littlelen,char);
5753 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5758 Move(little,SvPVX(bigstr)+offset,len,char);
5763 big = SvPVX(bigstr);
5766 bigend = big + SvCUR(bigstr);
5768 if (midend > bigend)
5769 Perl_croak(aTHX_ "panic: sv_insert");
5771 if (mid - big > bigend - midend) { /* faster to shorten from end */
5773 Move(little, mid, littlelen,char);
5776 i = bigend - midend;
5778 Move(midend, mid, i,char);
5782 SvCUR_set(bigstr, mid - big);
5784 else if ((i = mid - big)) { /* faster from front */
5785 midend -= littlelen;
5787 Move(big, midend - i, i, char);
5788 sv_chop(bigstr,midend-i);
5790 Move(little, mid, littlelen,char);
5792 else if (littlelen) {
5793 midend -= littlelen;
5794 sv_chop(bigstr,midend);
5795 Move(little,midend,littlelen,char);
5798 sv_chop(bigstr,midend);
5804 =for apidoc sv_replace
5806 Make the first argument a copy of the second, then delete the original.
5807 The target SV physically takes over ownership of the body of the source SV
5808 and inherits its flags; however, the target keeps any magic it owns,
5809 and any magic in the source is discarded.
5810 Note that this is a rather specialist SV copying operation; most of the
5811 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5817 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5820 const U32 refcnt = SvREFCNT(sv);
5822 PERL_ARGS_ASSERT_SV_REPLACE;
5824 SV_CHECK_THINKFIRST_COW_DROP(sv);
5825 if (SvREFCNT(nsv) != 1) {
5826 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
5827 " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
5829 if (SvMAGICAL(sv)) {
5833 sv_upgrade(nsv, SVt_PVMG);
5834 SvMAGIC_set(nsv, SvMAGIC(sv));
5835 SvFLAGS(nsv) |= SvMAGICAL(sv);
5837 SvMAGIC_set(sv, NULL);
5841 assert(!SvREFCNT(sv));
5842 #ifdef DEBUG_LEAKING_SCALARS
5843 sv->sv_flags = nsv->sv_flags;
5844 sv->sv_any = nsv->sv_any;
5845 sv->sv_refcnt = nsv->sv_refcnt;
5846 sv->sv_u = nsv->sv_u;
5848 StructCopy(nsv,sv,SV);
5850 if(SvTYPE(sv) == SVt_IV) {
5852 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5856 #ifdef PERL_OLD_COPY_ON_WRITE
5857 if (SvIsCOW_normal(nsv)) {
5858 /* We need to follow the pointers around the loop to make the
5859 previous SV point to sv, rather than nsv. */
5862 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5865 assert(SvPVX_const(current) == SvPVX_const(nsv));
5867 /* Make the SV before us point to the SV after us. */
5869 PerlIO_printf(Perl_debug_log, "previous is\n");
5871 PerlIO_printf(Perl_debug_log,
5872 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5873 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5875 SV_COW_NEXT_SV_SET(current, sv);
5878 SvREFCNT(sv) = refcnt;
5879 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5884 /* We're about to free a GV which has a CV that refers back to us.
5885 * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
5889 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
5895 PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
5898 assert(SvREFCNT(gv) == 0);
5899 assert(isGV(gv) && isGV_with_GP(gv));
5901 assert(!CvANON(cv));
5902 assert(CvGV(cv) == gv);
5904 /* will the CV shortly be freed by gp_free() ? */
5905 if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
5906 SvANY(cv)->xcv_gv = NULL;
5910 /* if not, anonymise: */
5911 stash = GvSTASH(gv) ? HvNAME(GvSTASH(gv)) : NULL;
5912 gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
5913 stash ? stash : "__ANON__");
5914 anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
5915 SvREFCNT_dec(gvname);
5919 SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
5924 =for apidoc sv_clear
5926 Clear an SV: call any destructors, free up any memory used by the body,
5927 and free the body itself. The SV's head is I<not> freed, although
5928 its type is set to all 1's so that it won't inadvertently be assumed
5929 to be live during global destruction etc.
5930 This function should only be called when REFCNT is zero. Most of the time
5931 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5938 Perl_sv_clear(pTHX_ SV *const orig_sv)
5943 const struct body_details *sv_type_details;
5946 register SV *sv = orig_sv;
5948 PERL_ARGS_ASSERT_SV_CLEAR;
5950 /* within this loop, sv is the SV currently being freed, and
5951 * iter_sv is the most recent AV or whatever that's being iterated
5952 * over to provide more SVs */
5958 assert(SvREFCNT(sv) == 0);
5959 assert(SvTYPE(sv) != SVTYPEMASK);
5961 if (type <= SVt_IV) {
5962 /* See the comment in sv.h about the collusion between this
5963 * early return and the overloading of the NULL slots in the
5967 SvFLAGS(sv) &= SVf_BREAK;
5968 SvFLAGS(sv) |= SVTYPEMASK;
5973 if (PL_defstash && /* Still have a symbol table? */
5980 stash = SvSTASH(sv);
5981 destructor = StashHANDLER(stash,DESTROY);
5983 /* A constant subroutine can have no side effects, so
5984 don't bother calling it. */
5985 && !CvCONST(destructor)
5986 /* Don't bother calling an empty destructor */
5987 && (CvISXSUB(destructor)
5988 || (CvSTART(destructor)
5989 && (CvSTART(destructor)->op_next->op_type
5992 SV* const tmpref = newRV(sv);
5993 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5995 PUSHSTACKi(PERLSI_DESTROY);
6000 call_sv(MUTABLE_SV(destructor),
6001 G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
6005 if(SvREFCNT(tmpref) < 2) {
6006 /* tmpref is not kept alive! */
6008 SvRV_set(tmpref, NULL);
6011 SvREFCNT_dec(tmpref);
6013 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
6017 if (PL_in_clean_objs)
6019 "DESTROY created new reference to dead object '%s'",
6021 /* DESTROY gave object new lease on life */
6027 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
6028 SvOBJECT_off(sv); /* Curse the object. */
6029 if (type != SVt_PVIO)
6030 --PL_sv_objcount;/* XXX Might want something more general */
6033 if (type >= SVt_PVMG) {
6034 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
6035 SvREFCNT_dec(SvOURSTASH(sv));
6036 } else if (SvMAGIC(sv))
6038 if (type == SVt_PVMG && SvPAD_TYPED(sv))
6039 SvREFCNT_dec(SvSTASH(sv));
6042 /* case SVt_BIND: */
6045 IoIFP(sv) != PerlIO_stdin() &&
6046 IoIFP(sv) != PerlIO_stdout() &&
6047 IoIFP(sv) != PerlIO_stderr() &&
6048 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6050 io_close(MUTABLE_IO(sv), FALSE);
6052 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6053 PerlDir_close(IoDIRP(sv));
6054 IoDIRP(sv) = (DIR*)NULL;
6055 Safefree(IoTOP_NAME(sv));
6056 Safefree(IoFMT_NAME(sv));
6057 Safefree(IoBOTTOM_NAME(sv));
6060 /* FIXME for plugins */
6061 pregfree2((REGEXP*) sv);
6065 cv_undef(MUTABLE_CV(sv));
6066 /* If we're in a stash, we don't own a reference to it.
6067 * However it does have a back reference to us, which needs to
6069 if ((stash = CvSTASH(sv)))
6070 sv_del_backref(MUTABLE_SV(stash), sv);
6073 if (PL_last_swash_hv == (const HV *)sv) {
6074 PL_last_swash_hv = NULL;
6076 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6077 Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6081 AV* av = MUTABLE_AV(sv);
6082 if (PL_comppad == av) {
6086 if (AvREAL(av) && AvFILLp(av) > -1) {
6087 next_sv = AvARRAY(av)[AvFILLp(av)--];
6088 /* save old iter_sv in top-most slot of AV,
6089 * and pray that it doesn't get wiped in the meantime */
6090 AvARRAY(av)[AvMAX(av)] = iter_sv;
6092 goto get_next_sv; /* process this new sv */
6094 Safefree(AvALLOC(av));
6099 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
6100 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
6101 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
6102 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
6104 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
6105 SvREFCNT_dec(LvTARG(sv));
6107 if (isGV_with_GP(sv)) {
6108 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
6109 && HvENAME_get(stash))
6110 mro_method_changed_in(stash);
6111 gp_free(MUTABLE_GV(sv));
6113 unshare_hek(GvNAME_HEK(sv));
6114 /* If we're in a stash, we don't own a reference to it.
6115 * However it does have a back reference to us, which
6116 * needs to be cleared. */
6117 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
6118 sv_del_backref(MUTABLE_SV(stash), sv);
6120 /* FIXME. There are probably more unreferenced pointers to SVs
6121 * in the interpreter struct that we should check and tidy in
6122 * a similar fashion to this: */
6123 if ((const GV *)sv == PL_last_in_gv)
6124 PL_last_in_gv = NULL;
6130 /* Don't bother with SvOOK_off(sv); as we're only going to
6134 SvOOK_offset(sv, offset);
6135 SvPV_set(sv, SvPVX_mutable(sv) - offset);
6136 /* Don't even bother with turning off the OOK flag. */
6141 SV * const target = SvRV(sv);
6143 sv_del_backref(target, sv);
6148 #ifdef PERL_OLD_COPY_ON_WRITE
6149 else if (SvPVX_const(sv)
6150 && !(SvTYPE(sv) == SVt_PVIO
6151 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6155 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6159 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
6161 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6165 } else if (SvLEN(sv)) {
6166 Safefree(SvPVX_const(sv));
6170 else if (SvPVX_const(sv) && SvLEN(sv)
6171 && !(SvTYPE(sv) == SVt_PVIO
6172 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6173 Safefree(SvPVX_mutable(sv));
6174 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
6175 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6186 SvFLAGS(sv) &= SVf_BREAK;
6187 SvFLAGS(sv) |= SVTYPEMASK;
6189 sv_type_details = bodies_by_type + type;
6190 if (sv_type_details->arena) {
6191 del_body(((char *)SvANY(sv) + sv_type_details->offset),
6192 &PL_body_roots[type]);
6194 else if (sv_type_details->body_size) {
6195 safefree(SvANY(sv));
6199 /* caller is responsible for freeing the head of the original sv */
6200 if (sv != orig_sv && !SvREFCNT(sv))
6203 /* grab and free next sv, if any */
6211 else if (!iter_sv) {
6213 } else if (SvTYPE(iter_sv) == SVt_PVAV) {
6214 AV *const av = (AV*)iter_sv;
6215 if (AvFILLp(av) > -1) {
6216 sv = AvARRAY(av)[AvFILLp(av)--];
6218 else { /* no more elements of current AV to free */
6221 /* restore previous value, squirrelled away */
6222 iter_sv = AvARRAY(av)[AvMAX(av)];
6223 Safefree(AvALLOC(av));
6228 /* unrolled SvREFCNT_dec and sv_free2 follows: */
6232 if (!SvREFCNT(sv)) {
6236 if (--(SvREFCNT(sv)))
6240 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6241 "Attempt to free temp prematurely: SV 0x%"UVxf
6242 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6246 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6247 /* make sure SvREFCNT(sv)==0 happens very seldom */
6248 SvREFCNT(sv) = (~(U32)0)/2;
6258 =for apidoc sv_newref
6260 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6267 Perl_sv_newref(pTHX_ SV *const sv)
6269 PERL_UNUSED_CONTEXT;
6278 Decrement an SV's reference count, and if it drops to zero, call
6279 C<sv_clear> to invoke destructors and free up any memory used by
6280 the body; finally, deallocate the SV's head itself.
6281 Normally called via a wrapper macro C<SvREFCNT_dec>.
6287 Perl_sv_free(pTHX_ SV *const sv)
6292 if (SvREFCNT(sv) == 0) {
6293 if (SvFLAGS(sv) & SVf_BREAK)
6294 /* this SV's refcnt has been artificially decremented to
6295 * trigger cleanup */
6297 if (PL_in_clean_all) /* All is fair */
6299 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6300 /* make sure SvREFCNT(sv)==0 happens very seldom */
6301 SvREFCNT(sv) = (~(U32)0)/2;
6304 if (ckWARN_d(WARN_INTERNAL)) {
6305 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
6306 Perl_dump_sv_child(aTHX_ sv);
6308 #ifdef DEBUG_LEAKING_SCALARS
6311 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6312 if (PL_warnhook == PERL_WARNHOOK_FATAL
6313 || ckDEAD(packWARN(WARN_INTERNAL))) {
6314 /* Don't let Perl_warner cause us to escape our fate: */
6318 /* This may not return: */
6319 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6320 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6321 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6324 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6329 if (--(SvREFCNT(sv)) > 0)
6331 Perl_sv_free2(aTHX_ sv);
6335 Perl_sv_free2(pTHX_ SV *const sv)
6339 PERL_ARGS_ASSERT_SV_FREE2;
6343 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6344 "Attempt to free temp prematurely: SV 0x%"UVxf
6345 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6349 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6350 /* make sure SvREFCNT(sv)==0 happens very seldom */
6351 SvREFCNT(sv) = (~(U32)0)/2;
6362 Returns the length of the string in the SV. Handles magic and type
6363 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6369 Perl_sv_len(pTHX_ register SV *const sv)
6377 len = mg_length(sv);
6379 (void)SvPV_const(sv, len);
6384 =for apidoc sv_len_utf8
6386 Returns the number of characters in the string in an SV, counting wide
6387 UTF-8 bytes as a single character. Handles magic and type coercion.
6393 * The length is cached in PERL_MAGIC_utf8, in the mg_len field. Also the
6394 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6395 * (Note that the mg_len is not the length of the mg_ptr field.
6396 * This allows the cache to store the character length of the string without
6397 * needing to malloc() extra storage to attach to the mg_ptr.)
6402 Perl_sv_len_utf8(pTHX_ register SV *const sv)
6408 return mg_length(sv);
6412 const U8 *s = (U8*)SvPV_const(sv, len);
6416 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6418 if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
6419 if (mg->mg_len != -1)
6422 /* We can use the offset cache for a headstart.
6423 The longer value is stored in the first pair. */
6424 STRLEN *cache = (STRLEN *) mg->mg_ptr;
6426 ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
6430 if (PL_utf8cache < 0) {
6431 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6432 assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
6436 ulen = Perl_utf8_length(aTHX_ s, s + len);
6437 utf8_mg_len_cache_update(sv, &mg, ulen);
6441 return Perl_utf8_length(aTHX_ s, s + len);
6445 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6448 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6449 STRLEN *const uoffset_p, bool *const at_end)
6451 const U8 *s = start;
6452 STRLEN uoffset = *uoffset_p;
6454 PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6456 while (s < send && uoffset) {
6463 else if (s > send) {
6465 /* This is the existing behaviour. Possibly it should be a croak, as
6466 it's actually a bounds error */
6469 *uoffset_p -= uoffset;
6473 /* Given the length of the string in both bytes and UTF-8 characters, decide
6474 whether to walk forwards or backwards to find the byte corresponding to
6475 the passed in UTF-8 offset. */
6477 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6478 STRLEN uoffset, const STRLEN uend)
6480 STRLEN backw = uend - uoffset;
6482 PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6484 if (uoffset < 2 * backw) {
6485 /* The assumption is that going forwards is twice the speed of going
6486 forward (that's where the 2 * backw comes from).
6487 (The real figure of course depends on the UTF-8 data.) */
6488 const U8 *s = start;
6490 while (s < send && uoffset--)
6500 while (UTF8_IS_CONTINUATION(*send))
6503 return send - start;
6506 /* For the string representation of the given scalar, find the byte
6507 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
6508 give another position in the string, *before* the sought offset, which
6509 (which is always true, as 0, 0 is a valid pair of positions), which should
6510 help reduce the amount of linear searching.
6511 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6512 will be used to reduce the amount of linear searching. The cache will be
6513 created if necessary, and the found value offered to it for update. */
6515 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6516 const U8 *const send, STRLEN uoffset,
6517 STRLEN uoffset0, STRLEN boffset0)
6519 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
6521 bool at_end = FALSE;
6523 PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6525 assert (uoffset >= uoffset0);
6532 && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
6533 (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
6534 if ((*mgp)->mg_ptr) {
6535 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6536 if (cache[0] == uoffset) {
6537 /* An exact match. */
6540 if (cache[2] == uoffset) {
6541 /* An exact match. */
6545 if (cache[0] < uoffset) {
6546 /* The cache already knows part of the way. */
6547 if (cache[0] > uoffset0) {
6548 /* The cache knows more than the passed in pair */
6549 uoffset0 = cache[0];
6550 boffset0 = cache[1];
6552 if ((*mgp)->mg_len != -1) {
6553 /* And we know the end too. */
6555 + sv_pos_u2b_midway(start + boffset0, send,
6557 (*mgp)->mg_len - uoffset0);
6559 uoffset -= uoffset0;
6561 + sv_pos_u2b_forwards(start + boffset0,
6562 send, &uoffset, &at_end);
6563 uoffset += uoffset0;
6566 else if (cache[2] < uoffset) {
6567 /* We're between the two cache entries. */
6568 if (cache[2] > uoffset0) {
6569 /* and the cache knows more than the passed in pair */
6570 uoffset0 = cache[2];
6571 boffset0 = cache[3];
6575 + sv_pos_u2b_midway(start + boffset0,
6578 cache[0] - uoffset0);
6581 + sv_pos_u2b_midway(start + boffset0,
6584 cache[2] - uoffset0);
6588 else if ((*mgp)->mg_len != -1) {
6589 /* If we can take advantage of a passed in offset, do so. */
6590 /* In fact, offset0 is either 0, or less than offset, so don't
6591 need to worry about the other possibility. */
6593 + sv_pos_u2b_midway(start + boffset0, send,
6595 (*mgp)->mg_len - uoffset0);
6600 if (!found || PL_utf8cache < 0) {
6601 STRLEN real_boffset;
6602 uoffset -= uoffset0;
6603 real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6604 send, &uoffset, &at_end);
6605 uoffset += uoffset0;
6607 if (found && PL_utf8cache < 0)
6608 assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
6610 boffset = real_boffset;
6615 utf8_mg_len_cache_update(sv, mgp, uoffset);
6617 utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6624 =for apidoc sv_pos_u2b_flags
6626 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6627 the start of the string, to a count of the equivalent number of bytes; if
6628 lenp is non-zero, it does the same to lenp, but this time starting from
6629 the offset, rather than from the start of the string. Handles type coercion.
6630 I<flags> is passed to C<SvPV_flags>, and usually should be
6631 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
6637 * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
6638 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6639 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6644 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
6651 PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
6653 start = (U8*)SvPV_flags(sv, len, flags);
6655 const U8 * const send = start + len;
6657 boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
6660 && *lenp /* don't bother doing work for 0, as its bytes equivalent
6661 is 0, and *lenp is already set to that. */) {
6662 /* Convert the relative offset to absolute. */
6663 const STRLEN uoffset2 = uoffset + *lenp;
6664 const STRLEN boffset2
6665 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6666 uoffset, boffset) - boffset;
6680 =for apidoc sv_pos_u2b
6682 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6683 the start of the string, to a count of the equivalent number of bytes; if
6684 lenp is non-zero, it does the same to lenp, but this time starting from
6685 the offset, rather than from the start of the string. Handles magic and
6688 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
6695 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6696 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6697 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6701 /* This function is subject to size and sign problems */
6704 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6706 PERL_ARGS_ASSERT_SV_POS_U2B;
6709 STRLEN ulen = (STRLEN)*lenp;
6710 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
6711 SV_GMAGIC|SV_CONST_RETURN);
6714 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
6715 SV_GMAGIC|SV_CONST_RETURN);
6720 S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
6723 PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
6727 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6728 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6729 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
6733 (*mgp)->mg_len = ulen;
6734 /* For now, treat "overflowed" as "still unknown". See RT #72924. */
6735 if (ulen != (STRLEN) (*mgp)->mg_len)
6736 (*mgp)->mg_len = -1;
6739 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6740 byte length pairing. The (byte) length of the total SV is passed in too,
6741 as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6742 may not have updated SvCUR, so we can't rely on reading it directly.
6744 The proffered utf8/byte length pairing isn't used if the cache already has
6745 two pairs, and swapping either for the proffered pair would increase the
6746 RMS of the intervals between known byte offsets.
6748 The cache itself consists of 4 STRLEN values
6749 0: larger UTF-8 offset
6750 1: corresponding byte offset
6751 2: smaller UTF-8 offset
6752 3: corresponding byte offset
6754 Unused cache pairs have the value 0, 0.
6755 Keeping the cache "backwards" means that the invariant of
6756 cache[0] >= cache[2] is maintained even with empty slots, which means that
6757 the code that uses it doesn't need to worry if only 1 entry has actually
6758 been set to non-zero. It also makes the "position beyond the end of the
6759 cache" logic much simpler, as the first slot is always the one to start
6763 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6764 const STRLEN utf8, const STRLEN blen)
6768 PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6773 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6774 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6775 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6777 (*mgp)->mg_len = -1;
6781 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6782 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6783 (*mgp)->mg_ptr = (char *) cache;
6787 if (PL_utf8cache < 0 && SvPOKp(sv)) {
6788 /* SvPOKp() because it's possible that sv has string overloading, and
6789 therefore is a reference, hence SvPVX() is actually a pointer.
6790 This cures the (very real) symptoms of RT 69422, but I'm not actually
6791 sure whether we should even be caching the results of UTF-8
6792 operations on overloading, given that nothing stops overloading
6793 returning a different value every time it's called. */
6794 const U8 *start = (const U8 *) SvPVX_const(sv);
6795 const STRLEN realutf8 = utf8_length(start, start + byte);
6797 assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
6801 /* Cache is held with the later position first, to simplify the code
6802 that deals with unbounded ends. */
6804 ASSERT_UTF8_CACHE(cache);
6805 if (cache[1] == 0) {
6806 /* Cache is totally empty */
6809 } else if (cache[3] == 0) {
6810 if (byte > cache[1]) {
6811 /* New one is larger, so goes first. */
6812 cache[2] = cache[0];
6813 cache[3] = cache[1];
6821 #define THREEWAY_SQUARE(a,b,c,d) \
6822 ((float)((d) - (c))) * ((float)((d) - (c))) \
6823 + ((float)((c) - (b))) * ((float)((c) - (b))) \
6824 + ((float)((b) - (a))) * ((float)((b) - (a)))
6826 /* Cache has 2 slots in use, and we know three potential pairs.
6827 Keep the two that give the lowest RMS distance. Do the
6828 calcualation in bytes simply because we always know the byte
6829 length. squareroot has the same ordering as the positive value,
6830 so don't bother with the actual square root. */
6831 const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6832 if (byte > cache[1]) {
6833 /* New position is after the existing pair of pairs. */
6834 const float keep_earlier
6835 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6836 const float keep_later
6837 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6839 if (keep_later < keep_earlier) {
6840 if (keep_later < existing) {
6841 cache[2] = cache[0];
6842 cache[3] = cache[1];
6848 if (keep_earlier < existing) {
6854 else if (byte > cache[3]) {
6855 /* New position is between the existing pair of pairs. */
6856 const float keep_earlier
6857 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6858 const float keep_later
6859 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6861 if (keep_later < keep_earlier) {
6862 if (keep_later < existing) {
6868 if (keep_earlier < existing) {
6875 /* New position is before the existing pair of pairs. */
6876 const float keep_earlier
6877 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6878 const float keep_later
6879 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6881 if (keep_later < keep_earlier) {
6882 if (keep_later < existing) {
6888 if (keep_earlier < existing) {
6889 cache[0] = cache[2];
6890 cache[1] = cache[3];
6897 ASSERT_UTF8_CACHE(cache);
6900 /* We already know all of the way, now we may be able to walk back. The same
6901 assumption is made as in S_sv_pos_u2b_midway(), namely that walking
6902 backward is half the speed of walking forward. */
6904 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
6905 const U8 *end, STRLEN endu)
6907 const STRLEN forw = target - s;
6908 STRLEN backw = end - target;
6910 PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
6912 if (forw < 2 * backw) {
6913 return utf8_length(s, target);
6916 while (end > target) {
6918 while (UTF8_IS_CONTINUATION(*end)) {
6927 =for apidoc sv_pos_b2u
6929 Converts the value pointed to by offsetp from a count of bytes from the
6930 start of the string, to a count of the equivalent number of UTF-8 chars.
6931 Handles magic and type coercion.
6937 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6938 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6943 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
6946 const STRLEN byte = *offsetp;
6947 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
6953 PERL_ARGS_ASSERT_SV_POS_B2U;
6958 s = (const U8*)SvPV_const(sv, blen);
6961 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6967 && SvTYPE(sv) >= SVt_PVMG
6968 && (mg = mg_find(sv, PERL_MAGIC_utf8)))
6971 STRLEN * const cache = (STRLEN *) mg->mg_ptr;
6972 if (cache[1] == byte) {
6973 /* An exact match. */
6974 *offsetp = cache[0];
6977 if (cache[3] == byte) {
6978 /* An exact match. */
6979 *offsetp = cache[2];
6983 if (cache[1] < byte) {
6984 /* We already know part of the way. */
6985 if (mg->mg_len != -1) {
6986 /* Actually, we know the end too. */
6988 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
6989 s + blen, mg->mg_len - cache[0]);
6991 len = cache[0] + utf8_length(s + cache[1], send);
6994 else if (cache[3] < byte) {
6995 /* We're between the two cached pairs, so we do the calculation
6996 offset by the byte/utf-8 positions for the earlier pair,
6997 then add the utf-8 characters from the string start to
6999 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
7000 s + cache[1], cache[0] - cache[2])
7004 else { /* cache[3] > byte */
7005 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
7009 ASSERT_UTF8_CACHE(cache);
7011 } else if (mg->mg_len != -1) {
7012 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
7016 if (!found || PL_utf8cache < 0) {
7017 const STRLEN real_len = utf8_length(s, send);
7019 if (found && PL_utf8cache < 0)
7020 assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
7027 utf8_mg_len_cache_update(sv, &mg, len);
7029 utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
7034 S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
7035 STRLEN real, SV *const sv)
7037 PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
7039 /* As this is debugging only code, save space by keeping this test here,
7040 rather than inlining it in all the callers. */
7041 if (from_cache == real)
7044 /* Need to turn the assertions off otherwise we may recurse infinitely
7045 while printing error messages. */
7046 SAVEI8(PL_utf8cache);
7048 Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
7049 func, (UV) from_cache, (UV) real, SVfARG(sv));
7055 Returns a boolean indicating whether the strings in the two SVs are
7056 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7057 coerce its args to strings if necessary.
7059 =for apidoc sv_eq_flags
7061 Returns a boolean indicating whether the strings in the two SVs are
7062 identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings
7063 if necessary. If the flags include SV_GMAGIC, it handles get-magic, too.
7069 Perl_sv_eq_flags(pTHX_ register SV *sv1, register SV *sv2, const U32 flags)
7078 SV* svrecode = NULL;
7085 /* if pv1 and pv2 are the same, second SvPV_const call may
7086 * invalidate pv1 (if we are handling magic), so we may need to
7088 if (sv1 == sv2 && flags & SV_GMAGIC
7089 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
7090 pv1 = SvPV_const(sv1, cur1);
7091 sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
7093 pv1 = SvPV_flags_const(sv1, cur1, flags);
7101 pv2 = SvPV_flags_const(sv2, cur2, flags);
7103 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7104 /* Differing utf8ness.
7105 * Do not UTF8size the comparands as a side-effect. */
7108 svrecode = newSVpvn(pv2, cur2);
7109 sv_recode_to_utf8(svrecode, PL_encoding);
7110 pv2 = SvPV_const(svrecode, cur2);
7113 svrecode = newSVpvn(pv1, cur1);
7114 sv_recode_to_utf8(svrecode, PL_encoding);
7115 pv1 = SvPV_const(svrecode, cur1);
7117 /* Now both are in UTF-8. */
7119 SvREFCNT_dec(svrecode);
7125 /* sv1 is the UTF-8 one */
7126 return bytes_cmp_utf8((const U8*)pv2, cur2,
7127 (const U8*)pv1, cur1) == 0;
7130 /* sv2 is the UTF-8 one */
7131 return bytes_cmp_utf8((const U8*)pv1, cur1,
7132 (const U8*)pv2, cur2) == 0;
7138 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
7140 SvREFCNT_dec(svrecode);
7150 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7151 string in C<sv1> is less than, equal to, or greater than the string in
7152 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7153 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
7155 =for apidoc sv_cmp_flags
7157 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7158 string in C<sv1> is less than, equal to, or greater than the string in
7159 C<sv2>. Is UTF-8 and 'use bytes' aware and will coerce its args to strings
7160 if necessary. If the flags include SV_GMAGIC, it handles get magic. See
7161 also C<sv_cmp_locale_flags>.
7167 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
7169 return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
7173 Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2,
7178 const char *pv1, *pv2;
7181 SV *svrecode = NULL;
7188 pv1 = SvPV_flags_const(sv1, cur1, flags);
7195 pv2 = SvPV_flags_const(sv2, cur2, flags);
7197 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7198 /* Differing utf8ness.
7199 * Do not UTF8size the comparands as a side-effect. */
7202 svrecode = newSVpvn(pv2, cur2);
7203 sv_recode_to_utf8(svrecode, PL_encoding);
7204 pv2 = SvPV_const(svrecode, cur2);
7207 const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2,
7208 (const U8*)pv1, cur1);
7209 return retval ? retval < 0 ? -1 : +1 : 0;
7214 svrecode = newSVpvn(pv1, cur1);
7215 sv_recode_to_utf8(svrecode, PL_encoding);
7216 pv1 = SvPV_const(svrecode, cur1);
7219 const int retval = bytes_cmp_utf8((const U8*)pv1, cur1,
7220 (const U8*)pv2, cur2);
7221 return retval ? retval < 0 ? -1 : +1 : 0;
7227 cmp = cur2 ? -1 : 0;
7231 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
7234 cmp = retval < 0 ? -1 : 1;
7235 } else if (cur1 == cur2) {
7238 cmp = cur1 < cur2 ? -1 : 1;
7242 SvREFCNT_dec(svrecode);
7250 =for apidoc sv_cmp_locale
7252 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7253 'use bytes' aware, handles get magic, and will coerce its args to strings
7254 if necessary. See also C<sv_cmp>.
7256 =for apidoc sv_cmp_locale_flags
7258 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7259 'use bytes' aware and will coerce its args to strings if necessary. If the
7260 flags contain SV_GMAGIC, it handles get magic. See also C<sv_cmp_flags>.
7266 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
7268 return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
7272 Perl_sv_cmp_locale_flags(pTHX_ register SV *const sv1, register SV *const sv2,
7276 #ifdef USE_LOCALE_COLLATE
7282 if (PL_collation_standard)
7286 pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
7288 pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
7290 if (!pv1 || !len1) {
7301 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
7304 return retval < 0 ? -1 : 1;
7307 * When the result of collation is equality, that doesn't mean
7308 * that there are no differences -- some locales exclude some
7309 * characters from consideration. So to avoid false equalities,
7310 * we use the raw string as a tiebreaker.
7316 #endif /* USE_LOCALE_COLLATE */
7318 return sv_cmp(sv1, sv2);
7322 #ifdef USE_LOCALE_COLLATE
7325 =for apidoc sv_collxfrm
7327 This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag. See
7328 C<sv_collxfrm_flags>.
7330 =for apidoc sv_collxfrm_flags
7332 Add Collate Transform magic to an SV if it doesn't already have it. If the
7333 flags contain SV_GMAGIC, it handles get-magic.
7335 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
7336 scalar data of the variable, but transformed to such a format that a normal
7337 memory comparison can be used to compare the data according to the locale
7344 Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
7349 PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
7351 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
7352 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
7358 Safefree(mg->mg_ptr);
7359 s = SvPV_flags_const(sv, len, flags);
7360 if ((xf = mem_collxfrm(s, len, &xlen))) {
7362 #ifdef PERL_OLD_COPY_ON_WRITE
7364 sv_force_normal_flags(sv, 0);
7366 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
7380 if (mg && mg->mg_ptr) {
7382 return mg->mg_ptr + sizeof(PL_collation_ix);
7390 #endif /* USE_LOCALE_COLLATE */
7393 S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7395 SV * const tsv = newSV(0);
7398 sv_gets(tsv, fp, 0);
7399 sv_utf8_upgrade_nomg(tsv);
7400 SvCUR_set(sv,append);
7403 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7407 S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7410 const U32 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7411 /* Grab the size of the record we're getting */
7412 char *const buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7419 /* VMS wants read instead of fread, because fread doesn't respect */
7420 /* RMS record boundaries. This is not necessarily a good thing to be */
7421 /* doing, but we've got no other real choice - except avoid stdio
7422 as implementation - perhaps write a :vms layer ?
7424 fd = PerlIO_fileno(fp);
7426 bytesread = PerlLIO_read(fd, buffer, recsize);
7428 else /* in-memory file from PerlIO::Scalar */
7431 bytesread = PerlIO_read(fp, buffer, recsize);
7436 SvCUR_set(sv, bytesread + append);
7437 buffer[bytesread] = '\0';
7438 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7444 Get a line from the filehandle and store it into the SV, optionally
7445 appending to the currently-stored string.
7451 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
7456 register STDCHAR rslast;
7457 register STDCHAR *bp;
7462 PERL_ARGS_ASSERT_SV_GETS;
7464 if (SvTHINKFIRST(sv))
7465 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
7466 /* XXX. If you make this PVIV, then copy on write can copy scalars read
7468 However, perlbench says it's slower, because the existing swipe code
7469 is faster than copy on write.
7470 Swings and roundabouts. */
7471 SvUPGRADE(sv, SVt_PV);
7476 if (PerlIO_isutf8(fp)) {
7478 sv_utf8_upgrade_nomg(sv);
7479 sv_pos_u2b(sv,&append,0);
7481 } else if (SvUTF8(sv)) {
7482 return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append);
7490 if (PerlIO_isutf8(fp))
7493 if (IN_PERL_COMPILETIME) {
7494 /* we always read code in line mode */
7498 else if (RsSNARF(PL_rs)) {
7499 /* If it is a regular disk file use size from stat() as estimate
7500 of amount we are going to read -- may result in mallocing
7501 more memory than we really need if the layers below reduce
7502 the size we read (e.g. CRLF or a gzip layer).
7505 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
7506 const Off_t offset = PerlIO_tell(fp);
7507 if (offset != (Off_t) -1 && st.st_size + append > offset) {
7508 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7514 else if (RsRECORD(PL_rs)) {
7515 return S_sv_gets_read_record(aTHX_ sv, fp, append);
7517 else if (RsPARA(PL_rs)) {
7523 /* Get $/ i.e. PL_rs into same encoding as stream wants */
7524 if (PerlIO_isutf8(fp)) {
7525 rsptr = SvPVutf8(PL_rs, rslen);
7528 if (SvUTF8(PL_rs)) {
7529 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7530 Perl_croak(aTHX_ "Wide character in $/");
7533 rsptr = SvPV_const(PL_rs, rslen);
7537 rslast = rslen ? rsptr[rslen - 1] : '\0';
7539 if (rspara) { /* have to do this both before and after */
7540 do { /* to make sure file boundaries work right */
7543 i = PerlIO_getc(fp);
7547 PerlIO_ungetc(fp,i);
7553 /* See if we know enough about I/O mechanism to cheat it ! */
7555 /* This used to be #ifdef test - it is made run-time test for ease
7556 of abstracting out stdio interface. One call should be cheap
7557 enough here - and may even be a macro allowing compile
7561 if (PerlIO_fast_gets(fp)) {
7564 * We're going to steal some values from the stdio struct
7565 * and put EVERYTHING in the innermost loop into registers.
7567 register STDCHAR *ptr;
7571 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7572 /* An ungetc()d char is handled separately from the regular
7573 * buffer, so we getc() it back out and stuff it in the buffer.
7575 i = PerlIO_getc(fp);
7576 if (i == EOF) return 0;
7577 *(--((*fp)->_ptr)) = (unsigned char) i;
7581 /* Here is some breathtakingly efficient cheating */
7583 cnt = PerlIO_get_cnt(fp); /* get count into register */
7584 /* make sure we have the room */
7585 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7586 /* Not room for all of it
7587 if we are looking for a separator and room for some
7589 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7590 /* just process what we have room for */
7591 shortbuffered = cnt - SvLEN(sv) + append + 1;
7592 cnt -= shortbuffered;
7596 /* remember that cnt can be negative */
7597 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7602 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
7603 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7604 DEBUG_P(PerlIO_printf(Perl_debug_log,
7605 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7606 DEBUG_P(PerlIO_printf(Perl_debug_log,
7607 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7608 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7609 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7614 while (cnt > 0) { /* this | eat */
7616 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7617 goto thats_all_folks; /* screams | sed :-) */
7621 Copy(ptr, bp, cnt, char); /* this | eat */
7622 bp += cnt; /* screams | dust */
7623 ptr += cnt; /* louder | sed :-) */
7625 assert (!shortbuffered);
7626 goto cannot_be_shortbuffered;
7630 if (shortbuffered) { /* oh well, must extend */
7631 cnt = shortbuffered;
7633 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7635 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7636 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7640 cannot_be_shortbuffered:
7641 DEBUG_P(PerlIO_printf(Perl_debug_log,
7642 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7643 PTR2UV(ptr),(long)cnt));
7644 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7646 DEBUG_Pv(PerlIO_printf(Perl_debug_log,
7647 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7648 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7649 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7651 /* This used to call 'filbuf' in stdio form, but as that behaves like
7652 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7653 another abstraction. */
7654 i = PerlIO_getc(fp); /* get more characters */
7656 DEBUG_Pv(PerlIO_printf(Perl_debug_log,
7657 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7658 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7659 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7661 cnt = PerlIO_get_cnt(fp);
7662 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7663 DEBUG_P(PerlIO_printf(Perl_debug_log,
7664 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7666 if (i == EOF) /* all done for ever? */
7667 goto thats_really_all_folks;
7669 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7671 SvGROW(sv, bpx + cnt + 2);
7672 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7674 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7676 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7677 goto thats_all_folks;
7681 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7682 memNE((char*)bp - rslen, rsptr, rslen))
7683 goto screamer; /* go back to the fray */
7684 thats_really_all_folks:
7686 cnt += shortbuffered;
7687 DEBUG_P(PerlIO_printf(Perl_debug_log,
7688 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7689 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7690 DEBUG_P(PerlIO_printf(Perl_debug_log,
7691 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7692 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7693 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7695 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
7696 DEBUG_P(PerlIO_printf(Perl_debug_log,
7697 "Screamer: done, len=%ld, string=|%.*s|\n",
7698 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7702 /*The big, slow, and stupid way. */
7703 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
7704 STDCHAR *buf = NULL;
7705 Newx(buf, 8192, STDCHAR);
7713 register const STDCHAR * const bpe = buf + sizeof(buf);
7715 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7716 ; /* keep reading */
7720 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7721 /* Accomodate broken VAXC compiler, which applies U8 cast to
7722 * both args of ?: operator, causing EOF to change into 255
7725 i = (U8)buf[cnt - 1];
7731 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7733 sv_catpvn(sv, (char *) buf, cnt);
7735 sv_setpvn(sv, (char *) buf, cnt);
7737 if (i != EOF && /* joy */
7739 SvCUR(sv) < rslen ||
7740 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7744 * If we're reading from a TTY and we get a short read,
7745 * indicating that the user hit his EOF character, we need
7746 * to notice it now, because if we try to read from the TTY
7747 * again, the EOF condition will disappear.
7749 * The comparison of cnt to sizeof(buf) is an optimization
7750 * that prevents unnecessary calls to feof().
7754 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7758 #ifdef USE_HEAP_INSTEAD_OF_STACK
7763 if (rspara) { /* have to do this both before and after */
7764 while (i != EOF) { /* to make sure file boundaries work right */
7765 i = PerlIO_getc(fp);
7767 PerlIO_ungetc(fp,i);
7773 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7779 Auto-increment of the value in the SV, doing string to numeric conversion
7780 if necessary. Handles 'get' magic and operator overloading.
7786 Perl_sv_inc(pTHX_ register SV *const sv)
7795 =for apidoc sv_inc_nomg
7797 Auto-increment of the value in the SV, doing string to numeric conversion
7798 if necessary. Handles operator overloading. Skips handling 'get' magic.
7804 Perl_sv_inc_nomg(pTHX_ register SV *const sv)
7812 if (SvTHINKFIRST(sv)) {
7814 sv_force_normal_flags(sv, 0);
7815 if (SvREADONLY(sv)) {
7816 if (IN_PERL_RUNTIME)
7817 Perl_croak_no_modify(aTHX);
7821 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7823 i = PTR2IV(SvRV(sv));
7828 flags = SvFLAGS(sv);
7829 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7830 /* It's (privately or publicly) a float, but not tested as an
7831 integer, so test it to see. */
7833 flags = SvFLAGS(sv);
7835 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7836 /* It's publicly an integer, or privately an integer-not-float */
7837 #ifdef PERL_PRESERVE_IVUV
7841 if (SvUVX(sv) == UV_MAX)
7842 sv_setnv(sv, UV_MAX_P1);
7844 (void)SvIOK_only_UV(sv);
7845 SvUV_set(sv, SvUVX(sv) + 1);
7847 if (SvIVX(sv) == IV_MAX)
7848 sv_setuv(sv, (UV)IV_MAX + 1);
7850 (void)SvIOK_only(sv);
7851 SvIV_set(sv, SvIVX(sv) + 1);
7856 if (flags & SVp_NOK) {
7857 const NV was = SvNVX(sv);
7858 if (NV_OVERFLOWS_INTEGERS_AT &&
7859 was >= NV_OVERFLOWS_INTEGERS_AT) {
7860 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7861 "Lost precision when incrementing %" NVff " by 1",
7864 (void)SvNOK_only(sv);
7865 SvNV_set(sv, was + 1.0);
7869 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7870 if ((flags & SVTYPEMASK) < SVt_PVIV)
7871 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
7872 (void)SvIOK_only(sv);
7877 while (isALPHA(*d)) d++;
7878 while (isDIGIT(*d)) d++;
7879 if (d < SvEND(sv)) {
7880 #ifdef PERL_PRESERVE_IVUV
7881 /* Got to punt this as an integer if needs be, but we don't issue
7882 warnings. Probably ought to make the sv_iv_please() that does
7883 the conversion if possible, and silently. */
7884 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7885 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7886 /* Need to try really hard to see if it's an integer.
7887 9.22337203685478e+18 is an integer.
7888 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7889 so $a="9.22337203685478e+18"; $a+0; $a++
7890 needs to be the same as $a="9.22337203685478e+18"; $a++
7897 /* sv_2iv *should* have made this an NV */
7898 if (flags & SVp_NOK) {
7899 (void)SvNOK_only(sv);
7900 SvNV_set(sv, SvNVX(sv) + 1.0);
7903 /* I don't think we can get here. Maybe I should assert this
7904 And if we do get here I suspect that sv_setnv will croak. NWC
7906 #if defined(USE_LONG_DOUBLE)
7907 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",
7908 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7910 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7911 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7914 #endif /* PERL_PRESERVE_IVUV */
7915 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7919 while (d >= SvPVX_const(sv)) {
7927 /* MKS: The original code here died if letters weren't consecutive.
7928 * at least it didn't have to worry about non-C locales. The
7929 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7930 * arranged in order (although not consecutively) and that only
7931 * [A-Za-z] are accepted by isALPHA in the C locale.
7933 if (*d != 'z' && *d != 'Z') {
7934 do { ++*d; } while (!isALPHA(*d));
7937 *(d--) -= 'z' - 'a';
7942 *(d--) -= 'z' - 'a' + 1;
7946 /* oh,oh, the number grew */
7947 SvGROW(sv, SvCUR(sv) + 2);
7948 SvCUR_set(sv, SvCUR(sv) + 1);
7949 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7960 Auto-decrement of the value in the SV, doing string to numeric conversion
7961 if necessary. Handles 'get' magic and operator overloading.
7967 Perl_sv_dec(pTHX_ register SV *const sv)
7977 =for apidoc sv_dec_nomg
7979 Auto-decrement of the value in the SV, doing string to numeric conversion
7980 if necessary. Handles operator overloading. Skips handling 'get' magic.
7986 Perl_sv_dec_nomg(pTHX_ register SV *const sv)
7993 if (SvTHINKFIRST(sv)) {
7995 sv_force_normal_flags(sv, 0);
7996 if (SvREADONLY(sv)) {
7997 if (IN_PERL_RUNTIME)
7998 Perl_croak_no_modify(aTHX);
8002 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
8004 i = PTR2IV(SvRV(sv));
8009 /* Unlike sv_inc we don't have to worry about string-never-numbers
8010 and keeping them magic. But we mustn't warn on punting */
8011 flags = SvFLAGS(sv);
8012 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
8013 /* It's publicly an integer, or privately an integer-not-float */
8014 #ifdef PERL_PRESERVE_IVUV
8018 if (SvUVX(sv) == 0) {
8019 (void)SvIOK_only(sv);
8023 (void)SvIOK_only_UV(sv);
8024 SvUV_set(sv, SvUVX(sv) - 1);
8027 if (SvIVX(sv) == IV_MIN) {
8028 sv_setnv(sv, (NV)IV_MIN);
8032 (void)SvIOK_only(sv);
8033 SvIV_set(sv, SvIVX(sv) - 1);
8038 if (flags & SVp_NOK) {
8041 const NV was = SvNVX(sv);
8042 if (NV_OVERFLOWS_INTEGERS_AT &&
8043 was <= -NV_OVERFLOWS_INTEGERS_AT) {
8044 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
8045 "Lost precision when decrementing %" NVff " by 1",
8048 (void)SvNOK_only(sv);
8049 SvNV_set(sv, was - 1.0);
8053 if (!(flags & SVp_POK)) {
8054 if ((flags & SVTYPEMASK) < SVt_PVIV)
8055 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
8057 (void)SvIOK_only(sv);
8060 #ifdef PERL_PRESERVE_IVUV
8062 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8063 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
8064 /* Need to try really hard to see if it's an integer.
8065 9.22337203685478e+18 is an integer.
8066 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8067 so $a="9.22337203685478e+18"; $a+0; $a--
8068 needs to be the same as $a="9.22337203685478e+18"; $a--
8075 /* sv_2iv *should* have made this an NV */
8076 if (flags & SVp_NOK) {
8077 (void)SvNOK_only(sv);
8078 SvNV_set(sv, SvNVX(sv) - 1.0);
8081 /* I don't think we can get here. Maybe I should assert this
8082 And if we do get here I suspect that sv_setnv will croak. NWC
8084 #if defined(USE_LONG_DOUBLE)
8085 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",
8086 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8088 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8089 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8093 #endif /* PERL_PRESERVE_IVUV */
8094 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
8097 /* this define is used to eliminate a chunk of duplicated but shared logic
8098 * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
8099 * used anywhere but here - yves
8101 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
8104 PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
8108 =for apidoc sv_mortalcopy
8110 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
8111 The new SV is marked as mortal. It will be destroyed "soon", either by an
8112 explicit call to FREETMPS, or by an implicit call at places such as
8113 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
8118 /* Make a string that will exist for the duration of the expression
8119 * evaluation. Actually, it may have to last longer than that, but
8120 * hopefully we won't free it until it has been assigned to a
8121 * permanent location. */
8124 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
8130 sv_setsv(sv,oldstr);
8131 PUSH_EXTEND_MORTAL__SV_C(sv);
8137 =for apidoc sv_newmortal
8139 Creates a new null SV which is mortal. The reference count of the SV is
8140 set to 1. It will be destroyed "soon", either by an explicit call to
8141 FREETMPS, or by an implicit call at places such as statement boundaries.
8142 See also C<sv_mortalcopy> and C<sv_2mortal>.
8148 Perl_sv_newmortal(pTHX)
8154 SvFLAGS(sv) = SVs_TEMP;
8155 PUSH_EXTEND_MORTAL__SV_C(sv);
8161 =for apidoc newSVpvn_flags
8163 Creates a new SV and copies a string into it. The reference count for the
8164 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
8165 string. You are responsible for ensuring that the source string is at least
8166 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
8167 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
8168 If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before
8169 returning. If C<SVf_UTF8> is set, C<s> is considered to be in UTF-8 and the
8170 C<SVf_UTF8> flag will be set on the new SV.
8171 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
8173 #define newSVpvn_utf8(s, len, u) \
8174 newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
8180 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
8185 /* All the flags we don't support must be zero.
8186 And we're new code so I'm going to assert this from the start. */
8187 assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
8189 sv_setpvn(sv,s,len);
8191 /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal()
8192 * and do what it does outselves here.
8193 * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags
8194 * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which
8195 * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we
8196 * eleminate quite a few steps than it looks - Yves (explaining patch by gfx)
8199 SvFLAGS(sv) |= flags;
8201 if(flags & SVs_TEMP){
8202 PUSH_EXTEND_MORTAL__SV_C(sv);
8209 =for apidoc sv_2mortal
8211 Marks an existing SV as mortal. The SV will be destroyed "soon", either
8212 by an explicit call to FREETMPS, or by an implicit call at places such as
8213 statement boundaries. SvTEMP() is turned on which means that the SV's
8214 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
8215 and C<sv_mortalcopy>.
8221 Perl_sv_2mortal(pTHX_ register SV *const sv)
8226 if (SvREADONLY(sv) && SvIMMORTAL(sv))
8228 PUSH_EXTEND_MORTAL__SV_C(sv);
8236 Creates a new SV and copies a string into it. The reference count for the
8237 SV is set to 1. If C<len> is zero, Perl will compute the length using
8238 strlen(). For efficiency, consider using C<newSVpvn> instead.
8244 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
8250 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
8255 =for apidoc newSVpvn
8257 Creates a new SV and copies a string into it. The reference count for the
8258 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
8259 string. You are responsible for ensuring that the source string is at least
8260 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
8266 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
8272 sv_setpvn(sv,s,len);
8277 =for apidoc newSVhek
8279 Creates a new SV from the hash key structure. It will generate scalars that
8280 point to the shared string table where possible. Returns a new (undefined)
8281 SV if the hek is NULL.
8287 Perl_newSVhek(pTHX_ const HEK *const hek)
8297 if (HEK_LEN(hek) == HEf_SVKEY) {
8298 return newSVsv(*(SV**)HEK_KEY(hek));
8300 const int flags = HEK_FLAGS(hek);
8301 if (flags & HVhek_WASUTF8) {
8303 Andreas would like keys he put in as utf8 to come back as utf8
8305 STRLEN utf8_len = HEK_LEN(hek);
8306 SV * const sv = newSV_type(SVt_PV);
8307 char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
8308 /* bytes_to_utf8() allocates a new string, which we can repurpose: */
8309 sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
8312 } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
8313 /* We don't have a pointer to the hv, so we have to replicate the
8314 flag into every HEK. This hv is using custom a hasing
8315 algorithm. Hence we can't return a shared string scalar, as
8316 that would contain the (wrong) hash value, and might get passed
8317 into an hv routine with a regular hash.
8318 Similarly, a hash that isn't using shared hash keys has to have
8319 the flag in every key so that we know not to try to call
8320 share_hek_kek on it. */
8322 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
8327 /* This will be overwhelminly the most common case. */
8329 /* Inline most of newSVpvn_share(), because share_hek_hek() is far
8330 more efficient than sharepvn(). */
8334 sv_upgrade(sv, SVt_PV);
8335 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
8336 SvCUR_set(sv, HEK_LEN(hek));
8349 =for apidoc newSVpvn_share
8351 Creates a new SV with its SvPVX_const pointing to a shared string in the string
8352 table. If the string does not already exist in the table, it is created
8353 first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
8354 value is used; otherwise the hash is computed. The string's hash can be later
8355 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
8356 that as the string table is used for shared hash keys these strings will have
8357 SvPVX_const == HeKEY and hash lookup will avoid string compare.
8363 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
8367 bool is_utf8 = FALSE;
8368 const char *const orig_src = src;
8371 STRLEN tmplen = -len;
8373 /* See the note in hv.c:hv_fetch() --jhi */
8374 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
8378 PERL_HASH(hash, src, len);
8380 /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
8381 changes here, update it there too. */
8382 sv_upgrade(sv, SVt_PV);
8383 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
8391 if (src != orig_src)
8397 =for apidoc newSVpv_share
8399 Like C<newSVpvn_share>, but takes a nul-terminated string instead of a
8406 Perl_newSVpv_share(pTHX_ const char *src, U32 hash)
8408 return newSVpvn_share(src, strlen(src), hash);
8411 #if defined(PERL_IMPLICIT_CONTEXT)
8413 /* pTHX_ magic can't cope with varargs, so this is a no-context
8414 * version of the main function, (which may itself be aliased to us).
8415 * Don't access this version directly.
8419 Perl_newSVpvf_nocontext(const char *const pat, ...)
8425 PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
8427 va_start(args, pat);
8428 sv = vnewSVpvf(pat, &args);
8435 =for apidoc newSVpvf
8437 Creates a new SV and initializes it with the string formatted like
8444 Perl_newSVpvf(pTHX_ const char *const pat, ...)
8449 PERL_ARGS_ASSERT_NEWSVPVF;
8451 va_start(args, pat);
8452 sv = vnewSVpvf(pat, &args);
8457 /* backend for newSVpvf() and newSVpvf_nocontext() */
8460 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
8465 PERL_ARGS_ASSERT_VNEWSVPVF;
8468 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8475 Creates a new SV and copies a floating point value into it.
8476 The reference count for the SV is set to 1.
8482 Perl_newSVnv(pTHX_ const NV n)
8495 Creates a new SV and copies an integer into it. The reference count for the
8502 Perl_newSViv(pTHX_ const IV i)
8515 Creates a new SV and copies an unsigned integer into it.
8516 The reference count for the SV is set to 1.
8522 Perl_newSVuv(pTHX_ const UV u)
8533 =for apidoc newSV_type
8535 Creates a new SV, of the type specified. The reference count for the new SV
8542 Perl_newSV_type(pTHX_ const svtype type)
8547 sv_upgrade(sv, type);
8552 =for apidoc newRV_noinc
8554 Creates an RV wrapper for an SV. The reference count for the original
8555 SV is B<not> incremented.
8561 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
8564 register SV *sv = newSV_type(SVt_IV);
8566 PERL_ARGS_ASSERT_NEWRV_NOINC;
8569 SvRV_set(sv, tmpRef);
8574 /* newRV_inc is the official function name to use now.
8575 * newRV_inc is in fact #defined to newRV in sv.h
8579 Perl_newRV(pTHX_ SV *const sv)
8583 PERL_ARGS_ASSERT_NEWRV;
8585 return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
8591 Creates a new SV which is an exact duplicate of the original SV.
8598 Perl_newSVsv(pTHX_ register SV *const old)
8605 if (SvTYPE(old) == SVTYPEMASK) {
8606 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
8610 /* SV_GMAGIC is the default for sv_setv()
8611 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
8612 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
8613 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
8618 =for apidoc sv_reset
8620 Underlying implementation for the C<reset> Perl function.
8621 Note that the perl-level function is vaguely deprecated.
8627 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
8630 char todo[PERL_UCHAR_MAX+1];
8632 PERL_ARGS_ASSERT_SV_RESET;
8637 if (!*s) { /* reset ?? searches */
8638 MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
8640 const U32 count = mg->mg_len / sizeof(PMOP**);
8641 PMOP **pmp = (PMOP**) mg->mg_ptr;
8642 PMOP *const *const end = pmp + count;
8646 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
8648 (*pmp)->op_pmflags &= ~PMf_USED;
8656 /* reset variables */
8658 if (!HvARRAY(stash))
8661 Zero(todo, 256, char);
8664 I32 i = (unsigned char)*s;
8668 max = (unsigned char)*s++;
8669 for ( ; i <= max; i++) {
8672 for (i = 0; i <= (I32) HvMAX(stash); i++) {
8674 for (entry = HvARRAY(stash)[i];
8676 entry = HeNEXT(entry))
8681 if (!todo[(U8)*HeKEY(entry)])
8683 gv = MUTABLE_GV(HeVAL(entry));
8686 if (SvTHINKFIRST(sv)) {
8687 if (!SvREADONLY(sv) && SvROK(sv))
8689 /* XXX Is this continue a bug? Why should THINKFIRST
8690 exempt us from resetting arrays and hashes? */
8694 if (SvTYPE(sv) >= SVt_PV) {
8696 if (SvPVX_const(sv) != NULL)
8704 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8706 Perl_die(aTHX_ "Can't reset %%ENV on this system");
8709 # if defined(USE_ENVIRON_ARRAY)
8712 # endif /* USE_ENVIRON_ARRAY */
8723 Using various gambits, try to get an IO from an SV: the IO slot if its a
8724 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8725 named after the PV if we're a string.
8731 Perl_sv_2io(pTHX_ SV *const sv)
8736 PERL_ARGS_ASSERT_SV_2IO;
8738 switch (SvTYPE(sv)) {
8740 io = MUTABLE_IO(sv);
8744 if (isGV_with_GP(sv)) {
8745 gv = MUTABLE_GV(sv);
8748 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8754 Perl_croak(aTHX_ PL_no_usym, "filehandle");
8756 return sv_2io(SvRV(sv));
8757 gv = gv_fetchsv(sv, 0, SVt_PVIO);
8763 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
8772 Using various gambits, try to get a CV from an SV; in addition, try if
8773 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8774 The flags in C<lref> are passed to gv_fetchsv.
8780 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8786 PERL_ARGS_ASSERT_SV_2CV;
8793 switch (SvTYPE(sv)) {
8797 return MUTABLE_CV(sv);
8804 if (isGV_with_GP(sv)) {
8805 gv = MUTABLE_GV(sv);
8815 sv = amagic_deref_call(sv, to_cv_amg);
8816 /* At this point I'd like to do SPAGAIN, but really I need to
8817 force it upon my callers. Hmmm. This is a mess... */
8820 if (SvTYPE(sv) == SVt_PVCV) {
8821 cv = MUTABLE_CV(sv);
8826 else if(isGV_with_GP(sv))
8827 gv = MUTABLE_GV(sv);
8829 Perl_croak(aTHX_ "Not a subroutine reference");
8831 else if (isGV_with_GP(sv)) {
8833 gv = MUTABLE_GV(sv);
8836 gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
8842 /* Some flags to gv_fetchsv mean don't really create the GV */
8843 if (!isGV_with_GP(gv)) {
8849 if (lref && !GvCVu(gv)) {
8853 gv_efullname3(tmpsv, gv, NULL);
8854 /* XXX this is probably not what they think they're getting.
8855 * It has the same effect as "sub name;", i.e. just a forward
8857 newSUB(start_subparse(FALSE, 0),
8858 newSVOP(OP_CONST, 0, tmpsv),
8862 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8863 SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8872 Returns true if the SV has a true value by Perl's rules.
8873 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8874 instead use an in-line version.
8880 Perl_sv_true(pTHX_ register SV *const sv)
8885 register const XPV* const tXpv = (XPV*)SvANY(sv);
8887 (tXpv->xpv_cur > 1 ||
8888 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
8895 return SvIVX(sv) != 0;
8898 return SvNVX(sv) != 0.0;
8900 return sv_2bool(sv);
8906 =for apidoc sv_pvn_force
8908 Get a sensible string out of the SV somehow.
8909 A private implementation of the C<SvPV_force> macro for compilers which
8910 can't cope with complex macro expressions. Always use the macro instead.
8912 =for apidoc sv_pvn_force_flags
8914 Get a sensible string out of the SV somehow.
8915 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8916 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8917 implemented in terms of this function.
8918 You normally want to use the various wrapper macros instead: see
8919 C<SvPV_force> and C<SvPV_force_nomg>
8925 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
8929 PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
8931 if (SvTHINKFIRST(sv) && !SvROK(sv))
8932 sv_force_normal_flags(sv, 0);
8942 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8943 const char * const ref = sv_reftype(sv,0);
8945 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8946 ref, OP_DESC(PL_op));
8948 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
8950 if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
8951 || isGV_with_GP(sv))
8952 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8954 s = sv_2pv_flags(sv, &len, flags);
8958 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
8961 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8962 SvGROW(sv, len + 1);
8963 Move(s,SvPVX(sv),len,char);
8965 SvPVX(sv)[len] = '\0';
8968 SvPOK_on(sv); /* validate pointer */
8970 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8971 PTR2UV(sv),SvPVX_const(sv)));
8974 return SvPVX_mutable(sv);
8978 =for apidoc sv_pvbyten_force
8980 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
8986 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
8988 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
8990 sv_pvn_force(sv,lp);
8991 sv_utf8_downgrade(sv,0);
8997 =for apidoc sv_pvutf8n_force
8999 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
9005 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
9007 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
9009 sv_pvn_force(sv,lp);
9010 sv_utf8_upgrade(sv);
9016 =for apidoc sv_reftype
9018 Returns a string describing what the SV is a reference to.
9024 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
9026 PERL_ARGS_ASSERT_SV_REFTYPE;
9028 /* The fact that I don't need to downcast to char * everywhere, only in ?:
9029 inside return suggests a const propagation bug in g++. */
9030 if (ob && SvOBJECT(sv)) {
9031 char * const name = HvNAME_get(SvSTASH(sv));
9032 return name ? name : (char *) "__ANON__";
9035 switch (SvTYPE(sv)) {
9050 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
9051 /* tied lvalues should appear to be
9052 * scalars for backwards compatitbility */
9053 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
9054 ? "SCALAR" : "LVALUE");
9055 case SVt_PVAV: return "ARRAY";
9056 case SVt_PVHV: return "HASH";
9057 case SVt_PVCV: return "CODE";
9058 case SVt_PVGV: return (char *) (isGV_with_GP(sv)
9059 ? "GLOB" : "SCALAR");
9060 case SVt_PVFM: return "FORMAT";
9061 case SVt_PVIO: return "IO";
9062 case SVt_BIND: return "BIND";
9063 case SVt_REGEXP: return "REGEXP";
9064 default: return "UNKNOWN";
9070 =for apidoc sv_isobject
9072 Returns a boolean indicating whether the SV is an RV pointing to a blessed
9073 object. If the SV is not an RV, or if the object is not blessed, then this
9080 Perl_sv_isobject(pTHX_ SV *sv)
9096 Returns a boolean indicating whether the SV is blessed into the specified
9097 class. This does not check for subtypes; use C<sv_derived_from> to verify
9098 an inheritance relationship.
9104 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
9108 PERL_ARGS_ASSERT_SV_ISA;
9118 hvname = HvNAME_get(SvSTASH(sv));
9122 return strEQ(hvname, name);
9128 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
9129 it will be upgraded to one. If C<classname> is non-null then the new SV will
9130 be blessed in the specified package. The new SV is returned and its
9131 reference count is 1.
9137 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
9142 PERL_ARGS_ASSERT_NEWSVRV;
9146 SV_CHECK_THINKFIRST_COW_DROP(rv);
9147 (void)SvAMAGIC_off(rv);
9149 if (SvTYPE(rv) >= SVt_PVMG) {
9150 const U32 refcnt = SvREFCNT(rv);
9154 SvREFCNT(rv) = refcnt;
9156 sv_upgrade(rv, SVt_IV);
9157 } else if (SvROK(rv)) {
9158 SvREFCNT_dec(SvRV(rv));
9160 prepare_SV_for_RV(rv);
9168 HV* const stash = gv_stashpv(classname, GV_ADD);
9169 (void)sv_bless(rv, stash);
9175 =for apidoc sv_setref_pv
9177 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
9178 argument will be upgraded to an RV. That RV will be modified to point to
9179 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
9180 into the SV. The C<classname> argument indicates the package for the
9181 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9182 will have a reference count of 1, and the RV will be returned.
9184 Do not use with other Perl types such as HV, AV, SV, CV, because those
9185 objects will become corrupted by the pointer copy process.
9187 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
9193 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
9197 PERL_ARGS_ASSERT_SV_SETREF_PV;
9200 sv_setsv(rv, &PL_sv_undef);
9204 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
9209 =for apidoc sv_setref_iv
9211 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
9212 argument will be upgraded to an RV. That RV will be modified to point to
9213 the new SV. The C<classname> argument indicates the package for the
9214 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9215 will have a reference count of 1, and the RV will be returned.
9221 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
9223 PERL_ARGS_ASSERT_SV_SETREF_IV;
9225 sv_setiv(newSVrv(rv,classname), iv);
9230 =for apidoc sv_setref_uv
9232 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
9233 argument will be upgraded to an RV. That RV will be modified to point to
9234 the new SV. The C<classname> argument indicates the package for the
9235 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9236 will have a reference count of 1, and the RV will be returned.
9242 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
9244 PERL_ARGS_ASSERT_SV_SETREF_UV;
9246 sv_setuv(newSVrv(rv,classname), uv);
9251 =for apidoc sv_setref_nv
9253 Copies a double into a new SV, optionally blessing the SV. The C<rv>
9254 argument will be upgraded to an RV. That RV will be modified to point to
9255 the new SV. The C<classname> argument indicates the package for the
9256 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9257 will have a reference count of 1, and the RV will be returned.
9263 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
9265 PERL_ARGS_ASSERT_SV_SETREF_NV;
9267 sv_setnv(newSVrv(rv,classname), nv);
9272 =for apidoc sv_setref_pvn
9274 Copies a string into a new SV, optionally blessing the SV. The length of the
9275 string must be specified with C<n>. The C<rv> argument will be upgraded to
9276 an RV. That RV will be modified to point to the new SV. The C<classname>
9277 argument indicates the package for the blessing. Set C<classname> to
9278 C<NULL> to avoid the blessing. The new SV will have a reference count
9279 of 1, and the RV will be returned.
9281 Note that C<sv_setref_pv> copies the pointer while this copies the string.
9287 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
9288 const char *const pv, const STRLEN n)
9290 PERL_ARGS_ASSERT_SV_SETREF_PVN;
9292 sv_setpvn(newSVrv(rv,classname), pv, n);
9297 =for apidoc sv_bless
9299 Blesses an SV into a specified package. The SV must be an RV. The package
9300 must be designated by its stash (see C<gv_stashpv()>). The reference count
9301 of the SV is unaffected.
9307 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
9312 PERL_ARGS_ASSERT_SV_BLESS;
9315 Perl_croak(aTHX_ "Can't bless non-reference value");
9317 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
9318 if (SvIsCOW(tmpRef))
9319 sv_force_normal_flags(tmpRef, 0);
9320 if (SvREADONLY(tmpRef))
9321 Perl_croak_no_modify(aTHX);
9322 if (SvOBJECT(tmpRef)) {
9323 if (SvTYPE(tmpRef) != SVt_PVIO)
9325 SvREFCNT_dec(SvSTASH(tmpRef));
9328 SvOBJECT_on(tmpRef);
9329 if (SvTYPE(tmpRef) != SVt_PVIO)
9331 SvUPGRADE(tmpRef, SVt_PVMG);
9332 SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
9337 (void)SvAMAGIC_off(sv);
9339 if(SvSMAGICAL(tmpRef))
9340 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
9348 /* Downgrades a PVGV to a PVMG. If it’s actually a PVLV, we leave the type
9349 * as it is after unglobbing it.
9353 S_sv_unglob(pTHX_ SV *const sv)
9358 SV * const temp = sv_newmortal();
9360 PERL_ARGS_ASSERT_SV_UNGLOB;
9362 assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
9364 gv_efullname3(temp, MUTABLE_GV(sv), "*");
9367 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
9368 && HvNAME_get(stash))
9369 mro_method_changed_in(stash);
9370 gp_free(MUTABLE_GV(sv));
9373 sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
9377 if (GvNAME_HEK(sv)) {
9378 unshare_hek(GvNAME_HEK(sv));
9380 isGV_with_GP_off(sv);
9382 if(SvTYPE(sv) == SVt_PVGV) {
9383 /* need to keep SvANY(sv) in the right arena */
9384 xpvmg = new_XPVMG();
9385 StructCopy(SvANY(sv), xpvmg, XPVMG);
9386 del_XPVGV(SvANY(sv));
9389 SvFLAGS(sv) &= ~SVTYPEMASK;
9390 SvFLAGS(sv) |= SVt_PVMG;
9393 /* Intentionally not calling any local SET magic, as this isn't so much a
9394 set operation as merely an internal storage change. */
9395 sv_setsv_flags(sv, temp, 0);
9399 =for apidoc sv_unref_flags
9401 Unsets the RV status of the SV, and decrements the reference count of
9402 whatever was being referenced by the RV. This can almost be thought of
9403 as a reversal of C<newSVrv>. The C<cflags> argument can contain
9404 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
9405 (otherwise the decrementing is conditional on the reference count being
9406 different from one or the reference being a readonly SV).
9413 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
9415 SV* const target = SvRV(ref);
9417 PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
9419 if (SvWEAKREF(ref)) {
9420 sv_del_backref(target, ref);
9422 SvRV_set(ref, NULL);
9425 SvRV_set(ref, NULL);
9427 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
9428 assigned to as BEGIN {$a = \"Foo"} will fail. */
9429 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
9430 SvREFCNT_dec(target);
9431 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
9432 sv_2mortal(target); /* Schedule for freeing later */
9436 =for apidoc sv_untaint
9438 Untaint an SV. Use C<SvTAINTED_off> instead.
9443 Perl_sv_untaint(pTHX_ SV *const sv)
9445 PERL_ARGS_ASSERT_SV_UNTAINT;
9447 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9448 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9455 =for apidoc sv_tainted
9457 Test an SV for taintedness. Use C<SvTAINTED> instead.
9462 Perl_sv_tainted(pTHX_ SV *const sv)
9464 PERL_ARGS_ASSERT_SV_TAINTED;
9466 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9467 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9468 if (mg && (mg->mg_len & 1) )
9475 =for apidoc sv_setpviv
9477 Copies an integer into the given SV, also updating its string value.
9478 Does not handle 'set' magic. See C<sv_setpviv_mg>.
9484 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
9486 char buf[TYPE_CHARS(UV)];
9488 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
9490 PERL_ARGS_ASSERT_SV_SETPVIV;
9492 sv_setpvn(sv, ptr, ebuf - ptr);
9496 =for apidoc sv_setpviv_mg
9498 Like C<sv_setpviv>, but also handles 'set' magic.
9504 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
9506 PERL_ARGS_ASSERT_SV_SETPVIV_MG;
9512 #if defined(PERL_IMPLICIT_CONTEXT)
9514 /* pTHX_ magic can't cope with varargs, so this is a no-context
9515 * version of the main function, (which may itself be aliased to us).
9516 * Don't access this version directly.
9520 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
9525 PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
9527 va_start(args, pat);
9528 sv_vsetpvf(sv, pat, &args);
9532 /* pTHX_ magic can't cope with varargs, so this is a no-context
9533 * version of the main function, (which may itself be aliased to us).
9534 * Don't access this version directly.
9538 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9543 PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
9545 va_start(args, pat);
9546 sv_vsetpvf_mg(sv, pat, &args);
9552 =for apidoc sv_setpvf
9554 Works like C<sv_catpvf> but copies the text into the SV instead of
9555 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
9561 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
9565 PERL_ARGS_ASSERT_SV_SETPVF;
9567 va_start(args, pat);
9568 sv_vsetpvf(sv, pat, &args);
9573 =for apidoc sv_vsetpvf
9575 Works like C<sv_vcatpvf> but copies the text into the SV instead of
9576 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
9578 Usually used via its frontend C<sv_setpvf>.
9584 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9586 PERL_ARGS_ASSERT_SV_VSETPVF;
9588 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9592 =for apidoc sv_setpvf_mg
9594 Like C<sv_setpvf>, but also handles 'set' magic.
9600 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9604 PERL_ARGS_ASSERT_SV_SETPVF_MG;
9606 va_start(args, pat);
9607 sv_vsetpvf_mg(sv, pat, &args);
9612 =for apidoc sv_vsetpvf_mg
9614 Like C<sv_vsetpvf>, but also handles 'set' magic.
9616 Usually used via its frontend C<sv_setpvf_mg>.
9622 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9624 PERL_ARGS_ASSERT_SV_VSETPVF_MG;
9626 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9630 #if defined(PERL_IMPLICIT_CONTEXT)
9632 /* pTHX_ magic can't cope with varargs, so this is a no-context
9633 * version of the main function, (which may itself be aliased to us).
9634 * Don't access this version directly.
9638 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
9643 PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
9645 va_start(args, pat);
9646 sv_vcatpvf(sv, pat, &args);
9650 /* pTHX_ magic can't cope with varargs, so this is a no-context
9651 * version of the main function, (which may itself be aliased to us).
9652 * Don't access this version directly.
9656 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9661 PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9663 va_start(args, pat);
9664 sv_vcatpvf_mg(sv, pat, &args);
9670 =for apidoc sv_catpvf
9672 Processes its arguments like C<sprintf> and appends the formatted
9673 output to an SV. If the appended data contains "wide" characters
9674 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9675 and characters >255 formatted with %c), the original SV might get
9676 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
9677 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9678 valid UTF-8; if the original SV was bytes, the pattern should be too.
9683 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9687 PERL_ARGS_ASSERT_SV_CATPVF;
9689 va_start(args, pat);
9690 sv_vcatpvf(sv, pat, &args);
9695 =for apidoc sv_vcatpvf
9697 Processes its arguments like C<vsprintf> and appends the formatted output
9698 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
9700 Usually used via its frontend C<sv_catpvf>.
9706 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9708 PERL_ARGS_ASSERT_SV_VCATPVF;
9710 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9714 =for apidoc sv_catpvf_mg
9716 Like C<sv_catpvf>, but also handles 'set' magic.
9722 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9726 PERL_ARGS_ASSERT_SV_CATPVF_MG;
9728 va_start(args, pat);
9729 sv_vcatpvf_mg(sv, pat, &args);
9734 =for apidoc sv_vcatpvf_mg
9736 Like C<sv_vcatpvf>, but also handles 'set' magic.
9738 Usually used via its frontend C<sv_catpvf_mg>.
9744 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9746 PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9748 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9753 =for apidoc sv_vsetpvfn
9755 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9758 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9764 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9765 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9767 PERL_ARGS_ASSERT_SV_VSETPVFN;
9770 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9775 * Warn of missing argument to sprintf, and then return a defined value
9776 * to avoid inappropriate "use of uninit" warnings [perl #71000].
9778 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
9780 S_vcatpvfn_missing_argument(pTHX) {
9781 if (ckWARN(WARN_MISSING)) {
9782 Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
9783 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
9790 S_expect_number(pTHX_ char **const pattern)
9795 PERL_ARGS_ASSERT_EXPECT_NUMBER;
9797 switch (**pattern) {
9798 case '1': case '2': case '3':
9799 case '4': case '5': case '6':
9800 case '7': case '8': case '9':
9801 var = *(*pattern)++ - '0';
9802 while (isDIGIT(**pattern)) {
9803 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
9805 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
9813 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
9815 const int neg = nv < 0;
9818 PERL_ARGS_ASSERT_F0CONVERT;
9826 if (uv & 1 && uv == nv)
9827 uv--; /* Round to even */
9829 const unsigned dig = uv % 10;
9842 =for apidoc sv_vcatpvfn
9844 Processes its arguments like C<vsprintf> and appends the formatted output
9845 to an SV. Uses an array of SVs if the C style variable argument list is
9846 missing (NULL). When running with taint checks enabled, indicates via
9847 C<maybe_tainted> if results are untrustworthy (often due to the use of
9850 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9856 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
9857 vecstr = (U8*)SvPV_const(vecsv,veclen);\
9858 vec_utf8 = DO_UTF8(vecsv);
9860 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9863 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9864 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9872 static const char nullstr[] = "(null)";
9874 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
9875 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9877 /* Times 4: a decimal digit takes more than 3 binary digits.
9878 * NV_DIG: mantissa takes than many decimal digits.
9879 * Plus 32: Playing safe. */
9880 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9881 /* large enough for "%#.#f" --chip */
9882 /* what about long double NVs? --jhi */
9884 PERL_ARGS_ASSERT_SV_VCATPVFN;
9885 PERL_UNUSED_ARG(maybe_tainted);
9887 /* no matter what, this is a string now */
9888 (void)SvPV_force(sv, origlen);
9890 /* special-case "", "%s", and "%-p" (SVf - see below) */
9893 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9895 const char * const s = va_arg(*args, char*);
9896 sv_catpv(sv, s ? s : nullstr);
9898 else if (svix < svmax) {
9899 sv_catsv(sv, *svargs);
9902 S_vcatpvfn_missing_argument(aTHX);
9905 if (args && patlen == 3 && pat[0] == '%' &&
9906 pat[1] == '-' && pat[2] == 'p') {
9907 argsv = MUTABLE_SV(va_arg(*args, void*));
9908 sv_catsv(sv, argsv);
9912 #ifndef USE_LONG_DOUBLE
9913 /* special-case "%.<number>[gf]" */
9914 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9915 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9916 unsigned digits = 0;
9920 while (*pp >= '0' && *pp <= '9')
9921 digits = 10 * digits + (*pp++ - '0');
9922 if (pp - pat == (int)patlen - 1 && svix < svmax) {
9923 const NV nv = SvNV(*svargs);
9925 /* Add check for digits != 0 because it seems that some
9926 gconverts are buggy in this case, and we don't yet have
9927 a Configure test for this. */
9928 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9929 /* 0, point, slack */
9930 Gconvert(nv, (int)digits, 0, ebuf);
9932 if (*ebuf) /* May return an empty string for digits==0 */
9935 } else if (!digits) {
9938 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9939 sv_catpvn(sv, p, l);
9945 #endif /* !USE_LONG_DOUBLE */
9947 if (!args && svix < svmax && DO_UTF8(*svargs))
9950 patend = (char*)pat + patlen;
9951 for (p = (char*)pat; p < patend; p = q) {
9954 bool vectorize = FALSE;
9955 bool vectorarg = FALSE;
9956 bool vec_utf8 = FALSE;
9962 bool has_precis = FALSE;
9964 const I32 osvix = svix;
9965 bool is_utf8 = FALSE; /* is this item utf8? */
9966 #ifdef HAS_LDBL_SPRINTF_BUG
9967 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9968 with sfio - Allen <allens@cpan.org> */
9969 bool fix_ldbl_sprintf_bug = FALSE;
9973 U8 utf8buf[UTF8_MAXBYTES+1];
9974 STRLEN esignlen = 0;
9976 const char *eptr = NULL;
9977 const char *fmtstart;
9980 const U8 *vecstr = NULL;
9987 /* we need a long double target in case HAS_LONG_DOUBLE but
9990 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9998 const char *dotstr = ".";
9999 STRLEN dotstrlen = 1;
10000 I32 efix = 0; /* explicit format parameter index */
10001 I32 ewix = 0; /* explicit width index */
10002 I32 epix = 0; /* explicit precision index */
10003 I32 evix = 0; /* explicit vector index */
10004 bool asterisk = FALSE;
10006 /* echo everything up to the next format specification */
10007 for (q = p; q < patend && *q != '%'; ++q) ;
10009 if (has_utf8 && !pat_utf8)
10010 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
10012 sv_catpvn(sv, p, q - p);
10021 We allow format specification elements in this order:
10022 \d+\$ explicit format parameter index
10024 v|\*(\d+\$)?v vector with optional (optionally specified) arg
10025 0 flag (as above): repeated to allow "v02"
10026 \d+|\*(\d+\$)? width using optional (optionally specified) arg
10027 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
10029 [%bcdefginopsuxDFOUX] format (mandatory)
10034 As of perl5.9.3, printf format checking is on by default.
10035 Internally, perl uses %p formats to provide an escape to
10036 some extended formatting. This block deals with those
10037 extensions: if it does not match, (char*)q is reset and
10038 the normal format processing code is used.
10040 Currently defined extensions are:
10041 %p include pointer address (standard)
10042 %-p (SVf) include an SV (previously %_)
10043 %-<num>p include an SV with precision <num>
10044 %<num>p reserved for future extensions
10046 Robin Barker 2005-07-14
10048 %1p (VDf) removed. RMB 2007-10-19
10055 n = expect_number(&q);
10057 if (sv) { /* SVf */
10062 argsv = MUTABLE_SV(va_arg(*args, void*));
10063 eptr = SvPV_const(argsv, elen);
10064 if (DO_UTF8(argsv))
10069 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
10070 "internal %%<num>p might conflict with future printf extensions");
10076 if ( (width = expect_number(&q)) ) {
10091 if (plus == '+' && *q == ' ') /* '+' over ' ' */
10120 if ( (ewix = expect_number(&q)) )
10129 if ((vectorarg = asterisk)) {
10142 width = expect_number(&q);
10148 vecsv = va_arg(*args, SV*);
10150 vecsv = (evix > 0 && evix <= svmax)
10151 ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
10153 vecsv = svix < svmax
10154 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10156 dotstr = SvPV_const(vecsv, dotstrlen);
10157 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
10158 bad with tied or overloaded values that return UTF8. */
10159 if (DO_UTF8(vecsv))
10161 else if (has_utf8) {
10162 vecsv = sv_mortalcopy(vecsv);
10163 sv_utf8_upgrade(vecsv);
10164 dotstr = SvPV_const(vecsv, dotstrlen);
10171 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
10172 vecsv = svargs[efix ? efix-1 : svix++];
10173 vecstr = (U8*)SvPV_const(vecsv,veclen);
10174 vec_utf8 = DO_UTF8(vecsv);
10176 /* if this is a version object, we need to convert
10177 * back into v-string notation and then let the
10178 * vectorize happen normally
10180 if (sv_derived_from(vecsv, "version")) {
10181 char *version = savesvpv(vecsv);
10182 if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
10183 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
10184 "vector argument not supported with alpha versions");
10187 vecsv = sv_newmortal();
10188 scan_vstring(version, version + veclen, vecsv);
10189 vecstr = (U8*)SvPV_const(vecsv, veclen);
10190 vec_utf8 = DO_UTF8(vecsv);
10202 i = va_arg(*args, int);
10204 i = (ewix ? ewix <= svmax : svix < svmax) ?
10205 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10207 width = (i < 0) ? -i : i;
10217 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
10219 /* XXX: todo, support specified precision parameter */
10223 i = va_arg(*args, int);
10225 i = (ewix ? ewix <= svmax : svix < svmax)
10226 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10228 has_precis = !(i < 0);
10232 while (isDIGIT(*q))
10233 precis = precis * 10 + (*q++ - '0');
10242 case 'I': /* Ix, I32x, and I64x */
10244 if (q[1] == '6' && q[2] == '4') {
10250 if (q[1] == '3' && q[2] == '2') {
10260 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10271 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10272 if (*(q + 1) == 'l') { /* lld, llf */
10298 if (!vectorize && !args) {
10300 const I32 i = efix-1;
10301 argsv = (i >= 0 && i < svmax)
10302 ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
10304 argsv = (svix >= 0 && svix < svmax)
10305 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10309 switch (c = *q++) {
10316 uv = (args) ? va_arg(*args, int) : SvIV(argsv);
10318 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
10320 eptr = (char*)utf8buf;
10321 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
10335 eptr = va_arg(*args, char*);
10337 elen = strlen(eptr);
10339 eptr = (char *)nullstr;
10340 elen = sizeof nullstr - 1;
10344 eptr = SvPV_const(argsv, elen);
10345 if (DO_UTF8(argsv)) {
10346 STRLEN old_precis = precis;
10347 if (has_precis && precis < elen) {
10348 STRLEN ulen = sv_len_utf8(argsv);
10349 I32 p = precis > ulen ? ulen : precis;
10350 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
10353 if (width) { /* fudge width (can't fudge elen) */
10354 if (has_precis && precis < elen)
10355 width += precis - old_precis;
10357 width += elen - sv_len_utf8(argsv);
10364 if (has_precis && precis < elen)
10371 if (alt || vectorize)
10373 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
10394 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10403 esignbuf[esignlen++] = plus;
10407 case 'h': iv = (short)va_arg(*args, int); break;
10408 case 'l': iv = va_arg(*args, long); break;
10409 case 'V': iv = va_arg(*args, IV); break;
10410 default: iv = va_arg(*args, int); break;
10413 iv = va_arg(*args, Quad_t); break;
10420 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
10422 case 'h': iv = (short)tiv; break;
10423 case 'l': iv = (long)tiv; break;
10425 default: iv = tiv; break;
10428 iv = (Quad_t)tiv; break;
10434 if ( !vectorize ) /* we already set uv above */
10439 esignbuf[esignlen++] = plus;
10443 esignbuf[esignlen++] = '-';
10487 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10498 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
10499 case 'l': uv = va_arg(*args, unsigned long); break;
10500 case 'V': uv = va_arg(*args, UV); break;
10501 default: uv = va_arg(*args, unsigned); break;
10504 uv = va_arg(*args, Uquad_t); break;
10511 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
10513 case 'h': uv = (unsigned short)tuv; break;
10514 case 'l': uv = (unsigned long)tuv; break;
10516 default: uv = tuv; break;
10519 uv = (Uquad_t)tuv; break;
10528 char *ptr = ebuf + sizeof ebuf;
10529 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
10535 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
10539 } while (uv >>= 4);
10541 esignbuf[esignlen++] = '0';
10542 esignbuf[esignlen++] = c; /* 'x' or 'X' */
10548 *--ptr = '0' + dig;
10549 } while (uv >>= 3);
10550 if (alt && *ptr != '0')
10556 *--ptr = '0' + dig;
10557 } while (uv >>= 1);
10559 esignbuf[esignlen++] = '0';
10560 esignbuf[esignlen++] = c;
10563 default: /* it had better be ten or less */
10566 *--ptr = '0' + dig;
10567 } while (uv /= base);
10570 elen = (ebuf + sizeof ebuf) - ptr;
10574 zeros = precis - elen;
10575 else if (precis == 0 && elen == 1 && *eptr == '0'
10576 && !(base == 8 && alt)) /* "%#.0o" prints "0" */
10579 /* a precision nullifies the 0 flag. */
10586 /* FLOATING POINT */
10589 c = 'f'; /* maybe %F isn't supported here */
10591 case 'e': case 'E':
10593 case 'g': case 'G':
10597 /* This is evil, but floating point is even more evil */
10599 /* for SV-style calling, we can only get NV
10600 for C-style calling, we assume %f is double;
10601 for simplicity we allow any of %Lf, %llf, %qf for long double
10605 #if defined(USE_LONG_DOUBLE)
10609 /* [perl #20339] - we should accept and ignore %lf rather than die */
10613 #if defined(USE_LONG_DOUBLE)
10614 intsize = args ? 0 : 'q';
10618 #if defined(HAS_LONG_DOUBLE)
10627 /* now we need (long double) if intsize == 'q', else (double) */
10629 #if LONG_DOUBLESIZE > DOUBLESIZE
10631 va_arg(*args, long double) :
10632 va_arg(*args, double)
10634 va_arg(*args, double)
10639 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
10640 else. frexp() has some unspecified behaviour for those three */
10641 if (c != 'e' && c != 'E' && (nv * 0) == 0) {
10643 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
10644 will cast our (long double) to (double) */
10645 (void)Perl_frexp(nv, &i);
10646 if (i == PERL_INT_MIN)
10647 Perl_die(aTHX_ "panic: frexp");
10649 need = BIT_DIGITS(i);
10651 need += has_precis ? precis : 6; /* known default */
10656 #ifdef HAS_LDBL_SPRINTF_BUG
10657 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10658 with sfio - Allen <allens@cpan.org> */
10661 # define MY_DBL_MAX DBL_MAX
10662 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
10663 # if DOUBLESIZE >= 8
10664 # define MY_DBL_MAX 1.7976931348623157E+308L
10666 # define MY_DBL_MAX 3.40282347E+38L
10670 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10671 # define MY_DBL_MAX_BUG 1L
10673 # define MY_DBL_MAX_BUG MY_DBL_MAX
10677 # define MY_DBL_MIN DBL_MIN
10678 # else /* XXX guessing! -Allen */
10679 # if DOUBLESIZE >= 8
10680 # define MY_DBL_MIN 2.2250738585072014E-308L
10682 # define MY_DBL_MIN 1.17549435E-38L
10686 if ((intsize == 'q') && (c == 'f') &&
10687 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10688 (need < DBL_DIG)) {
10689 /* it's going to be short enough that
10690 * long double precision is not needed */
10692 if ((nv <= 0L) && (nv >= -0L))
10693 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10695 /* would use Perl_fp_class as a double-check but not
10696 * functional on IRIX - see perl.h comments */
10698 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10699 /* It's within the range that a double can represent */
10700 #if defined(DBL_MAX) && !defined(DBL_MIN)
10701 if ((nv >= ((long double)1/DBL_MAX)) ||
10702 (nv <= (-(long double)1/DBL_MAX)))
10704 fix_ldbl_sprintf_bug = TRUE;
10707 if (fix_ldbl_sprintf_bug == TRUE) {
10717 # undef MY_DBL_MAX_BUG
10720 #endif /* HAS_LDBL_SPRINTF_BUG */
10722 need += 20; /* fudge factor */
10723 if (PL_efloatsize < need) {
10724 Safefree(PL_efloatbuf);
10725 PL_efloatsize = need + 20; /* more fudge */
10726 Newx(PL_efloatbuf, PL_efloatsize, char);
10727 PL_efloatbuf[0] = '\0';
10730 if ( !(width || left || plus || alt) && fill != '0'
10731 && has_precis && intsize != 'q' ) { /* Shortcuts */
10732 /* See earlier comment about buggy Gconvert when digits,
10734 if ( c == 'g' && precis) {
10735 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10736 /* May return an empty string for digits==0 */
10737 if (*PL_efloatbuf) {
10738 elen = strlen(PL_efloatbuf);
10739 goto float_converted;
10741 } else if ( c == 'f' && !precis) {
10742 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10747 char *ptr = ebuf + sizeof ebuf;
10750 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10751 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10752 if (intsize == 'q') {
10753 /* Copy the one or more characters in a long double
10754 * format before the 'base' ([efgEFG]) character to
10755 * the format string. */
10756 static char const prifldbl[] = PERL_PRIfldbl;
10757 char const *p = prifldbl + sizeof(prifldbl) - 3;
10758 while (p >= prifldbl) { *--ptr = *p--; }
10763 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10768 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10780 /* No taint. Otherwise we are in the strange situation
10781 * where printf() taints but print($float) doesn't.
10783 #if defined(HAS_LONG_DOUBLE)
10784 elen = ((intsize == 'q')
10785 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
10786 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
10788 elen = my_sprintf(PL_efloatbuf, ptr, nv);
10792 eptr = PL_efloatbuf;
10800 i = SvCUR(sv) - origlen;
10803 case 'h': *(va_arg(*args, short*)) = i; break;
10804 default: *(va_arg(*args, int*)) = i; break;
10805 case 'l': *(va_arg(*args, long*)) = i; break;
10806 case 'V': *(va_arg(*args, IV*)) = i; break;
10809 *(va_arg(*args, Quad_t*)) = i; break;
10816 sv_setuv_mg(argsv, (UV)i);
10817 continue; /* not "break" */
10824 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
10825 && ckWARN(WARN_PRINTF))
10827 SV * const msg = sv_newmortal();
10828 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10829 (PL_op->op_type == OP_PRTF) ? "" : "s");
10830 if (fmtstart < patend) {
10831 const char * const fmtend = q < patend ? q : patend;
10833 sv_catpvs(msg, "\"%");
10834 for (f = fmtstart; f < fmtend; f++) {
10836 sv_catpvn(msg, f, 1);
10838 Perl_sv_catpvf(aTHX_ msg,
10839 "\\%03"UVof, (UV)*f & 0xFF);
10842 sv_catpvs(msg, "\"");
10844 sv_catpvs(msg, "end of string");
10846 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
10849 /* output mangled stuff ... */
10855 /* ... right here, because formatting flags should not apply */
10856 SvGROW(sv, SvCUR(sv) + elen + 1);
10858 Copy(eptr, p, elen, char);
10861 SvCUR_set(sv, p - SvPVX_const(sv));
10863 continue; /* not "break" */
10866 if (is_utf8 != has_utf8) {
10869 sv_utf8_upgrade(sv);
10872 const STRLEN old_elen = elen;
10873 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
10874 sv_utf8_upgrade(nsv);
10875 eptr = SvPVX_const(nsv);
10878 if (width) { /* fudge width (can't fudge elen) */
10879 width += elen - old_elen;
10885 have = esignlen + zeros + elen;
10887 Perl_croak_nocontext("%s", PL_memory_wrap);
10889 need = (have > width ? have : width);
10892 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
10893 Perl_croak_nocontext("%s", PL_memory_wrap);
10894 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10896 if (esignlen && fill == '0') {
10898 for (i = 0; i < (int)esignlen; i++)
10899 *p++ = esignbuf[i];
10901 if (gap && !left) {
10902 memset(p, fill, gap);
10905 if (esignlen && fill != '0') {
10907 for (i = 0; i < (int)esignlen; i++)
10908 *p++ = esignbuf[i];
10912 for (i = zeros; i; i--)
10916 Copy(eptr, p, elen, char);
10920 memset(p, ' ', gap);
10925 Copy(dotstr, p, dotstrlen, char);
10929 vectorize = FALSE; /* done iterating over vecstr */
10936 SvCUR_set(sv, p - SvPVX_const(sv));
10945 /* =========================================================================
10947 =head1 Cloning an interpreter
10949 All the macros and functions in this section are for the private use of
10950 the main function, perl_clone().
10952 The foo_dup() functions make an exact copy of an existing foo thingy.
10953 During the course of a cloning, a hash table is used to map old addresses
10954 to new addresses. The table is created and manipulated with the
10955 ptr_table_* functions.
10959 * =========================================================================*/
10962 #if defined(USE_ITHREADS)
10964 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
10965 #ifndef GpREFCNT_inc
10966 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10970 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
10971 that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
10972 If this changes, please unmerge ss_dup.
10973 Likewise, sv_dup_inc_multiple() relies on this fact. */
10974 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup_inc(s,t))
10975 #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
10976 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
10977 #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
10978 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
10979 #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
10980 #define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t))
10981 #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
10982 #define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t))
10983 #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
10984 #define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t))
10985 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
10986 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
10988 /* clone a parser */
10991 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
10995 PERL_ARGS_ASSERT_PARSER_DUP;
11000 /* look for it in the table first */
11001 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
11005 /* create anew and remember what it is */
11006 Newxz(parser, 1, yy_parser);
11007 ptr_table_store(PL_ptr_table, proto, parser);
11009 /* XXX these not yet duped */
11010 parser->old_parser = NULL;
11011 parser->stack = NULL;
11013 parser->stack_size = 0;
11014 /* XXX parser->stack->state = 0; */
11016 /* XXX eventually, just Copy() most of the parser struct ? */
11018 parser->lex_brackets = proto->lex_brackets;
11019 parser->lex_casemods = proto->lex_casemods;
11020 parser->lex_brackstack = savepvn(proto->lex_brackstack,
11021 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
11022 parser->lex_casestack = savepvn(proto->lex_casestack,
11023 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
11024 parser->lex_defer = proto->lex_defer;
11025 parser->lex_dojoin = proto->lex_dojoin;
11026 parser->lex_expect = proto->lex_expect;
11027 parser->lex_formbrack = proto->lex_formbrack;
11028 parser->lex_inpat = proto->lex_inpat;
11029 parser->lex_inwhat = proto->lex_inwhat;
11030 parser->lex_op = proto->lex_op;
11031 parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
11032 parser->lex_starts = proto->lex_starts;
11033 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
11034 parser->multi_close = proto->multi_close;
11035 parser->multi_open = proto->multi_open;
11036 parser->multi_start = proto->multi_start;
11037 parser->multi_end = proto->multi_end;
11038 parser->pending_ident = proto->pending_ident;
11039 parser->preambled = proto->preambled;
11040 parser->sublex_info = proto->sublex_info; /* XXX not quite right */
11041 parser->linestr = sv_dup_inc(proto->linestr, param);
11042 parser->expect = proto->expect;
11043 parser->copline = proto->copline;
11044 parser->last_lop_op = proto->last_lop_op;
11045 parser->lex_state = proto->lex_state;
11046 parser->rsfp = fp_dup(proto->rsfp, '<', param);
11047 /* rsfp_filters entries have fake IoDIRP() */
11048 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
11049 parser->in_my = proto->in_my;
11050 parser->in_my_stash = hv_dup(proto->in_my_stash, param);
11051 parser->error_count = proto->error_count;
11054 parser->linestr = sv_dup_inc(proto->linestr, param);
11057 char * const ols = SvPVX(proto->linestr);
11058 char * const ls = SvPVX(parser->linestr);
11060 parser->bufptr = ls + (proto->bufptr >= ols ?
11061 proto->bufptr - ols : 0);
11062 parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
11063 proto->oldbufptr - ols : 0);
11064 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
11065 proto->oldoldbufptr - ols : 0);
11066 parser->linestart = ls + (proto->linestart >= ols ?
11067 proto->linestart - ols : 0);
11068 parser->last_uni = ls + (proto->last_uni >= ols ?
11069 proto->last_uni - ols : 0);
11070 parser->last_lop = ls + (proto->last_lop >= ols ?
11071 proto->last_lop - ols : 0);
11073 parser->bufend = ls + SvCUR(parser->linestr);
11076 Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
11080 parser->endwhite = proto->endwhite;
11081 parser->faketokens = proto->faketokens;
11082 parser->lasttoke = proto->lasttoke;
11083 parser->nextwhite = proto->nextwhite;
11084 parser->realtokenstart = proto->realtokenstart;
11085 parser->skipwhite = proto->skipwhite;
11086 parser->thisclose = proto->thisclose;
11087 parser->thismad = proto->thismad;
11088 parser->thisopen = proto->thisopen;
11089 parser->thisstuff = proto->thisstuff;
11090 parser->thistoken = proto->thistoken;
11091 parser->thiswhite = proto->thiswhite;
11093 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
11094 parser->curforce = proto->curforce;
11096 Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
11097 Copy(proto->nexttype, parser->nexttype, 5, I32);
11098 parser->nexttoke = proto->nexttoke;
11101 /* XXX should clone saved_curcop here, but we aren't passed
11102 * proto_perl; so do it in perl_clone_using instead */
11108 /* duplicate a file handle */
11111 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
11115 PERL_ARGS_ASSERT_FP_DUP;
11116 PERL_UNUSED_ARG(type);
11119 return (PerlIO*)NULL;
11121 /* look for it in the table first */
11122 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
11126 /* create anew and remember what it is */
11127 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
11128 ptr_table_store(PL_ptr_table, fp, ret);
11132 /* duplicate a directory handle */
11135 Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
11141 register const Direntry_t *dirent;
11142 char smallbuf[256];
11148 PERL_UNUSED_CONTEXT;
11149 PERL_ARGS_ASSERT_DIRP_DUP;
11154 /* look for it in the table first */
11155 ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
11161 PERL_UNUSED_ARG(param);
11165 /* open the current directory (so we can switch back) */
11166 if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
11168 /* chdir to our dir handle and open the present working directory */
11169 if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
11170 PerlDir_close(pwd);
11171 return (DIR *)NULL;
11173 /* Now we should have two dir handles pointing to the same dir. */
11175 /* Be nice to the calling code and chdir back to where we were. */
11176 fchdir(my_dirfd(pwd)); /* If this fails, then what? */
11178 /* We have no need of the pwd handle any more. */
11179 PerlDir_close(pwd);
11182 # define d_namlen(d) (d)->d_namlen
11184 # define d_namlen(d) strlen((d)->d_name)
11186 /* Iterate once through dp, to get the file name at the current posi-
11187 tion. Then step back. */
11188 pos = PerlDir_tell(dp);
11189 if ((dirent = PerlDir_read(dp))) {
11190 len = d_namlen(dirent);
11191 if (len <= sizeof smallbuf) name = smallbuf;
11192 else Newx(name, len, char);
11193 Move(dirent->d_name, name, len, char);
11195 PerlDir_seek(dp, pos);
11197 /* Iterate through the new dir handle, till we find a file with the
11199 if (!dirent) /* just before the end */
11201 pos = PerlDir_tell(ret);
11202 if (PerlDir_read(ret)) continue; /* not there yet */
11203 PerlDir_seek(ret, pos); /* step back */
11207 const long pos0 = PerlDir_tell(ret);
11209 pos = PerlDir_tell(ret);
11210 if ((dirent = PerlDir_read(ret))) {
11211 if (len == d_namlen(dirent)
11212 && memEQ(name, dirent->d_name, len)) {
11214 PerlDir_seek(ret, pos); /* step back */
11217 /* else we are not there yet; keep iterating */
11219 else { /* This is not meant to happen. The best we can do is
11220 reset the iterator to the beginning. */
11221 PerlDir_seek(ret, pos0);
11228 if (name && name != smallbuf)
11233 ret = win32_dirp_dup(dp, param);
11236 /* pop it in the pointer table */
11238 ptr_table_store(PL_ptr_table, dp, ret);
11243 /* duplicate a typeglob */
11246 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
11250 PERL_ARGS_ASSERT_GP_DUP;
11254 /* look for it in the table first */
11255 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
11259 /* create anew and remember what it is */
11261 ptr_table_store(PL_ptr_table, gp, ret);
11264 /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
11265 on Newxz() to do this for us. */
11266 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
11267 ret->gp_io = io_dup_inc(gp->gp_io, param);
11268 ret->gp_form = cv_dup_inc(gp->gp_form, param);
11269 ret->gp_av = av_dup_inc(gp->gp_av, param);
11270 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
11271 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
11272 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
11273 ret->gp_cvgen = gp->gp_cvgen;
11274 ret->gp_line = gp->gp_line;
11275 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
11279 /* duplicate a chain of magic */
11282 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
11284 MAGIC *mgret = NULL;
11285 MAGIC **mgprev_p = &mgret;
11287 PERL_ARGS_ASSERT_MG_DUP;
11289 for (; mg; mg = mg->mg_moremagic) {
11292 if ((param->flags & CLONEf_JOIN_IN)
11293 && mg->mg_type == PERL_MAGIC_backref)
11294 /* when joining, we let the individual SVs add themselves to
11295 * backref as needed. */
11298 Newx(nmg, 1, MAGIC);
11300 mgprev_p = &(nmg->mg_moremagic);
11302 /* There was a comment "XXX copy dynamic vtable?" but as we don't have
11303 dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
11304 from the original commit adding Perl_mg_dup() - revision 4538.
11305 Similarly there is the annotation "XXX random ptr?" next to the
11306 assignment to nmg->mg_ptr. */
11309 /* FIXME for plugins
11310 if (nmg->mg_type == PERL_MAGIC_qr) {
11311 nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
11315 nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
11316 ? nmg->mg_type == PERL_MAGIC_backref
11317 /* The backref AV has its reference
11318 * count deliberately bumped by 1 */
11319 ? SvREFCNT_inc(av_dup_inc((const AV *)
11320 nmg->mg_obj, param))
11321 : sv_dup_inc(nmg->mg_obj, param)
11322 : sv_dup(nmg->mg_obj, param);
11324 if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
11325 if (nmg->mg_len > 0) {
11326 nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
11327 if (nmg->mg_type == PERL_MAGIC_overload_table &&
11328 AMT_AMAGIC((AMT*)nmg->mg_ptr))
11330 AMT * const namtp = (AMT*)nmg->mg_ptr;
11331 sv_dup_inc_multiple((SV**)(namtp->table),
11332 (SV**)(namtp->table), NofAMmeth, param);
11335 else if (nmg->mg_len == HEf_SVKEY)
11336 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
11338 if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
11339 nmg->mg_virtual->svt_dup(aTHX_ nmg, param);
11345 #endif /* USE_ITHREADS */
11347 struct ptr_tbl_arena {
11348 struct ptr_tbl_arena *next;
11349 struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */
11352 /* create a new pointer-mapping table */
11355 Perl_ptr_table_new(pTHX)
11358 PERL_UNUSED_CONTEXT;
11360 Newx(tbl, 1, PTR_TBL_t);
11361 tbl->tbl_max = 511;
11362 tbl->tbl_items = 0;
11363 tbl->tbl_arena = NULL;
11364 tbl->tbl_arena_next = NULL;
11365 tbl->tbl_arena_end = NULL;
11366 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
11370 #define PTR_TABLE_HASH(ptr) \
11371 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
11373 /* map an existing pointer using a table */
11375 STATIC PTR_TBL_ENT_t *
11376 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
11378 PTR_TBL_ENT_t *tblent;
11379 const UV hash = PTR_TABLE_HASH(sv);
11381 PERL_ARGS_ASSERT_PTR_TABLE_FIND;
11383 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
11384 for (; tblent; tblent = tblent->next) {
11385 if (tblent->oldval == sv)
11392 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
11394 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
11396 PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
11397 PERL_UNUSED_CONTEXT;
11399 return tblent ? tblent->newval : NULL;
11402 /* add a new entry to a pointer-mapping table */
11405 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
11407 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
11409 PERL_ARGS_ASSERT_PTR_TABLE_STORE;
11410 PERL_UNUSED_CONTEXT;
11413 tblent->newval = newsv;
11415 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
11417 if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
11418 struct ptr_tbl_arena *new_arena;
11420 Newx(new_arena, 1, struct ptr_tbl_arena);
11421 new_arena->next = tbl->tbl_arena;
11422 tbl->tbl_arena = new_arena;
11423 tbl->tbl_arena_next = new_arena->array;
11424 tbl->tbl_arena_end = new_arena->array
11425 + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
11428 tblent = tbl->tbl_arena_next++;
11430 tblent->oldval = oldsv;
11431 tblent->newval = newsv;
11432 tblent->next = tbl->tbl_ary[entry];
11433 tbl->tbl_ary[entry] = tblent;
11435 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
11436 ptr_table_split(tbl);
11440 /* double the hash bucket size of an existing ptr table */
11443 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
11445 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
11446 const UV oldsize = tbl->tbl_max + 1;
11447 UV newsize = oldsize * 2;
11450 PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
11451 PERL_UNUSED_CONTEXT;
11453 Renew(ary, newsize, PTR_TBL_ENT_t*);
11454 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
11455 tbl->tbl_max = --newsize;
11456 tbl->tbl_ary = ary;
11457 for (i=0; i < oldsize; i++, ary++) {
11458 PTR_TBL_ENT_t **entp = ary;
11459 PTR_TBL_ENT_t *ent = *ary;
11460 PTR_TBL_ENT_t **curentp;
11463 curentp = ary + oldsize;
11465 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
11467 ent->next = *curentp;
11477 /* remove all the entries from a ptr table */
11478 /* Deprecated - will be removed post 5.14 */
11481 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
11483 if (tbl && tbl->tbl_items) {
11484 struct ptr_tbl_arena *arena = tbl->tbl_arena;
11486 Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
11489 struct ptr_tbl_arena *next = arena->next;
11495 tbl->tbl_items = 0;
11496 tbl->tbl_arena = NULL;
11497 tbl->tbl_arena_next = NULL;
11498 tbl->tbl_arena_end = NULL;
11502 /* clear and free a ptr table */
11505 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
11507 struct ptr_tbl_arena *arena;
11513 arena = tbl->tbl_arena;
11516 struct ptr_tbl_arena *next = arena->next;
11522 Safefree(tbl->tbl_ary);
11526 #if defined(USE_ITHREADS)
11529 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
11531 PERL_ARGS_ASSERT_RVPV_DUP;
11534 if (SvWEAKREF(sstr)) {
11535 SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
11536 if (param->flags & CLONEf_JOIN_IN) {
11537 /* if joining, we add any back references individually rather
11538 * than copying the whole backref array */
11539 Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
11543 SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
11545 else if (SvPVX_const(sstr)) {
11546 /* Has something there */
11548 /* Normal PV - clone whole allocated space */
11549 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
11550 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
11551 /* Not that normal - actually sstr is copy on write.
11552 But we are a true, independant SV, so: */
11553 SvREADONLY_off(dstr);
11558 /* Special case - not normally malloced for some reason */
11559 if (isGV_with_GP(sstr)) {
11560 /* Don't need to do anything here. */
11562 else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
11563 /* A "shared" PV - clone it as "shared" PV */
11565 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
11569 /* Some other special case - random pointer */
11570 SvPV_set(dstr, (char *) SvPVX_const(sstr));
11575 /* Copy the NULL */
11576 SvPV_set(dstr, NULL);
11580 /* duplicate a list of SVs. source and dest may point to the same memory. */
11582 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
11583 SSize_t items, CLONE_PARAMS *const param)
11585 PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
11587 while (items-- > 0) {
11588 *dest++ = sv_dup_inc(*source++, param);
11594 /* duplicate an SV of any type (including AV, HV etc) */
11597 S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11602 PERL_ARGS_ASSERT_SV_DUP_COMMON;
11604 if (SvTYPE(sstr) == SVTYPEMASK) {
11605 #ifdef DEBUG_LEAKING_SCALARS_ABORT
11610 /* look for it in the table first */
11611 dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
11615 if(param->flags & CLONEf_JOIN_IN) {
11616 /** We are joining here so we don't want do clone
11617 something that is bad **/
11618 if (SvTYPE(sstr) == SVt_PVHV) {
11619 const HEK * const hvname = HvNAME_HEK(sstr);
11621 /** don't clone stashes if they already exist **/
11622 dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
11623 ptr_table_store(PL_ptr_table, sstr, dstr);
11629 /* create anew and remember what it is */
11632 #ifdef DEBUG_LEAKING_SCALARS
11633 dstr->sv_debug_optype = sstr->sv_debug_optype;
11634 dstr->sv_debug_line = sstr->sv_debug_line;
11635 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
11636 dstr->sv_debug_parent = (SV*)sstr;
11637 FREE_SV_DEBUG_FILE(dstr);
11638 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
11641 ptr_table_store(PL_ptr_table, sstr, dstr);
11644 SvFLAGS(dstr) = SvFLAGS(sstr);
11645 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
11646 SvREFCNT(dstr) = 0; /* must be before any other dups! */
11649 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
11650 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
11651 (void*)PL_watch_pvx, SvPVX_const(sstr));
11654 /* don't clone objects whose class has asked us not to */
11655 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
11660 switch (SvTYPE(sstr)) {
11662 SvANY(dstr) = NULL;
11665 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
11667 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11669 SvIV_set(dstr, SvIVX(sstr));
11673 SvANY(dstr) = new_XNV();
11674 SvNV_set(dstr, SvNVX(sstr));
11676 /* case SVt_BIND: */
11679 /* These are all the types that need complex bodies allocating. */
11681 const svtype sv_type = SvTYPE(sstr);
11682 const struct body_details *const sv_type_details
11683 = bodies_by_type + sv_type;
11687 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11702 assert(sv_type_details->body_size);
11703 if (sv_type_details->arena) {
11704 new_body_inline(new_body, sv_type);
11706 = (void*)((char*)new_body - sv_type_details->offset);
11708 new_body = new_NOARENA(sv_type_details);
11712 SvANY(dstr) = new_body;
11715 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
11716 ((char*)SvANY(dstr)) + sv_type_details->offset,
11717 sv_type_details->copy, char);
11719 Copy(((char*)SvANY(sstr)),
11720 ((char*)SvANY(dstr)),
11721 sv_type_details->body_size + sv_type_details->offset, char);
11724 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
11725 && !isGV_with_GP(dstr)
11726 && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
11727 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11729 /* The Copy above means that all the source (unduplicated) pointers
11730 are now in the destination. We can check the flags and the
11731 pointers in either, but it's possible that there's less cache
11732 missing by always going for the destination.
11733 FIXME - instrument and check that assumption */
11734 if (sv_type >= SVt_PVMG) {
11735 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
11736 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
11737 } else if (SvMAGIC(dstr))
11738 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
11740 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
11743 /* The cast silences a GCC warning about unhandled types. */
11744 switch ((int)sv_type) {
11754 /* FIXME for plugins */
11755 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
11758 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
11759 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
11760 LvTARG(dstr) = dstr;
11761 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
11762 LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
11764 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
11766 /* non-GP case already handled above */
11767 if(isGV_with_GP(sstr)) {
11768 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
11769 /* Don't call sv_add_backref here as it's going to be
11770 created as part of the magic cloning of the symbol
11771 table--unless this is during a join and the stash
11772 is not actually being cloned. */
11773 /* Danger Will Robinson - GvGP(dstr) isn't initialised
11774 at the point of this comment. */
11775 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
11776 if (param->flags & CLONEf_JOIN_IN)
11777 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
11778 GvGP(dstr) = gp_dup(GvGP(sstr), param);
11779 (void)GpREFCNT_inc(GvGP(dstr));
11783 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
11784 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
11785 /* I have no idea why fake dirp (rsfps)
11786 should be treated differently but otherwise
11787 we end up with leaks -- sky*/
11788 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
11789 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
11790 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
11792 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
11793 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
11794 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
11795 if (IoDIRP(dstr)) {
11796 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr), param);
11799 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
11801 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param);
11803 if (IoOFP(dstr) == IoIFP(sstr))
11804 IoOFP(dstr) = IoIFP(dstr);
11806 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
11807 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
11808 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
11809 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
11812 /* avoid cloning an empty array */
11813 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
11814 SV **dst_ary, **src_ary;
11815 SSize_t items = AvFILLp((const AV *)sstr) + 1;
11817 src_ary = AvARRAY((const AV *)sstr);
11818 Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
11819 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
11820 AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
11821 AvALLOC((const AV *)dstr) = dst_ary;
11822 if (AvREAL((const AV *)sstr)) {
11823 dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
11827 while (items-- > 0)
11828 *dst_ary++ = sv_dup(*src_ary++, param);
11830 items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
11831 while (items-- > 0) {
11832 *dst_ary++ = &PL_sv_undef;
11836 AvARRAY(MUTABLE_AV(dstr)) = NULL;
11837 AvALLOC((const AV *)dstr) = (SV**)NULL;
11838 AvMAX( (const AV *)dstr) = -1;
11839 AvFILLp((const AV *)dstr) = -1;
11843 if (HvARRAY((const HV *)sstr)) {
11845 const bool sharekeys = !!HvSHAREKEYS(sstr);
11846 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
11847 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
11849 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
11850 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
11852 HvARRAY(dstr) = (HE**)darray;
11853 while (i <= sxhv->xhv_max) {
11854 const HE * const source = HvARRAY(sstr)[i];
11855 HvARRAY(dstr)[i] = source
11856 ? he_dup(source, sharekeys, param) : 0;
11860 const struct xpvhv_aux * const saux = HvAUX(sstr);
11861 struct xpvhv_aux * const daux = HvAUX(dstr);
11862 /* This flag isn't copied. */
11863 /* SvOOK_on(hv) attacks the IV flags. */
11864 SvFLAGS(dstr) |= SVf_OOK;
11866 if (saux->xhv_name_count) {
11867 HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
11869 = saux->xhv_name_count < 0
11870 ? -saux->xhv_name_count
11871 : saux->xhv_name_count;
11872 HEK **shekp = sname + count;
11874 Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *);
11875 dhekp = daux->xhv_name_u.xhvnameu_names + count;
11876 while (shekp-- > sname) {
11878 *dhekp = hek_dup(*shekp, param);
11882 daux->xhv_name_u.xhvnameu_name
11883 = hek_dup(saux->xhv_name_u.xhvnameu_name,
11886 daux->xhv_name_count = saux->xhv_name_count;
11888 daux->xhv_riter = saux->xhv_riter;
11889 daux->xhv_eiter = saux->xhv_eiter
11890 ? he_dup(saux->xhv_eiter,
11891 cBOOL(HvSHAREKEYS(sstr)), param) : 0;
11892 /* backref array needs refcnt=2; see sv_add_backref */
11893 daux->xhv_backreferences =
11894 (param->flags & CLONEf_JOIN_IN)
11895 /* when joining, we let the individual GVs and
11896 * CVs add themselves to backref as
11897 * needed. This avoids pulling in stuff
11898 * that isn't required, and simplifies the
11899 * case where stashes aren't cloned back
11900 * if they already exist in the parent
11903 : saux->xhv_backreferences
11904 ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
11905 ? MUTABLE_AV(SvREFCNT_inc(
11906 sv_dup_inc((const SV *)
11907 saux->xhv_backreferences, param)))
11908 : MUTABLE_AV(sv_dup((const SV *)
11909 saux->xhv_backreferences, param))
11912 daux->xhv_mro_meta = saux->xhv_mro_meta
11913 ? mro_meta_dup(saux->xhv_mro_meta, param)
11916 /* Record stashes for possible cloning in Perl_clone(). */
11918 av_push(param->stashes, dstr);
11922 HvARRAY(MUTABLE_HV(dstr)) = NULL;
11925 if (!(param->flags & CLONEf_COPY_STACKS)) {
11930 /* NOTE: not refcounted */
11931 SvANY(MUTABLE_CV(dstr))->xcv_stash =
11932 hv_dup(CvSTASH(dstr), param);
11933 if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
11934 Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
11935 if (!CvISXSUB(dstr)) {
11937 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
11939 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
11940 } else if (CvCONST(dstr)) {
11941 CvXSUBANY(dstr).any_ptr =
11942 sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
11944 /* don't dup if copying back - CvGV isn't refcounted, so the
11945 * duped GV may never be freed. A bit of a hack! DAPM */
11946 SvANY(MUTABLE_CV(dstr))->xcv_gv =
11948 ? gv_dup_inc(CvGV(sstr), param)
11949 : (param->flags & CLONEf_JOIN_IN)
11951 : gv_dup(CvGV(sstr), param);
11953 CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
11955 CvWEAKOUTSIDE(sstr)
11956 ? cv_dup( CvOUTSIDE(dstr), param)
11957 : cv_dup_inc(CvOUTSIDE(dstr), param);
11963 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11970 Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11972 PERL_ARGS_ASSERT_SV_DUP_INC;
11973 return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
11977 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11979 SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
11980 PERL_ARGS_ASSERT_SV_DUP;
11982 /* Track every SV that (at least initially) had a reference count of 0.
11983 We need to do this by holding an actual reference to it in this array.
11984 If we attempt to cheat, turn AvREAL_off(), and store only pointers
11985 (akin to the stashes hash, and the perl stack), we come unstuck if
11986 a weak reference (or other SV legitimately SvREFCNT() == 0 for this
11987 thread) is manipulated in a CLONE method, because CLONE runs before the
11988 unreferenced array is walked to find SVs still with SvREFCNT() == 0
11989 (and fix things up by giving each a reference via the temps stack).
11990 Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
11991 then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
11992 before the walk of unreferenced happens and a reference to that is SV
11993 added to the temps stack. At which point we have the same SV considered
11994 to be in use, and free to be re-used. Not good.
11996 if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
11997 assert(param->unreferenced);
11998 av_push(param->unreferenced, SvREFCNT_inc(dstr));
12004 /* duplicate a context */
12007 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
12009 PERL_CONTEXT *ncxs;
12011 PERL_ARGS_ASSERT_CX_DUP;
12014 return (PERL_CONTEXT*)NULL;
12016 /* look for it in the table first */
12017 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
12021 /* create anew and remember what it is */
12022 Newx(ncxs, max + 1, PERL_CONTEXT);
12023 ptr_table_store(PL_ptr_table, cxs, ncxs);
12024 Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
12027 PERL_CONTEXT * const ncx = &ncxs[ix];
12028 if (CxTYPE(ncx) == CXt_SUBST) {
12029 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
12032 switch (CxTYPE(ncx)) {
12034 ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
12035 ? cv_dup_inc(ncx->blk_sub.cv, param)
12036 : cv_dup(ncx->blk_sub.cv,param));
12037 ncx->blk_sub.argarray = (CxHASARGS(ncx)
12038 ? av_dup_inc(ncx->blk_sub.argarray,
12041 ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
12043 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
12044 ncx->blk_sub.oldcomppad);
12047 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
12049 ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
12051 case CXt_LOOP_LAZYSV:
12052 ncx->blk_loop.state_u.lazysv.end
12053 = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
12054 /* We are taking advantage of av_dup_inc and sv_dup_inc
12055 actually being the same function, and order equivalance of
12057 We can assert the later [but only at run time :-(] */
12058 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
12059 (void *) &ncx->blk_loop.state_u.lazysv.cur);
12061 ncx->blk_loop.state_u.ary.ary
12062 = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
12063 case CXt_LOOP_LAZYIV:
12064 case CXt_LOOP_PLAIN:
12065 if (CxPADLOOP(ncx)) {
12066 ncx->blk_loop.itervar_u.oldcomppad
12067 = (PAD*)ptr_table_fetch(PL_ptr_table,
12068 ncx->blk_loop.itervar_u.oldcomppad);
12070 ncx->blk_loop.itervar_u.gv
12071 = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
12076 ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
12077 ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
12078 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
12091 /* duplicate a stack info structure */
12094 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
12098 PERL_ARGS_ASSERT_SI_DUP;
12101 return (PERL_SI*)NULL;
12103 /* look for it in the table first */
12104 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
12108 /* create anew and remember what it is */
12109 Newxz(nsi, 1, PERL_SI);
12110 ptr_table_store(PL_ptr_table, si, nsi);
12112 nsi->si_stack = av_dup_inc(si->si_stack, param);
12113 nsi->si_cxix = si->si_cxix;
12114 nsi->si_cxmax = si->si_cxmax;
12115 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
12116 nsi->si_type = si->si_type;
12117 nsi->si_prev = si_dup(si->si_prev, param);
12118 nsi->si_next = si_dup(si->si_next, param);
12119 nsi->si_markoff = si->si_markoff;
12124 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
12125 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
12126 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
12127 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
12128 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
12129 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
12130 #define POPUV(ss,ix) ((ss)[--(ix)].any_uv)
12131 #define TOPUV(ss,ix) ((ss)[ix].any_uv)
12132 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
12133 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
12134 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
12135 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
12136 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
12137 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
12138 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
12139 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
12142 #define pv_dup_inc(p) SAVEPV(p)
12143 #define pv_dup(p) SAVEPV(p)
12144 #define svp_dup_inc(p,pp) any_dup(p,pp)
12146 /* map any object to the new equivent - either something in the
12147 * ptr table, or something in the interpreter structure
12151 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
12155 PERL_ARGS_ASSERT_ANY_DUP;
12158 return (void*)NULL;
12160 /* look for it in the table first */
12161 ret = ptr_table_fetch(PL_ptr_table, v);
12165 /* see if it is part of the interpreter structure */
12166 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
12167 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
12175 /* duplicate the save stack */
12178 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
12181 ANY * const ss = proto_perl->Isavestack;
12182 const I32 max = proto_perl->Isavestack_max;
12183 I32 ix = proto_perl->Isavestack_ix;
12196 void (*dptr) (void*);
12197 void (*dxptr) (pTHX_ void*);
12199 PERL_ARGS_ASSERT_SS_DUP;
12201 Newxz(nss, max, ANY);
12204 const UV uv = POPUV(ss,ix);
12205 const U8 type = (U8)uv & SAVE_MASK;
12207 TOPUV(nss,ix) = uv;
12209 case SAVEt_CLEARSV:
12211 case SAVEt_HELEM: /* hash element */
12212 sv = (const SV *)POPPTR(ss,ix);
12213 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12215 case SAVEt_ITEM: /* normal string */
12216 case SAVEt_GVSV: /* scalar slot in GV */
12217 case SAVEt_SV: /* scalar reference */
12218 sv = (const SV *)POPPTR(ss,ix);
12219 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12222 case SAVEt_MORTALIZESV:
12223 sv = (const SV *)POPPTR(ss,ix);
12224 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12226 case SAVEt_SHARED_PVREF: /* char* in shared space */
12227 c = (char*)POPPTR(ss,ix);
12228 TOPPTR(nss,ix) = savesharedpv(c);
12229 ptr = POPPTR(ss,ix);
12230 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12232 case SAVEt_GENERIC_SVREF: /* generic sv */
12233 case SAVEt_SVREF: /* scalar reference */
12234 sv = (const SV *)POPPTR(ss,ix);
12235 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12236 ptr = POPPTR(ss,ix);
12237 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
12239 case SAVEt_HV: /* hash reference */
12240 case SAVEt_AV: /* array reference */
12241 sv = (const SV *) POPPTR(ss,ix);
12242 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12244 case SAVEt_COMPPAD:
12246 sv = (const SV *) POPPTR(ss,ix);
12247 TOPPTR(nss,ix) = sv_dup(sv, param);
12249 case SAVEt_INT: /* int reference */
12250 ptr = POPPTR(ss,ix);
12251 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12252 intval = (int)POPINT(ss,ix);
12253 TOPINT(nss,ix) = intval;
12255 case SAVEt_LONG: /* long reference */
12256 ptr = POPPTR(ss,ix);
12257 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12258 longval = (long)POPLONG(ss,ix);
12259 TOPLONG(nss,ix) = longval;
12261 case SAVEt_I32: /* I32 reference */
12262 case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
12263 ptr = POPPTR(ss,ix);
12264 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12266 TOPINT(nss,ix) = i;
12268 case SAVEt_IV: /* IV reference */
12269 ptr = POPPTR(ss,ix);
12270 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12272 TOPIV(nss,ix) = iv;
12274 case SAVEt_HPTR: /* HV* reference */
12275 case SAVEt_APTR: /* AV* reference */
12276 case SAVEt_SPTR: /* SV* reference */
12277 ptr = POPPTR(ss,ix);
12278 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12279 sv = (const SV *)POPPTR(ss,ix);
12280 TOPPTR(nss,ix) = sv_dup(sv, param);
12282 case SAVEt_VPTR: /* random* reference */
12283 ptr = POPPTR(ss,ix);
12284 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12286 case SAVEt_INT_SMALL:
12287 case SAVEt_I32_SMALL:
12288 case SAVEt_I16: /* I16 reference */
12289 case SAVEt_I8: /* I8 reference */
12291 ptr = POPPTR(ss,ix);
12292 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12294 case SAVEt_GENERIC_PVREF: /* generic char* */
12295 case SAVEt_PPTR: /* char* reference */
12296 ptr = POPPTR(ss,ix);
12297 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12298 c = (char*)POPPTR(ss,ix);
12299 TOPPTR(nss,ix) = pv_dup(c);
12301 case SAVEt_GP: /* scalar reference */
12302 gp = (GP*)POPPTR(ss,ix);
12303 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
12304 (void)GpREFCNT_inc(gp);
12305 gv = (const GV *)POPPTR(ss,ix);
12306 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
12309 ptr = POPPTR(ss,ix);
12310 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
12311 /* these are assumed to be refcounted properly */
12313 switch (((OP*)ptr)->op_type) {
12315 case OP_LEAVESUBLV:
12319 case OP_LEAVEWRITE:
12320 TOPPTR(nss,ix) = ptr;
12323 (void) OpREFCNT_inc(o);
12327 TOPPTR(nss,ix) = NULL;
12332 TOPPTR(nss,ix) = NULL;
12334 case SAVEt_FREECOPHH:
12335 ptr = POPPTR(ss,ix);
12336 TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr);
12339 hv = (const HV *)POPPTR(ss,ix);
12340 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12342 TOPINT(nss,ix) = i;
12345 c = (char*)POPPTR(ss,ix);
12346 TOPPTR(nss,ix) = pv_dup_inc(c);
12348 case SAVEt_STACK_POS: /* Position on Perl stack */
12350 TOPINT(nss,ix) = i;
12352 case SAVEt_DESTRUCTOR:
12353 ptr = POPPTR(ss,ix);
12354 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
12355 dptr = POPDPTR(ss,ix);
12356 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
12357 any_dup(FPTR2DPTR(void *, dptr),
12360 case SAVEt_DESTRUCTOR_X:
12361 ptr = POPPTR(ss,ix);
12362 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
12363 dxptr = POPDXPTR(ss,ix);
12364 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
12365 any_dup(FPTR2DPTR(void *, dxptr),
12368 case SAVEt_REGCONTEXT:
12370 ix -= uv >> SAVE_TIGHT_SHIFT;
12372 case SAVEt_AELEM: /* array element */
12373 sv = (const SV *)POPPTR(ss,ix);
12374 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12376 TOPINT(nss,ix) = i;
12377 av = (const AV *)POPPTR(ss,ix);
12378 TOPPTR(nss,ix) = av_dup_inc(av, param);
12381 ptr = POPPTR(ss,ix);
12382 TOPPTR(nss,ix) = ptr;
12385 ptr = POPPTR(ss,ix);
12386 ptr = cophh_copy((COPHH*)ptr);
12387 TOPPTR(nss,ix) = ptr;
12389 TOPINT(nss,ix) = i;
12390 if (i & HINT_LOCALIZE_HH) {
12391 hv = (const HV *)POPPTR(ss,ix);
12392 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12395 case SAVEt_PADSV_AND_MORTALIZE:
12396 longval = (long)POPLONG(ss,ix);
12397 TOPLONG(nss,ix) = longval;
12398 ptr = POPPTR(ss,ix);
12399 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12400 sv = (const SV *)POPPTR(ss,ix);
12401 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12403 case SAVEt_SET_SVFLAGS:
12405 TOPINT(nss,ix) = i;
12407 TOPINT(nss,ix) = i;
12408 sv = (const SV *)POPPTR(ss,ix);
12409 TOPPTR(nss,ix) = sv_dup(sv, param);
12411 case SAVEt_RE_STATE:
12413 const struct re_save_state *const old_state
12414 = (struct re_save_state *)
12415 (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12416 struct re_save_state *const new_state
12417 = (struct re_save_state *)
12418 (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12420 Copy(old_state, new_state, 1, struct re_save_state);
12421 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
12423 new_state->re_state_bostr
12424 = pv_dup(old_state->re_state_bostr);
12425 new_state->re_state_reginput
12426 = pv_dup(old_state->re_state_reginput);
12427 new_state->re_state_regeol
12428 = pv_dup(old_state->re_state_regeol);
12429 new_state->re_state_regoffs
12430 = (regexp_paren_pair*)
12431 any_dup(old_state->re_state_regoffs, proto_perl);
12432 new_state->re_state_reglastparen
12433 = (U32*) any_dup(old_state->re_state_reglastparen,
12435 new_state->re_state_reglastcloseparen
12436 = (U32*)any_dup(old_state->re_state_reglastcloseparen,
12438 /* XXX This just has to be broken. The old save_re_context
12439 code did SAVEGENERICPV(PL_reg_start_tmp);
12440 PL_reg_start_tmp is char **.
12441 Look above to what the dup code does for
12442 SAVEt_GENERIC_PVREF
12443 It can never have worked.
12444 So this is merely a faithful copy of the exiting bug: */
12445 new_state->re_state_reg_start_tmp
12446 = (char **) pv_dup((char *)
12447 old_state->re_state_reg_start_tmp);
12448 /* I assume that it only ever "worked" because no-one called
12449 (pseudo)fork while the regexp engine had re-entered itself.
12451 #ifdef PERL_OLD_COPY_ON_WRITE
12452 new_state->re_state_nrs
12453 = sv_dup(old_state->re_state_nrs, param);
12455 new_state->re_state_reg_magic
12456 = (MAGIC*) any_dup(old_state->re_state_reg_magic,
12458 new_state->re_state_reg_oldcurpm
12459 = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
12461 new_state->re_state_reg_curpm
12462 = (PMOP*) any_dup(old_state->re_state_reg_curpm,
12464 new_state->re_state_reg_oldsaved
12465 = pv_dup(old_state->re_state_reg_oldsaved);
12466 new_state->re_state_reg_poscache
12467 = pv_dup(old_state->re_state_reg_poscache);
12468 new_state->re_state_reg_starttry
12469 = pv_dup(old_state->re_state_reg_starttry);
12472 case SAVEt_COMPILE_WARNINGS:
12473 ptr = POPPTR(ss,ix);
12474 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
12477 ptr = POPPTR(ss,ix);
12478 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
12482 "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
12490 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
12491 * flag to the result. This is done for each stash before cloning starts,
12492 * so we know which stashes want their objects cloned */
12495 do_mark_cloneable_stash(pTHX_ SV *const sv)
12497 const HEK * const hvname = HvNAME_HEK((const HV *)sv);
12499 GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
12500 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
12501 if (cloner && GvCV(cloner)) {
12508 mXPUSHs(newSVhek(hvname));
12510 call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
12517 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
12525 =for apidoc perl_clone
12527 Create and return a new interpreter by cloning the current one.
12529 perl_clone takes these flags as parameters:
12531 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
12532 without it we only clone the data and zero the stacks,
12533 with it we copy the stacks and the new perl interpreter is
12534 ready to run at the exact same point as the previous one.
12535 The pseudo-fork code uses COPY_STACKS while the
12536 threads->create doesn't.
12538 CLONEf_KEEP_PTR_TABLE
12539 perl_clone keeps a ptr_table with the pointer of the old
12540 variable as a key and the new variable as a value,
12541 this allows it to check if something has been cloned and not
12542 clone it again but rather just use the value and increase the
12543 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
12544 the ptr_table using the function
12545 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
12546 reason to keep it around is if you want to dup some of your own
12547 variable who are outside the graph perl scans, example of this
12548 code is in threads.xs create
12551 This is a win32 thing, it is ignored on unix, it tells perls
12552 win32host code (which is c++) to clone itself, this is needed on
12553 win32 if you want to run two threads at the same time,
12554 if you just want to do some stuff in a separate perl interpreter
12555 and then throw it away and return to the original one,
12556 you don't need to do anything.
12561 /* XXX the above needs expanding by someone who actually understands it ! */
12562 EXTERN_C PerlInterpreter *
12563 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
12566 perl_clone(PerlInterpreter *proto_perl, UV flags)
12569 #ifdef PERL_IMPLICIT_SYS
12571 PERL_ARGS_ASSERT_PERL_CLONE;
12573 /* perlhost.h so we need to call into it
12574 to clone the host, CPerlHost should have a c interface, sky */
12576 if (flags & CLONEf_CLONE_HOST) {
12577 return perl_clone_host(proto_perl,flags);
12579 return perl_clone_using(proto_perl, flags,
12581 proto_perl->IMemShared,
12582 proto_perl->IMemParse,
12584 proto_perl->IStdIO,
12588 proto_perl->IProc);
12592 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
12593 struct IPerlMem* ipM, struct IPerlMem* ipMS,
12594 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
12595 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
12596 struct IPerlDir* ipD, struct IPerlSock* ipS,
12597 struct IPerlProc* ipP)
12599 /* XXX many of the string copies here can be optimized if they're
12600 * constants; they need to be allocated as common memory and just
12601 * their pointers copied. */
12604 CLONE_PARAMS clone_params;
12605 CLONE_PARAMS* const param = &clone_params;
12607 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
12609 PERL_ARGS_ASSERT_PERL_CLONE_USING;
12610 #else /* !PERL_IMPLICIT_SYS */
12612 CLONE_PARAMS clone_params;
12613 CLONE_PARAMS* param = &clone_params;
12614 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
12616 PERL_ARGS_ASSERT_PERL_CLONE;
12617 #endif /* PERL_IMPLICIT_SYS */
12619 /* for each stash, determine whether its objects should be cloned */
12620 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
12621 PERL_SET_THX(my_perl);
12624 PoisonNew(my_perl, 1, PerlInterpreter);
12629 PL_scopestack_name = 0;
12631 PL_savestack_ix = 0;
12632 PL_savestack_max = -1;
12633 PL_sig_pending = 0;
12635 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
12636 # ifdef DEBUG_LEAKING_SCALARS
12637 PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
12639 #else /* !DEBUGGING */
12640 Zero(my_perl, 1, PerlInterpreter);
12641 #endif /* DEBUGGING */
12643 #ifdef PERL_IMPLICIT_SYS
12644 /* host pointers */
12646 PL_MemShared = ipMS;
12647 PL_MemParse = ipMP;
12654 #endif /* PERL_IMPLICIT_SYS */
12656 param->flags = flags;
12657 /* Nothing in the core code uses this, but we make it available to
12658 extensions (using mg_dup). */
12659 param->proto_perl = proto_perl;
12660 /* Likely nothing will use this, but it is initialised to be consistent
12661 with Perl_clone_params_new(). */
12662 param->new_perl = my_perl;
12663 param->unreferenced = NULL;
12665 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
12667 PL_body_arenas = NULL;
12668 Zero(&PL_body_roots, 1, PL_body_roots);
12671 PL_sv_objcount = 0;
12673 PL_sv_arenaroot = NULL;
12675 PL_debug = proto_perl->Idebug;
12677 PL_hash_seed = proto_perl->Ihash_seed;
12678 PL_rehash_seed = proto_perl->Irehash_seed;
12680 #ifdef USE_REENTRANT_API
12681 /* XXX: things like -Dm will segfault here in perlio, but doing
12682 * PERL_SET_CONTEXT(proto_perl);
12683 * breaks too many other things
12685 Perl_reentrant_init(aTHX);
12688 /* create SV map for pointer relocation */
12689 PL_ptr_table = ptr_table_new();
12691 /* initialize these special pointers as early as possible */
12692 SvANY(&PL_sv_undef) = NULL;
12693 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
12694 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
12695 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
12697 SvANY(&PL_sv_no) = new_XPVNV();
12698 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
12699 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12700 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12701 SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
12702 SvCUR_set(&PL_sv_no, 0);
12703 SvLEN_set(&PL_sv_no, 1);
12704 SvIV_set(&PL_sv_no, 0);
12705 SvNV_set(&PL_sv_no, 0);
12706 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
12708 SvANY(&PL_sv_yes) = new_XPVNV();
12709 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
12710 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12711 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12712 SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
12713 SvCUR_set(&PL_sv_yes, 1);
12714 SvLEN_set(&PL_sv_yes, 2);
12715 SvIV_set(&PL_sv_yes, 1);
12716 SvNV_set(&PL_sv_yes, 1);
12717 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
12719 /* dbargs array probably holds garbage */
12722 /* create (a non-shared!) shared string table */
12723 PL_strtab = newHV();
12724 HvSHAREKEYS_off(PL_strtab);
12725 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
12726 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
12728 PL_compiling = proto_perl->Icompiling;
12730 /* These two PVs will be free'd special way so must set them same way op.c does */
12731 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
12732 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
12734 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
12735 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
12737 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
12738 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
12739 CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));
12740 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
12741 #ifdef PERL_DEBUG_READONLY_OPS
12746 /* pseudo environmental stuff */
12747 PL_origargc = proto_perl->Iorigargc;
12748 PL_origargv = proto_perl->Iorigargv;
12750 param->stashes = newAV(); /* Setup array of objects to call clone on */
12751 /* This makes no difference to the implementation, as it always pushes
12752 and shifts pointers to other SVs without changing their reference
12753 count, with the array becoming empty before it is freed. However, it
12754 makes it conceptually clear what is going on, and will avoid some
12755 work inside av.c, filling slots between AvFILL() and AvMAX() with
12756 &PL_sv_undef, and SvREFCNT_dec()ing those. */
12757 AvREAL_off(param->stashes);
12759 if (!(flags & CLONEf_COPY_STACKS)) {
12760 param->unreferenced = newAV();
12763 /* Set tainting stuff before PerlIO_debug can possibly get called */
12764 PL_tainting = proto_perl->Itainting;
12765 PL_taint_warn = proto_perl->Itaint_warn;
12767 #ifdef PERLIO_LAYERS
12768 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
12769 PerlIO_clone(aTHX_ proto_perl, param);
12772 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
12773 PL_incgv = gv_dup(proto_perl->Iincgv, param);
12774 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
12775 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
12776 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
12777 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
12780 PL_minus_c = proto_perl->Iminus_c;
12781 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
12782 PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
12783 PL_localpatches = proto_perl->Ilocalpatches;
12784 PL_splitstr = proto_perl->Isplitstr;
12785 PL_minus_n = proto_perl->Iminus_n;
12786 PL_minus_p = proto_perl->Iminus_p;
12787 PL_minus_l = proto_perl->Iminus_l;
12788 PL_minus_a = proto_perl->Iminus_a;
12789 PL_minus_E = proto_perl->Iminus_E;
12790 PL_minus_F = proto_perl->Iminus_F;
12791 PL_doswitches = proto_perl->Idoswitches;
12792 PL_dowarn = proto_perl->Idowarn;
12793 PL_sawampersand = proto_perl->Isawampersand;
12794 PL_unsafe = proto_perl->Iunsafe;
12795 PL_inplace = SAVEPV(proto_perl->Iinplace);
12796 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
12797 PL_perldb = proto_perl->Iperldb;
12798 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
12799 PL_exit_flags = proto_perl->Iexit_flags;
12801 /* magical thingies */
12802 /* XXX time(&PL_basetime) when asked for? */
12803 PL_basetime = proto_perl->Ibasetime;
12804 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
12806 PL_maxsysfd = proto_perl->Imaxsysfd;
12807 PL_statusvalue = proto_perl->Istatusvalue;
12809 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
12811 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
12813 PL_encoding = sv_dup(proto_perl->Iencoding, param);
12815 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
12816 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
12817 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
12820 /* RE engine related */
12821 Zero(&PL_reg_state, 1, struct re_save_state);
12822 PL_reginterp_cnt = 0;
12823 PL_regmatch_slab = NULL;
12825 /* Clone the regex array */
12826 /* ORANGE FIXME for plugins, probably in the SV dup code.
12827 newSViv(PTR2IV(CALLREGDUPE(
12828 INT2PTR(REGEXP *, SvIVX(regex)), param))))
12830 PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
12831 PL_regex_pad = AvARRAY(PL_regex_padav);
12833 /* shortcuts to various I/O objects */
12834 PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param);
12835 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
12836 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
12837 PL_defgv = gv_dup(proto_perl->Idefgv, param);
12838 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
12839 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
12840 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
12842 /* shortcuts to regexp stuff */
12843 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
12845 /* shortcuts to misc objects */
12846 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
12848 /* shortcuts to debugging objects */
12849 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
12850 PL_DBline = gv_dup(proto_perl->IDBline, param);
12851 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
12852 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
12853 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
12854 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
12856 /* symbol tables */
12857 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
12858 PL_curstash = hv_dup(proto_perl->Icurstash, param);
12859 PL_debstash = hv_dup(proto_perl->Idebstash, param);
12860 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
12861 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
12863 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
12864 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
12865 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
12866 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
12867 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
12868 PL_endav = av_dup_inc(proto_perl->Iendav, param);
12869 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
12870 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
12872 PL_sub_generation = proto_perl->Isub_generation;
12873 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
12875 /* funky return mechanisms */
12876 PL_forkprocess = proto_perl->Iforkprocess;
12878 /* subprocess state */
12879 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
12881 /* internal state */
12882 PL_maxo = proto_perl->Imaxo;
12883 if (proto_perl->Iop_mask)
12884 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
12887 /* PL_asserting = proto_perl->Iasserting; */
12889 /* current interpreter roots */
12890 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
12892 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
12894 PL_main_start = proto_perl->Imain_start;
12895 PL_eval_root = proto_perl->Ieval_root;
12896 PL_eval_start = proto_perl->Ieval_start;
12898 /* runtime control stuff */
12899 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
12901 PL_filemode = proto_perl->Ifilemode;
12902 PL_lastfd = proto_perl->Ilastfd;
12903 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
12906 PL_gensym = proto_perl->Igensym;
12907 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
12908 PL_laststatval = proto_perl->Ilaststatval;
12909 PL_laststype = proto_perl->Ilaststype;
12912 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
12914 /* interpreter atexit processing */
12915 PL_exitlistlen = proto_perl->Iexitlistlen;
12916 if (PL_exitlistlen) {
12917 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12918 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12921 PL_exitlist = (PerlExitListEntry*)NULL;
12923 PL_my_cxt_size = proto_perl->Imy_cxt_size;
12924 if (PL_my_cxt_size) {
12925 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
12926 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
12927 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12928 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
12929 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
12933 PL_my_cxt_list = (void**)NULL;
12934 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
12935 PL_my_cxt_keys = (const char**)NULL;
12938 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
12939 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
12940 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
12941 PL_custom_ops = hv_dup_inc(proto_perl->Icustom_ops, param);
12943 PL_profiledata = NULL;
12945 PL_compcv = cv_dup(proto_perl->Icompcv, param);
12947 PAD_CLONE_VARS(proto_perl, param);
12949 #ifdef HAVE_INTERP_INTERN
12950 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
12953 /* more statics moved here */
12954 PL_generation = proto_perl->Igeneration;
12955 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
12957 PL_in_clean_objs = proto_perl->Iin_clean_objs;
12958 PL_in_clean_all = proto_perl->Iin_clean_all;
12960 PL_uid = proto_perl->Iuid;
12961 PL_euid = proto_perl->Ieuid;
12962 PL_gid = proto_perl->Igid;
12963 PL_egid = proto_perl->Iegid;
12964 PL_nomemok = proto_perl->Inomemok;
12965 PL_an = proto_perl->Ian;
12966 PL_evalseq = proto_perl->Ievalseq;
12967 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
12968 PL_origalen = proto_perl->Iorigalen;
12969 #ifdef PERL_USES_PL_PIDSTATUS
12970 PL_pidstatus = newHV(); /* XXX flag for cloning? */
12972 PL_osname = SAVEPV(proto_perl->Iosname);
12973 PL_sighandlerp = proto_perl->Isighandlerp;
12975 PL_runops = proto_perl->Irunops;
12977 PL_parser = parser_dup(proto_perl->Iparser, param);
12979 /* XXX this only works if the saved cop has already been cloned */
12980 if (proto_perl->Iparser) {
12981 PL_parser->saved_curcop = (COP*)any_dup(
12982 proto_perl->Iparser->saved_curcop,
12986 PL_subline = proto_perl->Isubline;
12987 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
12990 PL_cryptseen = proto_perl->Icryptseen;
12993 PL_hints = proto_perl->Ihints;
12995 PL_amagic_generation = proto_perl->Iamagic_generation;
12997 #ifdef USE_LOCALE_COLLATE
12998 PL_collation_ix = proto_perl->Icollation_ix;
12999 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
13000 PL_collation_standard = proto_perl->Icollation_standard;
13001 PL_collxfrm_base = proto_perl->Icollxfrm_base;
13002 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
13003 #endif /* USE_LOCALE_COLLATE */
13005 #ifdef USE_LOCALE_NUMERIC
13006 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
13007 PL_numeric_standard = proto_perl->Inumeric_standard;
13008 PL_numeric_local = proto_perl->Inumeric_local;
13009 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
13010 #endif /* !USE_LOCALE_NUMERIC */
13012 /* utf8 character classes */
13013 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
13014 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
13015 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
13016 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
13017 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
13018 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
13019 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
13020 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
13021 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
13022 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
13023 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
13024 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
13025 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
13026 PL_utf8_X_begin = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
13027 PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
13028 PL_utf8_X_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
13029 PL_utf8_X_non_hangul = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
13030 PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
13031 PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
13032 PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
13033 PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
13034 PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
13035 PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
13036 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
13037 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
13038 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
13039 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
13040 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
13041 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
13043 /* Did the locale setup indicate UTF-8? */
13044 PL_utf8locale = proto_perl->Iutf8locale;
13045 /* Unicode features (see perlrun/-C) */
13046 PL_unicode = proto_perl->Iunicode;
13048 /* Pre-5.8 signals control */
13049 PL_signals = proto_perl->Isignals;
13051 /* times() ticks per second */
13052 PL_clocktick = proto_perl->Iclocktick;
13054 /* Recursion stopper for PerlIO_find_layer */
13055 PL_in_load_module = proto_perl->Iin_load_module;
13057 /* sort() routine */
13058 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
13060 /* Not really needed/useful since the reenrant_retint is "volatile",
13061 * but do it for consistency's sake. */
13062 PL_reentrant_retint = proto_perl->Ireentrant_retint;
13064 /* Hooks to shared SVs and locks. */
13065 PL_sharehook = proto_perl->Isharehook;
13066 PL_lockhook = proto_perl->Ilockhook;
13067 PL_unlockhook = proto_perl->Iunlockhook;
13068 PL_threadhook = proto_perl->Ithreadhook;
13069 PL_destroyhook = proto_perl->Idestroyhook;
13070 PL_signalhook = proto_perl->Isignalhook;
13072 #ifdef THREADS_HAVE_PIDS
13073 PL_ppid = proto_perl->Ippid;
13077 PL_last_swash_hv = NULL; /* reinits on demand */
13078 PL_last_swash_klen = 0;
13079 PL_last_swash_key[0]= '\0';
13080 PL_last_swash_tmps = (U8*)NULL;
13081 PL_last_swash_slen = 0;
13083 PL_glob_index = proto_perl->Iglob_index;
13084 PL_srand_called = proto_perl->Isrand_called;
13086 if (proto_perl->Ipsig_pend) {
13087 Newxz(PL_psig_pend, SIG_SIZE, int);
13090 PL_psig_pend = (int*)NULL;
13093 if (proto_perl->Ipsig_name) {
13094 Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
13095 sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
13097 PL_psig_ptr = PL_psig_name + SIG_SIZE;
13100 PL_psig_ptr = (SV**)NULL;
13101 PL_psig_name = (SV**)NULL;
13104 /* intrpvar.h stuff */
13106 if (flags & CLONEf_COPY_STACKS) {
13107 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
13108 PL_tmps_ix = proto_perl->Itmps_ix;
13109 PL_tmps_max = proto_perl->Itmps_max;
13110 PL_tmps_floor = proto_perl->Itmps_floor;
13111 Newx(PL_tmps_stack, PL_tmps_max, SV*);
13112 sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
13113 PL_tmps_ix+1, param);
13115 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
13116 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
13117 Newxz(PL_markstack, i, I32);
13118 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
13119 - proto_perl->Imarkstack);
13120 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
13121 - proto_perl->Imarkstack);
13122 Copy(proto_perl->Imarkstack, PL_markstack,
13123 PL_markstack_ptr - PL_markstack + 1, I32);
13125 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13126 * NOTE: unlike the others! */
13127 PL_scopestack_ix = proto_perl->Iscopestack_ix;
13128 PL_scopestack_max = proto_perl->Iscopestack_max;
13129 Newxz(PL_scopestack, PL_scopestack_max, I32);
13130 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
13133 Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
13134 Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
13136 /* NOTE: si_dup() looks at PL_markstack */
13137 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
13139 /* PL_curstack = PL_curstackinfo->si_stack; */
13140 PL_curstack = av_dup(proto_perl->Icurstack, param);
13141 PL_mainstack = av_dup(proto_perl->Imainstack, param);
13143 /* next PUSHs() etc. set *(PL_stack_sp+1) */
13144 PL_stack_base = AvARRAY(PL_curstack);
13145 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
13146 - proto_perl->Istack_base);
13147 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
13149 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
13150 * NOTE: unlike the others! */
13151 PL_savestack_ix = proto_perl->Isavestack_ix;
13152 PL_savestack_max = proto_perl->Isavestack_max;
13153 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
13154 PL_savestack = ss_dup(proto_perl, param);
13158 ENTER; /* perl_destruct() wants to LEAVE; */
13161 PL_start_env = proto_perl->Istart_env; /* XXXXXX */
13162 PL_top_env = &PL_start_env;
13164 PL_op = proto_perl->Iop;
13167 PL_Xpv = (XPV*)NULL;
13168 my_perl->Ina = proto_perl->Ina;
13170 PL_statbuf = proto_perl->Istatbuf;
13171 PL_statcache = proto_perl->Istatcache;
13172 PL_statgv = gv_dup(proto_perl->Istatgv, param);
13173 PL_statname = sv_dup_inc(proto_perl->Istatname, param);
13175 PL_timesbuf = proto_perl->Itimesbuf;
13178 PL_tainted = proto_perl->Itainted;
13179 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
13180 PL_rs = sv_dup_inc(proto_perl->Irs, param);
13181 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
13182 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
13183 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
13184 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
13185 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
13186 PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
13188 PL_restartjmpenv = proto_perl->Irestartjmpenv;
13189 PL_restartop = proto_perl->Irestartop;
13190 PL_in_eval = proto_perl->Iin_eval;
13191 PL_delaymagic = proto_perl->Idelaymagic;
13192 PL_phase = proto_perl->Iphase;
13193 PL_localizing = proto_perl->Ilocalizing;
13195 PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
13196 PL_hv_fetch_ent_mh = NULL;
13197 PL_modcount = proto_perl->Imodcount;
13198 PL_lastgotoprobe = NULL;
13199 PL_dumpindent = proto_perl->Idumpindent;
13201 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
13202 PL_sortstash = hv_dup(proto_perl->Isortstash, param);
13203 PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
13204 PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
13205 PL_efloatbuf = NULL; /* reinits on demand */
13206 PL_efloatsize = 0; /* reinits on demand */
13210 PL_screamfirst = NULL;
13211 PL_screamnext = NULL;
13212 PL_maxscream = -1; /* reinits on demand */
13213 PL_lastscream = NULL;
13216 PL_regdummy = proto_perl->Iregdummy;
13217 PL_colorset = 0; /* reinits PL_colors[] */
13218 /*PL_colors[6] = {0,0,0,0,0,0};*/
13222 /* Pluggable optimizer */
13223 PL_peepp = proto_perl->Ipeepp;
13224 PL_rpeepp = proto_perl->Irpeepp;
13225 /* op_free() hook */
13226 PL_opfreehook = proto_perl->Iopfreehook;
13228 PL_stashcache = newHV();
13230 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
13231 proto_perl->Iwatchaddr);
13232 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
13233 if (PL_debug && PL_watchaddr) {
13234 PerlIO_printf(Perl_debug_log,
13235 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
13236 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
13237 PTR2UV(PL_watchok));
13240 PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
13241 PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param);
13242 PL_utf8_foldclosures = hv_dup_inc(proto_perl->Iutf8_foldclosures, param);
13244 /* Call the ->CLONE method, if it exists, for each of the stashes
13245 identified by sv_dup() above.
13247 while(av_len(param->stashes) != -1) {
13248 HV* const stash = MUTABLE_HV(av_shift(param->stashes));
13249 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
13250 if (cloner && GvCV(cloner)) {
13255 mXPUSHs(newSVhek(HvNAME_HEK(stash)));
13257 call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
13263 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
13264 ptr_table_free(PL_ptr_table);
13265 PL_ptr_table = NULL;
13268 if (!(flags & CLONEf_COPY_STACKS)) {
13269 unreferenced_to_tmp_stack(param->unreferenced);
13272 SvREFCNT_dec(param->stashes);
13274 /* orphaned? eg threads->new inside BEGIN or use */
13275 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
13276 SvREFCNT_inc_simple_void(PL_compcv);
13277 SAVEFREESV(PL_compcv);
13284 S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
13286 PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
13288 if (AvFILLp(unreferenced) > -1) {
13289 SV **svp = AvARRAY(unreferenced);
13290 SV **const last = svp + AvFILLp(unreferenced);
13294 if (SvREFCNT(*svp) == 1)
13296 } while (++svp <= last);
13298 EXTEND_MORTAL(count);
13299 svp = AvARRAY(unreferenced);
13302 if (SvREFCNT(*svp) == 1) {
13303 /* Our reference is the only one to this SV. This means that
13304 in this thread, the scalar effectively has a 0 reference.
13305 That doesn't work (cleanup never happens), so donate our
13306 reference to it onto the save stack. */
13307 PL_tmps_stack[++PL_tmps_ix] = *svp;
13309 /* As an optimisation, because we are already walking the
13310 entire array, instead of above doing either
13311 SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
13312 release our reference to the scalar, so that at the end of
13313 the array owns zero references to the scalars it happens to
13314 point to. We are effectively converting the array from
13315 AvREAL() on to AvREAL() off. This saves the av_clear()
13316 (triggered by the SvREFCNT_dec(unreferenced) below) from
13317 walking the array a second time. */
13318 SvREFCNT_dec(*svp);
13321 } while (++svp <= last);
13322 AvREAL_off(unreferenced);
13324 SvREFCNT_dec(unreferenced);
13328 Perl_clone_params_del(CLONE_PARAMS *param)
13330 /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
13332 PerlInterpreter *const to = param->new_perl;
13334 PerlInterpreter *const was = PERL_GET_THX;
13336 PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
13342 SvREFCNT_dec(param->stashes);
13343 if (param->unreferenced)
13344 unreferenced_to_tmp_stack(param->unreferenced);
13354 Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
13357 /* Need to play this game, as newAV() can call safesysmalloc(), and that
13358 does a dTHX; to get the context from thread local storage.
13359 FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
13360 a version that passes in my_perl. */
13361 PerlInterpreter *const was = PERL_GET_THX;
13362 CLONE_PARAMS *param;
13364 PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
13370 /* Given that we've set the context, we can do this unshared. */
13371 Newx(param, 1, CLONE_PARAMS);
13374 param->proto_perl = from;
13375 param->new_perl = to;
13376 param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
13377 AvREAL_off(param->stashes);
13378 param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
13386 #endif /* USE_ITHREADS */
13389 =head1 Unicode Support
13391 =for apidoc sv_recode_to_utf8
13393 The encoding is assumed to be an Encode object, on entry the PV
13394 of the sv is assumed to be octets in that encoding, and the sv
13395 will be converted into Unicode (and UTF-8).
13397 If the sv already is UTF-8 (or if it is not POK), or if the encoding
13398 is not a reference, nothing is done to the sv. If the encoding is not
13399 an C<Encode::XS> Encoding object, bad things will happen.
13400 (See F<lib/encoding.pm> and L<Encode>).
13402 The PV of the sv is returned.
13407 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
13411 PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
13413 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
13427 Passing sv_yes is wrong - it needs to be or'ed set of constants
13428 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
13429 remove converted chars from source.
13431 Both will default the value - let them.
13433 XPUSHs(&PL_sv_yes);
13436 call_method("decode", G_SCALAR);
13440 s = SvPV_const(uni, len);
13441 if (s != SvPVX_const(sv)) {
13442 SvGROW(sv, len + 1);
13443 Move(s, SvPVX(sv), len + 1, char);
13444 SvCUR_set(sv, len);
13451 return SvPOKp(sv) ? SvPVX(sv) : NULL;
13455 =for apidoc sv_cat_decode
13457 The encoding is assumed to be an Encode object, the PV of the ssv is
13458 assumed to be octets in that encoding and decoding the input starts
13459 from the position which (PV + *offset) pointed to. The dsv will be
13460 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
13461 when the string tstr appears in decoding output or the input ends on
13462 the PV of the ssv. The value which the offset points will be modified
13463 to the last input position on the ssv.
13465 Returns TRUE if the terminator was found, else returns FALSE.
13470 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
13471 SV *ssv, int *offset, char *tstr, int tlen)
13476 PERL_ARGS_ASSERT_SV_CAT_DECODE;
13478 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
13489 offsv = newSViv(*offset);
13491 mXPUSHp(tstr, tlen);
13493 call_method("cat_decode", G_SCALAR);
13495 ret = SvTRUE(TOPs);
13496 *offset = SvIV(offsv);
13502 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
13507 /* ---------------------------------------------------------------------
13509 * support functions for report_uninit()
13512 /* the maxiumum size of array or hash where we will scan looking
13513 * for the undefined element that triggered the warning */
13515 #define FUV_MAX_SEARCH_SIZE 1000
13517 /* Look for an entry in the hash whose value has the same SV as val;
13518 * If so, return a mortal copy of the key. */
13521 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
13524 register HE **array;
13527 PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
13529 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
13530 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
13533 array = HvARRAY(hv);
13535 for (i=HvMAX(hv); i>0; i--) {
13536 register HE *entry;
13537 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
13538 if (HeVAL(entry) != val)
13540 if ( HeVAL(entry) == &PL_sv_undef ||
13541 HeVAL(entry) == &PL_sv_placeholder)
13545 if (HeKLEN(entry) == HEf_SVKEY)
13546 return sv_mortalcopy(HeKEY_sv(entry));
13547 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
13553 /* Look for an entry in the array whose value has the same SV as val;
13554 * If so, return the index, otherwise return -1. */
13557 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
13561 PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
13563 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
13564 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
13567 if (val != &PL_sv_undef) {
13568 SV ** const svp = AvARRAY(av);
13571 for (i=AvFILLp(av); i>=0; i--)
13578 /* S_varname(): return the name of a variable, optionally with a subscript.
13579 * If gv is non-zero, use the name of that global, along with gvtype (one
13580 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
13581 * targ. Depending on the value of the subscript_type flag, return:
13584 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
13585 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
13586 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
13587 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
13590 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
13591 const SV *const keyname, I32 aindex, int subscript_type)
13594 SV * const name = sv_newmortal();
13597 buffer[0] = gvtype;
13600 /* as gv_fullname4(), but add literal '^' for $^FOO names */
13602 gv_fullname4(name, gv, buffer, 0);
13604 if ((unsigned int)SvPVX(name)[1] <= 26) {
13606 buffer[1] = SvPVX(name)[1] + 'A' - 1;
13608 /* Swap the 1 unprintable control character for the 2 byte pretty
13609 version - ie substr($name, 1, 1) = $buffer; */
13610 sv_insert(name, 1, 1, buffer, 2);
13614 CV * const cv = find_runcv(NULL);
13618 if (!cv || !CvPADLIST(cv))
13620 av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
13621 sv = *av_fetch(av, targ, FALSE);
13622 sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
13625 if (subscript_type == FUV_SUBSCRIPT_HASH) {
13626 SV * const sv = newSV(0);
13627 *SvPVX(name) = '$';
13628 Perl_sv_catpvf(aTHX_ name, "{%s}",
13629 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
13632 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
13633 *SvPVX(name) = '$';
13634 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
13636 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
13637 /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
13638 Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
13646 =for apidoc find_uninit_var
13648 Find the name of the undefined variable (if any) that caused the operator o
13649 to issue a "Use of uninitialized value" warning.
13650 If match is true, only return a name if it's value matches uninit_sv.
13651 So roughly speaking, if a unary operator (such as OP_COS) generates a
13652 warning, then following the direct child of the op may yield an
13653 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
13654 other hand, with OP_ADD there are two branches to follow, so we only print
13655 the variable name if we get an exact match.
13657 The name is returned as a mortal SV.
13659 Assumes that PL_op is the op that originally triggered the error, and that
13660 PL_comppad/PL_curpad points to the currently executing pad.
13666 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
13672 const OP *o, *o2, *kid;
13674 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
13675 uninit_sv == &PL_sv_placeholder)))
13678 switch (obase->op_type) {
13685 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
13686 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
13689 int subscript_type = FUV_SUBSCRIPT_WITHIN;
13691 if (pad) { /* @lex, %lex */
13692 sv = PAD_SVl(obase->op_targ);
13696 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
13697 /* @global, %global */
13698 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
13701 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
13703 else /* @{expr}, %{expr} */
13704 return find_uninit_var(cUNOPx(obase)->op_first,
13708 /* attempt to find a match within the aggregate */
13710 keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13712 subscript_type = FUV_SUBSCRIPT_HASH;
13715 index = find_array_subscript((const AV *)sv, uninit_sv);
13717 subscript_type = FUV_SUBSCRIPT_ARRAY;
13720 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
13723 return varname(gv, hash ? '%' : '@', obase->op_targ,
13724 keysv, index, subscript_type);
13728 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
13730 return varname(NULL, '$', obase->op_targ,
13731 NULL, 0, FUV_SUBSCRIPT_NONE);
13734 gv = cGVOPx_gv(obase);
13735 if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))
13737 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
13740 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
13743 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
13744 if (!av || SvRMAGICAL(av))
13746 svp = av_fetch(av, (I32)obase->op_private, FALSE);
13747 if (!svp || *svp != uninit_sv)
13750 return varname(NULL, '$', obase->op_targ,
13751 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
13754 gv = cGVOPx_gv(obase);
13759 AV *const av = GvAV(gv);
13760 if (!av || SvRMAGICAL(av))
13762 svp = av_fetch(av, (I32)obase->op_private, FALSE);
13763 if (!svp || *svp != uninit_sv)
13766 return varname(gv, '$', 0,
13767 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
13772 o = cUNOPx(obase)->op_first;
13773 if (!o || o->op_type != OP_NULL ||
13774 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
13776 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
13780 if (PL_op == obase)
13781 /* $a[uninit_expr] or $h{uninit_expr} */
13782 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
13785 o = cBINOPx(obase)->op_first;
13786 kid = cBINOPx(obase)->op_last;
13788 /* get the av or hv, and optionally the gv */
13790 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
13791 sv = PAD_SV(o->op_targ);
13793 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
13794 && cUNOPo->op_first->op_type == OP_GV)
13796 gv = cGVOPx_gv(cUNOPo->op_first);
13800 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
13805 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
13806 /* index is constant */
13810 if (obase->op_type == OP_HELEM) {
13811 HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
13812 if (!he || HeVAL(he) != uninit_sv)
13816 SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
13817 if (!svp || *svp != uninit_sv)
13821 if (obase->op_type == OP_HELEM)
13822 return varname(gv, '%', o->op_targ,
13823 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
13825 return varname(gv, '@', o->op_targ, NULL,
13826 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
13829 /* index is an expression;
13830 * attempt to find a match within the aggregate */
13831 if (obase->op_type == OP_HELEM) {
13832 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13834 return varname(gv, '%', o->op_targ,
13835 keysv, 0, FUV_SUBSCRIPT_HASH);
13839 = find_array_subscript((const AV *)sv, uninit_sv);
13841 return varname(gv, '@', o->op_targ,
13842 NULL, index, FUV_SUBSCRIPT_ARRAY);
13847 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
13849 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
13854 /* only examine RHS */
13855 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
13858 o = cUNOPx(obase)->op_first;
13859 if (o->op_type == OP_PUSHMARK)
13862 if (!o->op_sibling) {
13863 /* one-arg version of open is highly magical */
13865 if (o->op_type == OP_GV) { /* open FOO; */
13867 if (match && GvSV(gv) != uninit_sv)
13869 return varname(gv, '$', 0,
13870 NULL, 0, FUV_SUBSCRIPT_NONE);
13872 /* other possibilities not handled are:
13873 * open $x; or open my $x; should return '${*$x}'
13874 * open expr; should return '$'.expr ideally
13880 /* ops where $_ may be an implicit arg */
13884 if ( !(obase->op_flags & OPf_STACKED)) {
13885 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
13886 ? PAD_SVl(obase->op_targ)
13889 sv = sv_newmortal();
13890 sv_setpvs(sv, "$_");
13899 match = 1; /* print etc can return undef on defined args */
13900 /* skip filehandle as it can't produce 'undef' warning */
13901 o = cUNOPx(obase)->op_first;
13902 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
13903 o = o->op_sibling->op_sibling;
13907 case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
13909 case OP_CUSTOM: /* XS or custom code could trigger random warnings */
13911 /* the following ops are capable of returning PL_sv_undef even for
13912 * defined arg(s) */
13931 case OP_GETPEERNAME:
13979 case OP_SMARTMATCH:
13988 /* XXX tmp hack: these two may call an XS sub, and currently
13989 XS subs don't have a SUB entry on the context stack, so CV and
13990 pad determination goes wrong, and BAD things happen. So, just
13991 don't try to determine the value under those circumstances.
13992 Need a better fix at dome point. DAPM 11/2007 */
13998 GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
13999 if (gv && GvSV(gv) == uninit_sv)
14000 return newSVpvs_flags("$.", SVs_TEMP);
14005 /* def-ness of rval pos() is independent of the def-ness of its arg */
14006 if ( !(obase->op_flags & OPf_MOD))
14011 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
14012 return newSVpvs_flags("${$/}", SVs_TEMP);
14017 if (!(obase->op_flags & OPf_KIDS))
14019 o = cUNOPx(obase)->op_first;
14025 /* if all except one arg are constant, or have no side-effects,
14026 * or are optimized away, then it's unambiguous */
14028 for (kid=o; kid; kid = kid->op_sibling) {
14030 const OPCODE type = kid->op_type;
14031 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
14032 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
14033 || (type == OP_PUSHMARK)
14035 /* @$a and %$a, but not @a or %a */
14036 (type == OP_RV2AV || type == OP_RV2HV)
14037 && cUNOPx(kid)->op_first
14038 && cUNOPx(kid)->op_first->op_type != OP_GV
14043 if (o2) { /* more than one found */
14050 return find_uninit_var(o2, uninit_sv, match);
14052 /* scan all args */
14054 sv = find_uninit_var(o, uninit_sv, 1);
14066 =for apidoc report_uninit
14068 Print appropriate "Use of uninitialized variable" warning
14074 Perl_report_uninit(pTHX_ const SV *uninit_sv)
14078 SV* varname = NULL;
14080 varname = find_uninit_var(PL_op, uninit_sv,0);
14082 sv_insert(varname, 0, 0, " ", 1);
14084 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
14085 varname ? SvPV_nolen_const(varname) : "",
14086 " in ", OP_DESC(PL_op));
14089 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
14095 * c-indentation-style: bsd
14096 * c-basic-offset: 4
14097 * indent-tabs-mode: t
14100 * ex: set ts=8 sts=4 sw=4 noet: