3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'I wonder what the Entish is for "yes" and "no",' he thought.
16 * [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
22 * This file contains the code that creates, manipulates and destroys
23 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
24 * structure of an SV, so their creation and destruction is handled
25 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
26 * level functions (eg. substr, split, join) for each of the types are
36 # if __STDC_VERSION__ >= 199901L && !defined(VMS)
45 /* Missing proto on LynxOS */
46 char *gconvert(double, int, int, char *);
49 /* void Gconvert: on Linux at least, gcvt (which Gconvert gets deffed to),
50 * has a mandatory return value, even though that value is just the same
53 #define V_Gconvert(x,n,t,b) \
55 char *rc = (char *)Gconvert(x,n,t,b); \
56 PERL_UNUSED_VAR(rc); \
60 #ifdef PERL_UTF8_CACHE_ASSERT
61 /* if adding more checks watch out for the following tests:
62 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
63 * lib/utf8.t lib/Unicode/Collate/t/index.t
66 # define ASSERT_UTF8_CACHE(cache) \
67 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
68 assert((cache)[2] <= (cache)[3]); \
69 assert((cache)[3] <= (cache)[1]);} \
72 # define ASSERT_UTF8_CACHE(cache) NOOP
75 #ifdef PERL_OLD_COPY_ON_WRITE
76 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
77 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
80 /* ============================================================================
82 =head1 Allocation and deallocation of SVs.
84 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
85 sv, av, hv...) contains type and reference count information, and for
86 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
87 contains fields specific to each type. Some types store all they need
88 in the head, so don't have a body.
90 In all but the most memory-paranoid configurations (ex: PURIFY), heads
91 and bodies are allocated out of arenas, which by default are
92 approximately 4K chunks of memory parcelled up into N heads or bodies.
93 Sv-bodies are allocated by their sv-type, guaranteeing size
94 consistency needed to allocate safely from arrays.
96 For SV-heads, the first slot in each arena is reserved, and holds a
97 link to the next arena, some flags, and a note of the number of slots.
98 Snaked through each arena chain is a linked list of free items; when
99 this becomes empty, an extra arena is allocated and divided up into N
100 items which are threaded into the free list.
102 SV-bodies are similar, but they use arena-sets by default, which
103 separate the link and info from the arena itself, and reclaim the 1st
104 slot in the arena. SV-bodies are further described later.
106 The following global variables are associated with arenas:
108 PL_sv_arenaroot pointer to list of SV arenas
109 PL_sv_root pointer to list of free SV structures
111 PL_body_arenas head of linked-list of body arenas
112 PL_body_roots[] array of pointers to list of free bodies of svtype
113 arrays are indexed by the svtype needed
115 A few special SV heads are not allocated from an arena, but are
116 instead directly created in the interpreter structure, eg PL_sv_undef.
117 The size of arenas can be changed from the default by setting
118 PERL_ARENA_SIZE appropriately at compile time.
120 The SV arena serves the secondary purpose of allowing still-live SVs
121 to be located and destroyed during final cleanup.
123 At the lowest level, the macros new_SV() and del_SV() grab and free
124 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
125 to return the SV to the free list with error checking.) new_SV() calls
126 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
127 SVs in the free list have their SvTYPE field set to all ones.
129 At the time of very final cleanup, sv_free_arenas() is called from
130 perl_destruct() to physically free all the arenas allocated since the
131 start of the interpreter.
133 The function visit() scans the SV arenas list, and calls a specified
134 function for each SV it finds which is still live - ie which has an SvTYPE
135 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
136 following functions (specified as [function that calls visit()] / [function
137 called by visit() for each SV]):
139 sv_report_used() / do_report_used()
140 dump all remaining SVs (debugging aid)
142 sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
143 do_clean_named_io_objs(),do_curse()
144 Attempt to free all objects pointed to by RVs,
145 try to do the same for all objects indir-
146 ectly referenced by typeglobs too, and
147 then do a final sweep, cursing any
148 objects that remain. Called once from
149 perl_destruct(), prior to calling sv_clean_all()
152 sv_clean_all() / do_clean_all()
153 SvREFCNT_dec(sv) each remaining SV, possibly
154 triggering an sv_free(). It also sets the
155 SVf_BREAK flag on the SV to indicate that the
156 refcnt has been artificially lowered, and thus
157 stopping sv_free() from giving spurious warnings
158 about SVs which unexpectedly have a refcnt
159 of zero. called repeatedly from perl_destruct()
160 until there are no SVs left.
162 =head2 Arena allocator API Summary
164 Private API to rest of sv.c
168 new_XPVNV(), del_XPVGV(),
173 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
177 * ========================================================================= */
180 * "A time to plant, and a time to uproot what was planted..."
184 # define MEM_LOG_NEW_SV(sv, file, line, func) \
185 Perl_mem_log_new_sv(sv, file, line, func)
186 # define MEM_LOG_DEL_SV(sv, file, line, func) \
187 Perl_mem_log_del_sv(sv, file, line, func)
189 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
190 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
193 #ifdef DEBUG_LEAKING_SCALARS
194 # define FREE_SV_DEBUG_FILE(sv) STMT_START { \
195 if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \
197 # define DEBUG_SV_SERIAL(sv) \
198 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
199 PTR2UV(sv), (long)(sv)->sv_debug_serial))
201 # define FREE_SV_DEBUG_FILE(sv)
202 # define DEBUG_SV_SERIAL(sv) NOOP
206 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
207 # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
208 /* Whilst I'd love to do this, it seems that things like to check on
210 # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
212 # define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
213 PoisonNew(&SvREFCNT(sv), 1, U32)
215 # define SvARENA_CHAIN(sv) SvANY(sv)
216 # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
217 # define POSION_SV_HEAD(sv)
220 /* Mark an SV head as unused, and add to free list.
222 * If SVf_BREAK is set, skip adding it to the free list, as this SV had
223 * its refcount artificially decremented during global destruction, so
224 * there may be dangling pointers to it. The last thing we want in that
225 * case is for it to be reused. */
227 #define plant_SV(p) \
229 const U32 old_flags = SvFLAGS(p); \
230 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
231 DEBUG_SV_SERIAL(p); \
232 FREE_SV_DEBUG_FILE(p); \
234 SvFLAGS(p) = SVTYPEMASK; \
235 if (!(old_flags & SVf_BREAK)) { \
236 SvARENA_CHAIN_SET(p, PL_sv_root); \
242 #define uproot_SV(p) \
245 PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
250 /* make some more SVs by adding another arena */
257 char *chunk; /* must use New here to match call to */
258 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
259 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
264 /* new_SV(): return a new, empty SV head */
266 #ifdef DEBUG_LEAKING_SCALARS
267 /* provide a real function for a debugger to play with */
269 S_new_SV(pTHX_ const char *file, int line, const char *func)
276 sv = S_more_sv(aTHX);
280 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
281 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
287 sv->sv_debug_inpad = 0;
288 sv->sv_debug_parent = NULL;
289 sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
291 sv->sv_debug_serial = PL_sv_serial++;
293 MEM_LOG_NEW_SV(sv, file, line, func);
294 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
295 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
299 # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
307 (p) = S_more_sv(aTHX); \
311 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
316 /* del_SV(): return an empty SV head to the free list */
329 S_del_sv(pTHX_ SV *p)
333 PERL_ARGS_ASSERT_DEL_SV;
338 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
339 const SV * const sv = sva + 1;
340 const SV * const svend = &sva[SvREFCNT(sva)];
341 if (p >= sv && p < svend) {
347 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
348 "Attempt to free non-arena SV: 0x%"UVxf
349 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
356 #else /* ! DEBUGGING */
358 #define del_SV(p) plant_SV(p)
360 #endif /* DEBUGGING */
364 =head1 SV Manipulation Functions
366 =for apidoc sv_add_arena
368 Given a chunk of memory, link it to the head of the list of arenas,
369 and split it into a list of free SVs.
375 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
378 SV *const sva = MUTABLE_SV(ptr);
382 PERL_ARGS_ASSERT_SV_ADD_ARENA;
384 /* The first SV in an arena isn't an SV. */
385 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
386 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
387 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
389 PL_sv_arenaroot = sva;
390 PL_sv_root = sva + 1;
392 svend = &sva[SvREFCNT(sva) - 1];
395 SvARENA_CHAIN_SET(sv, (sv + 1));
399 /* Must always set typemask because it's always checked in on cleanup
400 when the arenas are walked looking for objects. */
401 SvFLAGS(sv) = SVTYPEMASK;
404 SvARENA_CHAIN_SET(sv, 0);
408 SvFLAGS(sv) = SVTYPEMASK;
411 /* visit(): call the named function for each non-free SV in the arenas
412 * whose flags field matches the flags/mask args. */
415 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
421 PERL_ARGS_ASSERT_VISIT;
423 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
424 const SV * const svend = &sva[SvREFCNT(sva)];
426 for (sv = sva + 1; sv < svend; ++sv) {
427 if (SvTYPE(sv) != (svtype)SVTYPEMASK
428 && (sv->sv_flags & mask) == flags
441 /* called by sv_report_used() for each live SV */
444 do_report_used(pTHX_ SV *const sv)
446 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
447 PerlIO_printf(Perl_debug_log, "****\n");
454 =for apidoc sv_report_used
456 Dump the contents of all SVs not yet freed (debugging aid).
462 Perl_sv_report_used(pTHX)
465 visit(do_report_used, 0, 0);
471 /* called by sv_clean_objs() for each live SV */
474 do_clean_objs(pTHX_ SV *const ref)
479 SV * const target = SvRV(ref);
480 if (SvOBJECT(target)) {
481 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
482 if (SvWEAKREF(ref)) {
483 sv_del_backref(target, ref);
489 SvREFCNT_dec_NN(target);
496 /* clear any slots in a GV which hold objects - except IO;
497 * called by sv_clean_objs() for each live GV */
500 do_clean_named_objs(pTHX_ SV *const sv)
504 assert(SvTYPE(sv) == SVt_PVGV);
505 assert(isGV_with_GP(sv));
509 /* freeing GP entries may indirectly free the current GV;
510 * hold onto it while we mess with the GP slots */
513 if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
514 DEBUG_D((PerlIO_printf(Perl_debug_log,
515 "Cleaning named glob SV object:\n "), sv_dump(obj)));
517 SvREFCNT_dec_NN(obj);
519 if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
520 DEBUG_D((PerlIO_printf(Perl_debug_log,
521 "Cleaning named glob AV object:\n "), sv_dump(obj)));
523 SvREFCNT_dec_NN(obj);
525 if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
526 DEBUG_D((PerlIO_printf(Perl_debug_log,
527 "Cleaning named glob HV object:\n "), sv_dump(obj)));
529 SvREFCNT_dec_NN(obj);
531 if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
532 DEBUG_D((PerlIO_printf(Perl_debug_log,
533 "Cleaning named glob CV object:\n "), sv_dump(obj)));
535 SvREFCNT_dec_NN(obj);
537 SvREFCNT_dec_NN(sv); /* undo the inc above */
540 /* clear any IO slots in a GV which hold objects (except stderr, defout);
541 * called by sv_clean_objs() for each live GV */
544 do_clean_named_io_objs(pTHX_ SV *const sv)
548 assert(SvTYPE(sv) == SVt_PVGV);
549 assert(isGV_with_GP(sv));
550 if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
554 if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
555 DEBUG_D((PerlIO_printf(Perl_debug_log,
556 "Cleaning named glob IO object:\n "), sv_dump(obj)));
558 SvREFCNT_dec_NN(obj);
560 SvREFCNT_dec_NN(sv); /* undo the inc above */
563 /* Void wrapper to pass to visit() */
565 do_curse(pTHX_ SV * const sv) {
566 if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
567 || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
573 =for apidoc sv_clean_objs
575 Attempt to destroy all objects not yet freed.
581 Perl_sv_clean_objs(pTHX)
585 PL_in_clean_objs = TRUE;
586 visit(do_clean_objs, SVf_ROK, SVf_ROK);
587 /* Some barnacles may yet remain, clinging to typeglobs.
588 * Run the non-IO destructors first: they may want to output
589 * error messages, close files etc */
590 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
591 visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
592 /* And if there are some very tenacious barnacles clinging to arrays,
593 closures, or what have you.... */
594 visit(do_curse, SVs_OBJECT, SVs_OBJECT);
595 olddef = PL_defoutgv;
596 PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
597 if (olddef && isGV_with_GP(olddef))
598 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
599 olderr = PL_stderrgv;
600 PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
601 if (olderr && isGV_with_GP(olderr))
602 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
603 SvREFCNT_dec(olddef);
604 PL_in_clean_objs = FALSE;
607 /* called by sv_clean_all() for each live SV */
610 do_clean_all(pTHX_ SV *const sv)
613 if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
614 /* don't clean pid table and strtab */
617 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
618 SvFLAGS(sv) |= SVf_BREAK;
623 =for apidoc sv_clean_all
625 Decrement the refcnt of each remaining SV, possibly triggering a
626 cleanup. This function may have to be called multiple times to free
627 SVs which are in complex self-referential hierarchies.
633 Perl_sv_clean_all(pTHX)
637 PL_in_clean_all = TRUE;
638 cleaned = visit(do_clean_all, 0,0);
643 ARENASETS: a meta-arena implementation which separates arena-info
644 into struct arena_set, which contains an array of struct
645 arena_descs, each holding info for a single arena. By separating
646 the meta-info from the arena, we recover the 1st slot, formerly
647 borrowed for list management. The arena_set is about the size of an
648 arena, avoiding the needless malloc overhead of a naive linked-list.
650 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
651 memory in the last arena-set (1/2 on average). In trade, we get
652 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
653 smaller types). The recovery of the wasted space allows use of
654 small arenas for large, rare body types, by changing array* fields
655 in body_details_by_type[] below.
658 char *arena; /* the raw storage, allocated aligned */
659 size_t size; /* its size ~4k typ */
660 svtype utype; /* bodytype stored in arena */
665 /* Get the maximum number of elements in set[] such that struct arena_set
666 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
667 therefore likely to be 1 aligned memory page. */
669 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
670 - 2 * sizeof(int)) / sizeof (struct arena_desc))
673 struct arena_set* next;
674 unsigned int set_size; /* ie ARENAS_PER_SET */
675 unsigned int curr; /* index of next available arena-desc */
676 struct arena_desc set[ARENAS_PER_SET];
680 =for apidoc sv_free_arenas
682 Deallocate the memory used by all arenas. Note that all the individual SV
683 heads and bodies within the arenas must already have been freed.
688 Perl_sv_free_arenas(pTHX)
695 /* Free arenas here, but be careful about fake ones. (We assume
696 contiguity of the fake ones with the corresponding real ones.) */
698 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
699 svanext = MUTABLE_SV(SvANY(sva));
700 while (svanext && SvFAKE(svanext))
701 svanext = MUTABLE_SV(SvANY(svanext));
708 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
711 struct arena_set *current = aroot;
714 assert(aroot->set[i].arena);
715 Safefree(aroot->set[i].arena);
723 i = PERL_ARENA_ROOTS_SIZE;
725 PL_body_roots[i] = 0;
732 Here are mid-level routines that manage the allocation of bodies out
733 of the various arenas. There are 5 kinds of arenas:
735 1. SV-head arenas, which are discussed and handled above
736 2. regular body arenas
737 3. arenas for reduced-size bodies
740 Arena types 2 & 3 are chained by body-type off an array of
741 arena-root pointers, which is indexed by svtype. Some of the
742 larger/less used body types are malloced singly, since a large
743 unused block of them is wasteful. Also, several svtypes dont have
744 bodies; the data fits into the sv-head itself. The arena-root
745 pointer thus has a few unused root-pointers (which may be hijacked
746 later for arena types 4,5)
748 3 differs from 2 as an optimization; some body types have several
749 unused fields in the front of the structure (which are kept in-place
750 for consistency). These bodies can be allocated in smaller chunks,
751 because the leading fields arent accessed. Pointers to such bodies
752 are decremented to point at the unused 'ghost' memory, knowing that
753 the pointers are used with offsets to the real memory.
756 =head1 SV-Body Allocation
758 Allocation of SV-bodies is similar to SV-heads, differing as follows;
759 the allocation mechanism is used for many body types, so is somewhat
760 more complicated, it uses arena-sets, and has no need for still-live
763 At the outermost level, (new|del)_X*V macros return bodies of the
764 appropriate type. These macros call either (new|del)_body_type or
765 (new|del)_body_allocated macro pairs, depending on specifics of the
766 type. Most body types use the former pair, the latter pair is used to
767 allocate body types with "ghost fields".
769 "ghost fields" are fields that are unused in certain types, and
770 consequently don't need to actually exist. They are declared because
771 they're part of a "base type", which allows use of functions as
772 methods. The simplest examples are AVs and HVs, 2 aggregate types
773 which don't use the fields which support SCALAR semantics.
775 For these types, the arenas are carved up into appropriately sized
776 chunks, we thus avoid wasted memory for those unaccessed members.
777 When bodies are allocated, we adjust the pointer back in memory by the
778 size of the part not allocated, so it's as if we allocated the full
779 structure. (But things will all go boom if you write to the part that
780 is "not there", because you'll be overwriting the last members of the
781 preceding structure in memory.)
783 We calculate the correction using the STRUCT_OFFSET macro on the first
784 member present. If the allocated structure is smaller (no initial NV
785 actually allocated) then the net effect is to subtract the size of the NV
786 from the pointer, to return a new pointer as if an initial NV were actually
787 allocated. (We were using structures named *_allocated for this, but
788 this turned out to be a subtle bug, because a structure without an NV
789 could have a lower alignment constraint, but the compiler is allowed to
790 optimised accesses based on the alignment constraint of the actual pointer
791 to the full structure, for example, using a single 64 bit load instruction
792 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
794 This is the same trick as was used for NV and IV bodies. Ironically it
795 doesn't need to be used for NV bodies any more, because NV is now at
796 the start of the structure. IV bodies don't need it either, because
797 they are no longer allocated.
799 In turn, the new_body_* allocators call S_new_body(), which invokes
800 new_body_inline macro, which takes a lock, and takes a body off the
801 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
802 necessary to refresh an empty list. Then the lock is released, and
803 the body is returned.
805 Perl_more_bodies allocates a new arena, and carves it up into an array of N
806 bodies, which it strings into a linked list. It looks up arena-size
807 and body-size from the body_details table described below, thus
808 supporting the multiple body-types.
810 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
811 the (new|del)_X*V macros are mapped directly to malloc/free.
813 For each sv-type, struct body_details bodies_by_type[] carries
814 parameters which control these aspects of SV handling:
816 Arena_size determines whether arenas are used for this body type, and if
817 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
818 zero, forcing individual mallocs and frees.
820 Body_size determines how big a body is, and therefore how many fit into
821 each arena. Offset carries the body-pointer adjustment needed for
822 "ghost fields", and is used in *_allocated macros.
824 But its main purpose is to parameterize info needed in
825 Perl_sv_upgrade(). The info here dramatically simplifies the function
826 vs the implementation in 5.8.8, making it table-driven. All fields
827 are used for this, except for arena_size.
829 For the sv-types that have no bodies, arenas are not used, so those
830 PL_body_roots[sv_type] are unused, and can be overloaded. In
831 something of a special case, SVt_NULL is borrowed for HE arenas;
832 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
833 bodies_by_type[SVt_NULL] slot is not used, as the table is not
838 struct body_details {
839 U8 body_size; /* Size to allocate */
840 U8 copy; /* Size of structure to copy (may be shorter) */
842 unsigned int type : 4; /* We have space for a sanity check. */
843 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
844 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
845 unsigned int arena : 1; /* Allocated from an arena */
846 size_t arena_size; /* Size of arena to allocate */
854 /* With -DPURFIY we allocate everything directly, and don't use arenas.
855 This seems a rather elegant way to simplify some of the code below. */
856 #define HASARENA FALSE
858 #define HASARENA TRUE
860 #define NOARENA FALSE
862 /* Size the arenas to exactly fit a given number of bodies. A count
863 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
864 simplifying the default. If count > 0, the arena is sized to fit
865 only that many bodies, allowing arenas to be used for large, rare
866 bodies (XPVFM, XPVIO) without undue waste. The arena size is
867 limited by PERL_ARENA_SIZE, so we can safely oversize the
870 #define FIT_ARENA0(body_size) \
871 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
872 #define FIT_ARENAn(count,body_size) \
873 ( count * body_size <= PERL_ARENA_SIZE) \
874 ? count * body_size \
875 : FIT_ARENA0 (body_size)
876 #define FIT_ARENA(count,body_size) \
878 ? FIT_ARENAn (count, body_size) \
879 : FIT_ARENA0 (body_size)
881 /* Calculate the length to copy. Specifically work out the length less any
882 final padding the compiler needed to add. See the comment in sv_upgrade
883 for why copying the padding proved to be a bug. */
885 #define copy_length(type, last_member) \
886 STRUCT_OFFSET(type, last_member) \
887 + sizeof (((type*)SvANY((const SV *)0))->last_member)
889 static const struct body_details bodies_by_type[] = {
890 /* HEs use this offset for their arena. */
891 { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
893 /* IVs are in the head, so the allocation size is 0. */
895 sizeof(IV), /* This is used to copy out the IV body. */
896 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
897 NOARENA /* IVS don't need an arena */, 0
900 { sizeof(NV), sizeof(NV),
901 STRUCT_OFFSET(XPVNV, xnv_u),
902 SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
904 { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
905 copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
906 + STRUCT_OFFSET(XPV, xpv_cur),
907 SVt_PV, FALSE, NONV, HASARENA,
908 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
910 { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur),
911 copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur),
912 + STRUCT_OFFSET(XPV, xpv_cur),
913 SVt_INVLIST, TRUE, NONV, HASARENA,
914 FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) },
916 { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
917 copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
918 + STRUCT_OFFSET(XPV, xpv_cur),
919 SVt_PVIV, FALSE, NONV, HASARENA,
920 FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
922 { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
923 copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
924 + STRUCT_OFFSET(XPV, xpv_cur),
925 SVt_PVNV, FALSE, HADNV, HASARENA,
926 FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
928 { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
929 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
934 SVt_REGEXP, TRUE, NONV, HASARENA,
935 FIT_ARENA(0, sizeof(regexp))
938 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
939 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
941 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
942 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
945 copy_length(XPVAV, xav_alloc),
947 SVt_PVAV, TRUE, NONV, HASARENA,
948 FIT_ARENA(0, sizeof(XPVAV)) },
951 copy_length(XPVHV, xhv_max),
953 SVt_PVHV, TRUE, NONV, HASARENA,
954 FIT_ARENA(0, sizeof(XPVHV)) },
959 SVt_PVCV, TRUE, NONV, HASARENA,
960 FIT_ARENA(0, sizeof(XPVCV)) },
965 SVt_PVFM, TRUE, NONV, NOARENA,
966 FIT_ARENA(20, sizeof(XPVFM)) },
971 SVt_PVIO, TRUE, NONV, HASARENA,
972 FIT_ARENA(24, sizeof(XPVIO)) },
975 #define new_body_allocated(sv_type) \
976 (void *)((char *)S_new_body(aTHX_ sv_type) \
977 - bodies_by_type[sv_type].offset)
979 /* return a thing to the free list */
981 #define del_body(thing, root) \
983 void ** const thing_copy = (void **)thing; \
984 *thing_copy = *root; \
985 *root = (void*)thing_copy; \
990 #define new_XNV() safemalloc(sizeof(XPVNV))
991 #define new_XPVNV() safemalloc(sizeof(XPVNV))
992 #define new_XPVMG() safemalloc(sizeof(XPVMG))
994 #define del_XPVGV(p) safefree(p)
998 #define new_XNV() new_body_allocated(SVt_NV)
999 #define new_XPVNV() new_body_allocated(SVt_PVNV)
1000 #define new_XPVMG() new_body_allocated(SVt_PVMG)
1002 #define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \
1003 &PL_body_roots[SVt_PVGV])
1007 /* no arena for you! */
1009 #define new_NOARENA(details) \
1010 safemalloc((details)->body_size + (details)->offset)
1011 #define new_NOARENAZ(details) \
1012 safecalloc((details)->body_size + (details)->offset, 1)
1015 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1016 const size_t arena_size)
1019 void ** const root = &PL_body_roots[sv_type];
1020 struct arena_desc *adesc;
1021 struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1025 const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1026 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1027 static bool done_sanity_check;
1029 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1030 * variables like done_sanity_check. */
1031 if (!done_sanity_check) {
1032 unsigned int i = SVt_LAST;
1034 done_sanity_check = TRUE;
1037 assert (bodies_by_type[i].type == i);
1043 /* may need new arena-set to hold new arena */
1044 if (!aroot || aroot->curr >= aroot->set_size) {
1045 struct arena_set *newroot;
1046 Newxz(newroot, 1, struct arena_set);
1047 newroot->set_size = ARENAS_PER_SET;
1048 newroot->next = aroot;
1050 PL_body_arenas = (void *) newroot;
1051 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1054 /* ok, now have arena-set with at least 1 empty/available arena-desc */
1055 curr = aroot->curr++;
1056 adesc = &(aroot->set[curr]);
1057 assert(!adesc->arena);
1059 Newx(adesc->arena, good_arena_size, char);
1060 adesc->size = good_arena_size;
1061 adesc->utype = sv_type;
1062 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
1063 curr, (void*)adesc->arena, (UV)good_arena_size));
1065 start = (char *) adesc->arena;
1067 /* Get the address of the byte after the end of the last body we can fit.
1068 Remember, this is integer division: */
1069 end = start + good_arena_size / body_size * body_size;
1071 /* computed count doesn't reflect the 1st slot reservation */
1072 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1073 DEBUG_m(PerlIO_printf(Perl_debug_log,
1074 "arena %p end %p arena-size %d (from %d) type %d "
1076 (void*)start, (void*)end, (int)good_arena_size,
1077 (int)arena_size, sv_type, (int)body_size,
1078 (int)good_arena_size / (int)body_size));
1080 DEBUG_m(PerlIO_printf(Perl_debug_log,
1081 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1082 (void*)start, (void*)end,
1083 (int)arena_size, sv_type, (int)body_size,
1084 (int)good_arena_size / (int)body_size));
1086 *root = (void *)start;
1089 /* Where the next body would start: */
1090 char * const next = start + body_size;
1093 /* This is the last body: */
1094 assert(next == end);
1096 *(void **)start = 0;
1100 *(void**) start = (void *)next;
1105 /* grab a new thing from the free list, allocating more if necessary.
1106 The inline version is used for speed in hot routines, and the
1107 function using it serves the rest (unless PURIFY).
1109 #define new_body_inline(xpv, sv_type) \
1111 void ** const r3wt = &PL_body_roots[sv_type]; \
1112 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1113 ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1114 bodies_by_type[sv_type].body_size,\
1115 bodies_by_type[sv_type].arena_size)); \
1116 *(r3wt) = *(void**)(xpv); \
1122 S_new_body(pTHX_ const svtype sv_type)
1126 new_body_inline(xpv, sv_type);
1132 static const struct body_details fake_rv =
1133 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1136 =for apidoc sv_upgrade
1138 Upgrade an SV to a more complex form. Generally adds a new body type to the
1139 SV, then copies across as much information as possible from the old body.
1140 It croaks if the SV is already in a more complex form than requested. You
1141 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
1142 before calling C<sv_upgrade>, and hence does not croak. See also
1149 Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
1154 const svtype old_type = SvTYPE(sv);
1155 const struct body_details *new_type_details;
1156 const struct body_details *old_type_details
1157 = bodies_by_type + old_type;
1158 SV *referant = NULL;
1160 PERL_ARGS_ASSERT_SV_UPGRADE;
1162 if (old_type == new_type)
1165 /* This clause was purposefully added ahead of the early return above to
1166 the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1167 inference by Nick I-S that it would fix other troublesome cases. See
1168 changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1170 Given that shared hash key scalars are no longer PVIV, but PV, there is
1171 no longer need to unshare so as to free up the IVX slot for its proper
1172 purpose. So it's safe to move the early return earlier. */
1174 if (new_type > SVt_PVMG && SvIsCOW(sv)) {
1175 sv_force_normal_flags(sv, 0);
1178 old_body = SvANY(sv);
1180 /* Copying structures onto other structures that have been neatly zeroed
1181 has a subtle gotcha. Consider XPVMG
1183 +------+------+------+------+------+-------+-------+
1184 | NV | CUR | LEN | IV | MAGIC | STASH |
1185 +------+------+------+------+------+-------+-------+
1186 0 4 8 12 16 20 24 28
1188 where NVs are aligned to 8 bytes, so that sizeof that structure is
1189 actually 32 bytes long, with 4 bytes of padding at the end:
1191 +------+------+------+------+------+-------+-------+------+
1192 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1193 +------+------+------+------+------+-------+-------+------+
1194 0 4 8 12 16 20 24 28 32
1196 so what happens if you allocate memory for this structure:
1198 +------+------+------+------+------+-------+-------+------+------+...
1199 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1200 +------+------+------+------+------+-------+-------+------+------+...
1201 0 4 8 12 16 20 24 28 32 36
1203 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1204 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1205 started out as zero once, but it's quite possible that it isn't. So now,
1206 rather than a nicely zeroed GP, you have it pointing somewhere random.
1209 (In fact, GP ends up pointing at a previous GP structure, because the
1210 principle cause of the padding in XPVMG getting garbage is a copy of
1211 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1212 this happens to be moot because XPVGV has been re-ordered, with GP
1213 no longer after STASH)
1215 So we are careful and work out the size of used parts of all the
1223 referant = SvRV(sv);
1224 old_type_details = &fake_rv;
1225 if (new_type == SVt_NV)
1226 new_type = SVt_PVNV;
1228 if (new_type < SVt_PVIV) {
1229 new_type = (new_type == SVt_NV)
1230 ? SVt_PVNV : SVt_PVIV;
1235 if (new_type < SVt_PVNV) {
1236 new_type = SVt_PVNV;
1240 assert(new_type > SVt_PV);
1241 assert(SVt_IV < SVt_PV);
1242 assert(SVt_NV < SVt_PV);
1249 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1250 there's no way that it can be safely upgraded, because perl.c
1251 expects to Safefree(SvANY(PL_mess_sv)) */
1252 assert(sv != PL_mess_sv);
1253 /* This flag bit is used to mean other things in other scalar types.
1254 Given that it only has meaning inside the pad, it shouldn't be set
1255 on anything that can get upgraded. */
1256 assert(!SvPAD_TYPED(sv));
1259 if (UNLIKELY(old_type_details->cant_upgrade))
1260 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1261 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1264 if (UNLIKELY(old_type > new_type))
1265 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1266 (int)old_type, (int)new_type);
1268 new_type_details = bodies_by_type + new_type;
1270 SvFLAGS(sv) &= ~SVTYPEMASK;
1271 SvFLAGS(sv) |= new_type;
1273 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1274 the return statements above will have triggered. */
1275 assert (new_type != SVt_NULL);
1278 assert(old_type == SVt_NULL);
1279 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1283 assert(old_type == SVt_NULL);
1284 SvANY(sv) = new_XNV();
1289 assert(new_type_details->body_size);
1292 assert(new_type_details->arena);
1293 assert(new_type_details->arena_size);
1294 /* This points to the start of the allocated area. */
1295 new_body_inline(new_body, new_type);
1296 Zero(new_body, new_type_details->body_size, char);
1297 new_body = ((char *)new_body) - new_type_details->offset;
1299 /* We always allocated the full length item with PURIFY. To do this
1300 we fake things so that arena is false for all 16 types.. */
1301 new_body = new_NOARENAZ(new_type_details);
1303 SvANY(sv) = new_body;
1304 if (new_type == SVt_PVAV) {
1308 if (old_type_details->body_size) {
1311 /* It will have been zeroed when the new body was allocated.
1312 Lets not write to it, in case it confuses a write-back
1318 #ifndef NODEFAULT_SHAREKEYS
1319 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1321 /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
1322 HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
1325 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1326 The target created by newSVrv also is, and it can have magic.
1327 However, it never has SvPVX set.
1329 if (old_type == SVt_IV) {
1331 } else if (old_type >= SVt_PV) {
1332 assert(SvPVX_const(sv) == 0);
1335 if (old_type >= SVt_PVMG) {
1336 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1337 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1339 sv->sv_u.svu_array = NULL; /* or svu_hash */
1344 /* XXX Is this still needed? Was it ever needed? Surely as there is
1345 no route from NV to PVIV, NOK can never be true */
1346 assert(!SvNOKp(sv));
1359 assert(new_type_details->body_size);
1360 /* We always allocated the full length item with PURIFY. To do this
1361 we fake things so that arena is false for all 16 types.. */
1362 if(new_type_details->arena) {
1363 /* This points to the start of the allocated area. */
1364 new_body_inline(new_body, new_type);
1365 Zero(new_body, new_type_details->body_size, char);
1366 new_body = ((char *)new_body) - new_type_details->offset;
1368 new_body = new_NOARENAZ(new_type_details);
1370 SvANY(sv) = new_body;
1372 if (old_type_details->copy) {
1373 /* There is now the potential for an upgrade from something without
1374 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1375 int offset = old_type_details->offset;
1376 int length = old_type_details->copy;
1378 if (new_type_details->offset > old_type_details->offset) {
1379 const int difference
1380 = new_type_details->offset - old_type_details->offset;
1381 offset += difference;
1382 length -= difference;
1384 assert (length >= 0);
1386 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1390 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1391 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1392 * correct 0.0 for us. Otherwise, if the old body didn't have an
1393 * NV slot, but the new one does, then we need to initialise the
1394 * freshly created NV slot with whatever the correct bit pattern is
1396 if (old_type_details->zero_nv && !new_type_details->zero_nv
1397 && !isGV_with_GP(sv))
1401 if (UNLIKELY(new_type == SVt_PVIO)) {
1402 IO * const io = MUTABLE_IO(sv);
1403 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1406 /* Clear the stashcache because a new IO could overrule a package
1408 DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
1409 hv_clear(PL_stashcache);
1411 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1412 IoPAGE_LEN(sv) = 60;
1414 if (UNLIKELY(new_type == SVt_REGEXP))
1415 sv->sv_u.svu_rx = (regexp *)new_body;
1416 else if (old_type < SVt_PV) {
1417 /* referant will be NULL unless the old type was SVt_IV emulating
1419 sv->sv_u.svu_rv = referant;
1423 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1424 (unsigned long)new_type);
1427 if (old_type > SVt_IV) {
1431 /* Note that there is an assumption that all bodies of types that
1432 can be upgraded came from arenas. Only the more complex non-
1433 upgradable types are allowed to be directly malloc()ed. */
1434 assert(old_type_details->arena);
1435 del_body((void*)((char*)old_body + old_type_details->offset),
1436 &PL_body_roots[old_type]);
1442 =for apidoc sv_backoff
1444 Remove any string offset. You should normally use the C<SvOOK_off> macro
1451 Perl_sv_backoff(pTHX_ SV *const sv)
1454 const char * const s = SvPVX_const(sv);
1456 PERL_ARGS_ASSERT_SV_BACKOFF;
1457 PERL_UNUSED_CONTEXT;
1460 assert(SvTYPE(sv) != SVt_PVHV);
1461 assert(SvTYPE(sv) != SVt_PVAV);
1463 SvOOK_offset(sv, delta);
1465 SvLEN_set(sv, SvLEN(sv) + delta);
1466 SvPV_set(sv, SvPVX(sv) - delta);
1467 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1468 SvFLAGS(sv) &= ~SVf_OOK;
1475 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1476 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1477 Use the C<SvGROW> wrapper instead.
1482 static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
1485 Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
1489 PERL_ARGS_ASSERT_SV_GROW;
1493 if (SvTYPE(sv) < SVt_PV) {
1494 sv_upgrade(sv, SVt_PV);
1495 s = SvPVX_mutable(sv);
1497 else if (SvOOK(sv)) { /* pv is offset? */
1499 s = SvPVX_mutable(sv);
1500 if (newlen > SvLEN(sv))
1501 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1505 if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
1506 s = SvPVX_mutable(sv);
1509 #ifdef PERL_NEW_COPY_ON_WRITE
1510 /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1511 * to store the COW count. So in general, allocate one more byte than
1512 * asked for, to make it likely this byte is always spare: and thus
1513 * make more strings COW-able.
1514 * If the new size is a big power of two, don't bother: we assume the
1515 * caller wanted a nice 2^N sized block and will be annoyed at getting
1521 if (newlen > SvLEN(sv)) { /* need more room? */
1522 STRLEN minlen = SvCUR(sv);
1523 minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1524 if (newlen < minlen)
1526 #ifndef Perl_safesysmalloc_size
1527 newlen = PERL_STRLEN_ROUNDUP(newlen);
1529 if (SvLEN(sv) && s) {
1530 s = (char*)saferealloc(s, newlen);
1533 s = (char*)safemalloc(newlen);
1534 if (SvPVX_const(sv) && SvCUR(sv)) {
1535 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1539 #ifdef Perl_safesysmalloc_size
1540 /* Do this here, do it once, do it right, and then we will never get
1541 called back into sv_grow() unless there really is some growing
1543 SvLEN_set(sv, Perl_safesysmalloc_size(s));
1545 SvLEN_set(sv, newlen);
1552 =for apidoc sv_setiv
1554 Copies an integer into the given SV, upgrading first if necessary.
1555 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1561 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1565 PERL_ARGS_ASSERT_SV_SETIV;
1567 SV_CHECK_THINKFIRST_COW_DROP(sv);
1568 switch (SvTYPE(sv)) {
1571 sv_upgrade(sv, SVt_IV);
1574 sv_upgrade(sv, SVt_PVIV);
1578 if (!isGV_with_GP(sv))
1585 /* diag_listed_as: Can't coerce %s to %s in %s */
1586 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1590 (void)SvIOK_only(sv); /* validate number */
1596 =for apidoc sv_setiv_mg
1598 Like C<sv_setiv>, but also handles 'set' magic.
1604 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1606 PERL_ARGS_ASSERT_SV_SETIV_MG;
1613 =for apidoc sv_setuv
1615 Copies an unsigned integer into the given SV, upgrading first if necessary.
1616 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1622 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1624 PERL_ARGS_ASSERT_SV_SETUV;
1626 /* With the if statement to ensure that integers are stored as IVs whenever
1628 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1631 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1633 If you wish to remove the following if statement, so that this routine
1634 (and its callers) always return UVs, please benchmark to see what the
1635 effect is. Modern CPUs may be different. Or may not :-)
1637 if (u <= (UV)IV_MAX) {
1638 sv_setiv(sv, (IV)u);
1647 =for apidoc sv_setuv_mg
1649 Like C<sv_setuv>, but also handles 'set' magic.
1655 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1657 PERL_ARGS_ASSERT_SV_SETUV_MG;
1664 =for apidoc sv_setnv
1666 Copies a double into the given SV, upgrading first if necessary.
1667 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1673 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1677 PERL_ARGS_ASSERT_SV_SETNV;
1679 SV_CHECK_THINKFIRST_COW_DROP(sv);
1680 switch (SvTYPE(sv)) {
1683 sv_upgrade(sv, SVt_NV);
1687 sv_upgrade(sv, SVt_PVNV);
1691 if (!isGV_with_GP(sv))
1698 /* diag_listed_as: Can't coerce %s to %s in %s */
1699 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1704 (void)SvNOK_only(sv); /* validate number */
1709 =for apidoc sv_setnv_mg
1711 Like C<sv_setnv>, but also handles 'set' magic.
1717 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1719 PERL_ARGS_ASSERT_SV_SETNV_MG;
1725 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1726 * not incrementable warning display.
1727 * Originally part of S_not_a_number().
1728 * The return value may be != tmpbuf.
1732 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1735 PERL_ARGS_ASSERT_SV_DISPLAY;
1738 SV *dsv = newSVpvs_flags("", SVs_TEMP);
1739 pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
1742 const char * const limit = tmpbuf + tmpbuf_size - 8;
1743 /* each *s can expand to 4 chars + "...\0",
1744 i.e. need room for 8 chars */
1746 const char *s = SvPVX_const(sv);
1747 const char * const end = s + SvCUR(sv);
1748 for ( ; s < end && d < limit; s++ ) {
1750 if (! isASCII(ch) && !isPRINT_LC(ch)) {
1754 /* Map to ASCII "equivalent" of Latin1 */
1755 ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1761 else if (ch == '\r') {
1765 else if (ch == '\f') {
1769 else if (ch == '\\') {
1773 else if (ch == '\0') {
1777 else if (isPRINT_LC(ch))
1796 /* Print an "isn't numeric" warning, using a cleaned-up,
1797 * printable version of the offending string
1801 S_not_a_number(pTHX_ SV *const sv)
1807 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1809 pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1812 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1813 /* diag_listed_as: Argument "%s" isn't numeric%s */
1814 "Argument \"%s\" isn't numeric in %s", pv,
1817 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1818 /* diag_listed_as: Argument "%s" isn't numeric%s */
1819 "Argument \"%s\" isn't numeric", pv);
1823 S_not_incrementable(pTHX_ SV *const sv) {
1828 PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1830 pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1832 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1833 "Argument \"%s\" treated as 0 in increment (++)", pv);
1837 =for apidoc looks_like_number
1839 Test if the content of an SV looks like a number (or is a number).
1840 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1841 non-numeric warning), even if your atof() doesn't grok them. Get-magic is
1848 Perl_looks_like_number(pTHX_ SV *const sv)
1853 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1855 if (SvPOK(sv) || SvPOKp(sv)) {
1856 sbegin = SvPV_nomg_const(sv, len);
1859 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1860 return grok_number(sbegin, len, NULL);
1864 S_glob_2number(pTHX_ GV * const gv)
1866 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1868 /* We know that all GVs stringify to something that is not-a-number,
1869 so no need to test that. */
1870 if (ckWARN(WARN_NUMERIC))
1872 SV *const buffer = sv_newmortal();
1873 gv_efullname3(buffer, gv, "*");
1874 not_a_number(buffer);
1876 /* We just want something true to return, so that S_sv_2iuv_common
1877 can tail call us and return true. */
1881 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1882 until proven guilty, assume that things are not that bad... */
1887 As 64 bit platforms often have an NV that doesn't preserve all bits of
1888 an IV (an assumption perl has been based on to date) it becomes necessary
1889 to remove the assumption that the NV always carries enough precision to
1890 recreate the IV whenever needed, and that the NV is the canonical form.
1891 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1892 precision as a side effect of conversion (which would lead to insanity
1893 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1894 1) to distinguish between IV/UV/NV slots that have cached a valid
1895 conversion where precision was lost and IV/UV/NV slots that have a
1896 valid conversion which has lost no precision
1897 2) to ensure that if a numeric conversion to one form is requested that
1898 would lose precision, the precise conversion (or differently
1899 imprecise conversion) is also performed and cached, to prevent
1900 requests for different numeric formats on the same SV causing
1901 lossy conversion chains. (lossless conversion chains are perfectly
1906 SvIOKp is true if the IV slot contains a valid value
1907 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1908 SvNOKp is true if the NV slot contains a valid value
1909 SvNOK is true only if the NV value is accurate
1912 while converting from PV to NV, check to see if converting that NV to an
1913 IV(or UV) would lose accuracy over a direct conversion from PV to
1914 IV(or UV). If it would, cache both conversions, return NV, but mark
1915 SV as IOK NOKp (ie not NOK).
1917 While converting from PV to IV, check to see if converting that IV to an
1918 NV would lose accuracy over a direct conversion from PV to NV. If it
1919 would, cache both conversions, flag similarly.
1921 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1922 correctly because if IV & NV were set NV *always* overruled.
1923 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1924 changes - now IV and NV together means that the two are interchangeable:
1925 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1927 The benefit of this is that operations such as pp_add know that if
1928 SvIOK is true for both left and right operands, then integer addition
1929 can be used instead of floating point (for cases where the result won't
1930 overflow). Before, floating point was always used, which could lead to
1931 loss of precision compared with integer addition.
1933 * making IV and NV equal status should make maths accurate on 64 bit
1935 * may speed up maths somewhat if pp_add and friends start to use
1936 integers when possible instead of fp. (Hopefully the overhead in
1937 looking for SvIOK and checking for overflow will not outweigh the
1938 fp to integer speedup)
1939 * will slow down integer operations (callers of SvIV) on "inaccurate"
1940 values, as the change from SvIOK to SvIOKp will cause a call into
1941 sv_2iv each time rather than a macro access direct to the IV slot
1942 * should speed up number->string conversion on integers as IV is
1943 favoured when IV and NV are equally accurate
1945 ####################################################################
1946 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1947 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1948 On the other hand, SvUOK is true iff UV.
1949 ####################################################################
1951 Your mileage will vary depending your CPU's relative fp to integer
1955 #ifndef NV_PRESERVES_UV
1956 # define IS_NUMBER_UNDERFLOW_IV 1
1957 # define IS_NUMBER_UNDERFLOW_UV 2
1958 # define IS_NUMBER_IV_AND_UV 2
1959 # define IS_NUMBER_OVERFLOW_IV 4
1960 # define IS_NUMBER_OVERFLOW_UV 5
1962 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1964 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1966 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
1974 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1976 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));
1977 if (SvNVX(sv) < (NV)IV_MIN) {
1978 (void)SvIOKp_on(sv);
1980 SvIV_set(sv, IV_MIN);
1981 return IS_NUMBER_UNDERFLOW_IV;
1983 if (SvNVX(sv) > (NV)UV_MAX) {
1984 (void)SvIOKp_on(sv);
1987 SvUV_set(sv, UV_MAX);
1988 return IS_NUMBER_OVERFLOW_UV;
1990 (void)SvIOKp_on(sv);
1992 /* Can't use strtol etc to convert this string. (See truth table in
1994 if (SvNVX(sv) <= (UV)IV_MAX) {
1995 SvIV_set(sv, I_V(SvNVX(sv)));
1996 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1997 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1999 /* Integer is imprecise. NOK, IOKp */
2001 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2004 SvUV_set(sv, U_V(SvNVX(sv)));
2005 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2006 if (SvUVX(sv) == UV_MAX) {
2007 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2008 possibly be preserved by NV. Hence, it must be overflow.
2010 return IS_NUMBER_OVERFLOW_UV;
2012 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2014 /* Integer is imprecise. NOK, IOKp */
2016 return IS_NUMBER_OVERFLOW_IV;
2018 #endif /* !NV_PRESERVES_UV*/
2021 S_sv_2iuv_common(pTHX_ SV *const sv)
2025 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2028 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2029 * without also getting a cached IV/UV from it at the same time
2030 * (ie PV->NV conversion should detect loss of accuracy and cache
2031 * IV or UV at same time to avoid this. */
2032 /* IV-over-UV optimisation - choose to cache IV if possible */
2034 if (SvTYPE(sv) == SVt_NV)
2035 sv_upgrade(sv, SVt_PVNV);
2037 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2038 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2039 certainly cast into the IV range at IV_MAX, whereas the correct
2040 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2042 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2043 if (Perl_isnan(SvNVX(sv))) {
2049 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2050 SvIV_set(sv, I_V(SvNVX(sv)));
2051 if (SvNVX(sv) == (NV) SvIVX(sv)
2052 #ifndef NV_PRESERVES_UV
2053 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2054 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2055 /* Don't flag it as "accurately an integer" if the number
2056 came from a (by definition imprecise) NV operation, and
2057 we're outside the range of NV integer precision */
2061 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2063 /* scalar has trailing garbage, eg "42a" */
2065 DEBUG_c(PerlIO_printf(Perl_debug_log,
2066 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2072 /* IV not precise. No need to convert from PV, as NV
2073 conversion would already have cached IV if it detected
2074 that PV->IV would be better than PV->NV->IV
2075 flags already correct - don't set public IOK. */
2076 DEBUG_c(PerlIO_printf(Perl_debug_log,
2077 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2082 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2083 but the cast (NV)IV_MIN rounds to a the value less (more
2084 negative) than IV_MIN which happens to be equal to SvNVX ??
2085 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2086 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2087 (NV)UVX == NVX are both true, but the values differ. :-(
2088 Hopefully for 2s complement IV_MIN is something like
2089 0x8000000000000000 which will be exact. NWC */
2092 SvUV_set(sv, U_V(SvNVX(sv)));
2094 (SvNVX(sv) == (NV) SvUVX(sv))
2095 #ifndef NV_PRESERVES_UV
2096 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2097 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2098 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2099 /* Don't flag it as "accurately an integer" if the number
2100 came from a (by definition imprecise) NV operation, and
2101 we're outside the range of NV integer precision */
2107 DEBUG_c(PerlIO_printf(Perl_debug_log,
2108 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2114 else if (SvPOKp(sv)) {
2116 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2117 /* We want to avoid a possible problem when we cache an IV/ a UV which
2118 may be later translated to an NV, and the resulting NV is not
2119 the same as the direct translation of the initial string
2120 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2121 be careful to ensure that the value with the .456 is around if the
2122 NV value is requested in the future).
2124 This means that if we cache such an IV/a UV, we need to cache the
2125 NV as well. Moreover, we trade speed for space, and do not
2126 cache the NV if we are sure it's not needed.
2129 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2130 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2131 == IS_NUMBER_IN_UV) {
2132 /* It's definitely an integer, only upgrade to PVIV */
2133 if (SvTYPE(sv) < SVt_PVIV)
2134 sv_upgrade(sv, SVt_PVIV);
2136 } else if (SvTYPE(sv) < SVt_PVNV)
2137 sv_upgrade(sv, SVt_PVNV);
2139 /* If NVs preserve UVs then we only use the UV value if we know that
2140 we aren't going to call atof() below. If NVs don't preserve UVs
2141 then the value returned may have more precision than atof() will
2142 return, even though value isn't perfectly accurate. */
2143 if ((numtype & (IS_NUMBER_IN_UV
2144 #ifdef NV_PRESERVES_UV
2147 )) == IS_NUMBER_IN_UV) {
2148 /* This won't turn off the public IOK flag if it was set above */
2149 (void)SvIOKp_on(sv);
2151 if (!(numtype & IS_NUMBER_NEG)) {
2153 if (value <= (UV)IV_MAX) {
2154 SvIV_set(sv, (IV)value);
2156 /* it didn't overflow, and it was positive. */
2157 SvUV_set(sv, value);
2161 /* 2s complement assumption */
2162 if (value <= (UV)IV_MIN) {
2163 SvIV_set(sv, -(IV)value);
2165 /* Too negative for an IV. This is a double upgrade, but
2166 I'm assuming it will be rare. */
2167 if (SvTYPE(sv) < SVt_PVNV)
2168 sv_upgrade(sv, SVt_PVNV);
2172 SvNV_set(sv, -(NV)value);
2173 SvIV_set(sv, IV_MIN);
2177 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2178 will be in the previous block to set the IV slot, and the next
2179 block to set the NV slot. So no else here. */
2181 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2182 != IS_NUMBER_IN_UV) {
2183 /* It wasn't an (integer that doesn't overflow the UV). */
2184 SvNV_set(sv, Atof(SvPVX_const(sv)));
2186 if (! numtype && ckWARN(WARN_NUMERIC))
2189 #if defined(USE_LONG_DOUBLE)
2190 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2191 PTR2UV(sv), SvNVX(sv)));
2193 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2194 PTR2UV(sv), SvNVX(sv)));
2197 #ifdef NV_PRESERVES_UV
2198 (void)SvIOKp_on(sv);
2200 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2201 SvIV_set(sv, I_V(SvNVX(sv)));
2202 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2205 NOOP; /* Integer is imprecise. NOK, IOKp */
2207 /* UV will not work better than IV */
2209 if (SvNVX(sv) > (NV)UV_MAX) {
2211 /* Integer is inaccurate. NOK, IOKp, is UV */
2212 SvUV_set(sv, UV_MAX);
2214 SvUV_set(sv, U_V(SvNVX(sv)));
2215 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2216 NV preservse UV so can do correct comparison. */
2217 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2220 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
2225 #else /* NV_PRESERVES_UV */
2226 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2227 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2228 /* The IV/UV slot will have been set from value returned by
2229 grok_number above. The NV slot has just been set using
2232 assert (SvIOKp(sv));
2234 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2235 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2236 /* Small enough to preserve all bits. */
2237 (void)SvIOKp_on(sv);
2239 SvIV_set(sv, I_V(SvNVX(sv)));
2240 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2242 /* Assumption: first non-preserved integer is < IV_MAX,
2243 this NV is in the preserved range, therefore: */
2244 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2246 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);
2250 0 0 already failed to read UV.
2251 0 1 already failed to read UV.
2252 1 0 you won't get here in this case. IV/UV
2253 slot set, public IOK, Atof() unneeded.
2254 1 1 already read UV.
2255 so there's no point in sv_2iuv_non_preserve() attempting
2256 to use atol, strtol, strtoul etc. */
2258 sv_2iuv_non_preserve (sv, numtype);
2260 sv_2iuv_non_preserve (sv);
2264 #endif /* NV_PRESERVES_UV */
2265 /* It might be more code efficient to go through the entire logic above
2266 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2267 gets complex and potentially buggy, so more programmer efficient
2268 to do it this way, by turning off the public flags: */
2270 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2274 if (isGV_with_GP(sv))
2275 return glob_2number(MUTABLE_GV(sv));
2277 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2279 if (SvTYPE(sv) < SVt_IV)
2280 /* Typically the caller expects that sv_any is not NULL now. */
2281 sv_upgrade(sv, SVt_IV);
2282 /* Return 0 from the caller. */
2289 =for apidoc sv_2iv_flags
2291 Return the integer value of an SV, doing any necessary string
2292 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2293 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2299 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2303 PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2305 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2306 && SvTYPE(sv) != SVt_PVFM);
2308 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2314 if (flags & SV_SKIP_OVERLOAD)
2316 tmpstr = AMG_CALLunary(sv, numer_amg);
2317 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2318 return SvIV(tmpstr);
2321 return PTR2IV(SvRV(sv));
2324 if (SvVALID(sv) || isREGEXP(sv)) {
2325 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2326 the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2327 In practice they are extremely unlikely to actually get anywhere
2328 accessible by user Perl code - the only way that I'm aware of is when
2329 a constant subroutine which is used as the second argument to index.
2331 Regexps have no SvIVX and SvNVX fields.
2333 assert(isREGEXP(sv) || SvPOKp(sv));
2336 const char * const ptr =
2337 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2339 = grok_number(ptr, SvCUR(sv), &value);
2341 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2342 == IS_NUMBER_IN_UV) {
2343 /* It's definitely an integer */
2344 if (numtype & IS_NUMBER_NEG) {
2345 if (value < (UV)IV_MIN)
2348 if (value < (UV)IV_MAX)
2353 if (ckWARN(WARN_NUMERIC))
2356 return I_V(Atof(ptr));
2360 if (SvTHINKFIRST(sv)) {
2361 #ifdef PERL_OLD_COPY_ON_WRITE
2363 sv_force_normal_flags(sv, 0);
2366 if (SvREADONLY(sv) && !SvOK(sv)) {
2367 if (ckWARN(WARN_UNINITIALIZED))
2374 if (S_sv_2iuv_common(aTHX_ sv))
2378 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2379 PTR2UV(sv),SvIVX(sv)));
2380 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2384 =for apidoc sv_2uv_flags
2386 Return the unsigned integer value of an SV, doing any necessary string
2387 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2388 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2394 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2398 PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2400 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2406 if (flags & SV_SKIP_OVERLOAD)
2408 tmpstr = AMG_CALLunary(sv, numer_amg);
2409 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2410 return SvUV(tmpstr);
2413 return PTR2UV(SvRV(sv));
2416 if (SvVALID(sv) || isREGEXP(sv)) {
2417 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2418 the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2419 Regexps have no SvIVX and SvNVX fields. */
2420 assert(isREGEXP(sv) || SvPOKp(sv));
2423 const char * const ptr =
2424 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2426 = grok_number(ptr, SvCUR(sv), &value);
2428 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2429 == IS_NUMBER_IN_UV) {
2430 /* It's definitely an integer */
2431 if (!(numtype & IS_NUMBER_NEG))
2435 if (ckWARN(WARN_NUMERIC))
2438 return U_V(Atof(ptr));
2442 if (SvTHINKFIRST(sv)) {
2443 #ifdef PERL_OLD_COPY_ON_WRITE
2445 sv_force_normal_flags(sv, 0);
2448 if (SvREADONLY(sv) && !SvOK(sv)) {
2449 if (ckWARN(WARN_UNINITIALIZED))
2456 if (S_sv_2iuv_common(aTHX_ sv))
2460 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2461 PTR2UV(sv),SvUVX(sv)));
2462 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2466 =for apidoc sv_2nv_flags
2468 Return the num value of an SV, doing any necessary string or integer
2469 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2470 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2476 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2480 PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2482 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2483 && SvTYPE(sv) != SVt_PVFM);
2484 if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2485 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2486 the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2487 Regexps have no SvIVX and SvNVX fields. */
2489 if (flags & SV_GMAGIC)
2493 if (SvPOKp(sv) && !SvIOKp(sv)) {
2494 ptr = SvPVX_const(sv);
2496 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2497 !grok_number(ptr, SvCUR(sv), NULL))
2503 return (NV)SvUVX(sv);
2505 return (NV)SvIVX(sv);
2511 ptr = RX_WRAPPED((REGEXP *)sv);
2514 assert(SvTYPE(sv) >= SVt_PVMG);
2515 /* This falls through to the report_uninit near the end of the
2517 } else if (SvTHINKFIRST(sv)) {
2522 if (flags & SV_SKIP_OVERLOAD)
2524 tmpstr = AMG_CALLunary(sv, numer_amg);
2525 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2526 return SvNV(tmpstr);
2529 return PTR2NV(SvRV(sv));
2531 #ifdef PERL_OLD_COPY_ON_WRITE
2533 sv_force_normal_flags(sv, 0);
2536 if (SvREADONLY(sv) && !SvOK(sv)) {
2537 if (ckWARN(WARN_UNINITIALIZED))
2542 if (SvTYPE(sv) < SVt_NV) {
2543 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2544 sv_upgrade(sv, SVt_NV);
2545 #ifdef USE_LONG_DOUBLE
2547 STORE_NUMERIC_LOCAL_SET_STANDARD();
2548 PerlIO_printf(Perl_debug_log,
2549 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2550 PTR2UV(sv), SvNVX(sv));
2551 RESTORE_NUMERIC_LOCAL();
2555 STORE_NUMERIC_LOCAL_SET_STANDARD();
2556 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2557 PTR2UV(sv), SvNVX(sv));
2558 RESTORE_NUMERIC_LOCAL();
2562 else if (SvTYPE(sv) < SVt_PVNV)
2563 sv_upgrade(sv, SVt_PVNV);
2568 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2569 #ifdef NV_PRESERVES_UV
2575 /* Only set the public NV OK flag if this NV preserves the IV */
2576 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2578 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2579 : (SvIVX(sv) == I_V(SvNVX(sv))))
2585 else if (SvPOKp(sv)) {
2587 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2588 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2590 #ifdef NV_PRESERVES_UV
2591 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2592 == IS_NUMBER_IN_UV) {
2593 /* It's definitely an integer */
2594 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2596 SvNV_set(sv, Atof(SvPVX_const(sv)));
2602 SvNV_set(sv, Atof(SvPVX_const(sv)));
2603 /* Only set the public NV OK flag if this NV preserves the value in
2604 the PV at least as well as an IV/UV would.
2605 Not sure how to do this 100% reliably. */
2606 /* if that shift count is out of range then Configure's test is
2607 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2609 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2610 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2611 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2612 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2613 /* Can't use strtol etc to convert this string, so don't try.
2614 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2617 /* value has been set. It may not be precise. */
2618 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2619 /* 2s complement assumption for (UV)IV_MIN */
2620 SvNOK_on(sv); /* Integer is too negative. */
2625 if (numtype & IS_NUMBER_NEG) {
2626 SvIV_set(sv, -(IV)value);
2627 } else if (value <= (UV)IV_MAX) {
2628 SvIV_set(sv, (IV)value);
2630 SvUV_set(sv, value);
2634 if (numtype & IS_NUMBER_NOT_INT) {
2635 /* I believe that even if the original PV had decimals,
2636 they are lost beyond the limit of the FP precision.
2637 However, neither is canonical, so both only get p
2638 flags. NWC, 2000/11/25 */
2639 /* Both already have p flags, so do nothing */
2641 const NV nv = SvNVX(sv);
2642 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2643 if (SvIVX(sv) == I_V(nv)) {
2646 /* It had no "." so it must be integer. */
2650 /* between IV_MAX and NV(UV_MAX).
2651 Could be slightly > UV_MAX */
2653 if (numtype & IS_NUMBER_NOT_INT) {
2654 /* UV and NV both imprecise. */
2656 const UV nv_as_uv = U_V(nv);
2658 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2667 /* It might be more code efficient to go through the entire logic above
2668 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2669 gets complex and potentially buggy, so more programmer efficient
2670 to do it this way, by turning off the public flags: */
2672 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2673 #endif /* NV_PRESERVES_UV */
2676 if (isGV_with_GP(sv)) {
2677 glob_2number(MUTABLE_GV(sv));
2681 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2683 assert (SvTYPE(sv) >= SVt_NV);
2684 /* Typically the caller expects that sv_any is not NULL now. */
2685 /* XXX Ilya implies that this is a bug in callers that assume this
2686 and ideally should be fixed. */
2689 #if defined(USE_LONG_DOUBLE)
2691 STORE_NUMERIC_LOCAL_SET_STANDARD();
2692 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2693 PTR2UV(sv), SvNVX(sv));
2694 RESTORE_NUMERIC_LOCAL();
2698 STORE_NUMERIC_LOCAL_SET_STANDARD();
2699 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2700 PTR2UV(sv), SvNVX(sv));
2701 RESTORE_NUMERIC_LOCAL();
2710 Return an SV with the numeric value of the source SV, doing any necessary
2711 reference or overload conversion. You must use the C<SvNUM(sv)> macro to
2712 access this function.
2718 Perl_sv_2num(pTHX_ SV *const sv)
2720 PERL_ARGS_ASSERT_SV_2NUM;
2725 SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2726 TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2727 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2728 return sv_2num(tmpsv);
2730 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2733 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2734 * UV as a string towards the end of buf, and return pointers to start and
2737 * We assume that buf is at least TYPE_CHARS(UV) long.
2741 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2743 char *ptr = buf + TYPE_CHARS(UV);
2744 char * const ebuf = ptr;
2747 PERL_ARGS_ASSERT_UIV_2BUF;
2759 *--ptr = '0' + (char)(uv % 10);
2768 =for apidoc sv_2pv_flags
2770 Returns a pointer to the string value of an SV, and sets *lp to its length.
2771 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a
2772 string if necessary. Normally invoked via the C<SvPV_flags> macro.
2773 C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
2779 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
2784 PERL_ARGS_ASSERT_SV_2PV_FLAGS;
2786 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2787 && SvTYPE(sv) != SVt_PVFM);
2788 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2793 if (flags & SV_SKIP_OVERLOAD)
2795 tmpstr = AMG_CALLunary(sv, string_amg);
2796 TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2797 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2799 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2803 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2804 if (flags & SV_CONST_RETURN) {
2805 pv = (char *) SvPVX_const(tmpstr);
2807 pv = (flags & SV_MUTABLE_RETURN)
2808 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2811 *lp = SvCUR(tmpstr);
2813 pv = sv_2pv_flags(tmpstr, lp, flags);
2826 SV *const referent = SvRV(sv);
2830 retval = buffer = savepvn("NULLREF", len);
2831 } else if (SvTYPE(referent) == SVt_REGEXP &&
2832 (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
2833 amagic_is_enabled(string_amg))) {
2834 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2838 /* If the regex is UTF-8 we want the containing scalar to
2839 have an UTF-8 flag too */
2846 *lp = RX_WRAPLEN(re);
2848 return RX_WRAPPED(re);
2850 const char *const typestr = sv_reftype(referent, 0);
2851 const STRLEN typelen = strlen(typestr);
2852 UV addr = PTR2UV(referent);
2853 const char *stashname = NULL;
2854 STRLEN stashnamelen = 0; /* hush, gcc */
2855 const char *buffer_end;
2857 if (SvOBJECT(referent)) {
2858 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2861 stashname = HEK_KEY(name);
2862 stashnamelen = HEK_LEN(name);
2864 if (HEK_UTF8(name)) {
2870 stashname = "__ANON__";
2873 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2874 + 2 * sizeof(UV) + 2 /* )\0 */;
2876 len = typelen + 3 /* (0x */
2877 + 2 * sizeof(UV) + 2 /* )\0 */;
2880 Newx(buffer, len, char);
2881 buffer_end = retval = buffer + len;
2883 /* Working backwards */
2887 *--retval = PL_hexdigit[addr & 15];
2888 } while (addr >>= 4);
2894 memcpy(retval, typestr, typelen);
2898 retval -= stashnamelen;
2899 memcpy(retval, stashname, stashnamelen);
2901 /* retval may not necessarily have reached the start of the
2903 assert (retval >= buffer);
2905 len = buffer_end - retval - 1; /* -1 for that \0 */
2917 if (flags & SV_MUTABLE_RETURN)
2918 return SvPVX_mutable(sv);
2919 if (flags & SV_CONST_RETURN)
2920 return (char *)SvPVX_const(sv);
2925 /* I'm assuming that if both IV and NV are equally valid then
2926 converting the IV is going to be more efficient */
2927 const U32 isUIOK = SvIsUV(sv);
2928 char buf[TYPE_CHARS(UV)];
2932 if (SvTYPE(sv) < SVt_PVIV)
2933 sv_upgrade(sv, SVt_PVIV);
2934 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2936 /* inlined from sv_setpvn */
2937 s = SvGROW_mutable(sv, len + 1);
2938 Move(ptr, s, len, char);
2943 else if (SvNOK(sv)) {
2944 if (SvTYPE(sv) < SVt_PVNV)
2945 sv_upgrade(sv, SVt_PVNV);
2946 if (SvNVX(sv) == 0.0) {
2947 s = SvGROW_mutable(sv, 2);
2952 /* The +20 is pure guesswork. Configure test needed. --jhi */
2953 s = SvGROW_mutable(sv, NV_DIG + 20);
2954 /* some Xenix systems wipe out errno here */
2956 #ifndef USE_LOCALE_NUMERIC
2957 V_Gconvert(SvNVX(sv), NV_DIG, 0, s);
2961 DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
2962 V_Gconvert(SvNVX(sv), NV_DIG, 0, s);
2964 /* If the radix character is UTF-8, and actually is in the
2965 * output, turn on the UTF-8 flag for the scalar */
2966 if (PL_numeric_local
2967 && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
2968 && instr(s, SvPVX_const(PL_numeric_radix_sv)))
2972 RESTORE_LC_NUMERIC();
2975 /* We don't call SvPOK_on(), because it may come to pass that the
2976 * locale changes so that the stringification we just did is no
2977 * longer correct. We will have to re-stringify every time it is
2984 else if (isGV_with_GP(sv)) {
2985 GV *const gv = MUTABLE_GV(sv);
2986 SV *const buffer = sv_newmortal();
2988 gv_efullname3(buffer, gv, "*");
2990 assert(SvPOK(buffer));
2994 *lp = SvCUR(buffer);
2995 return SvPVX(buffer);
2997 else if (isREGEXP(sv)) {
2998 if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
2999 return RX_WRAPPED((REGEXP *)sv);
3004 if (flags & SV_UNDEF_RETURNS_NULL)
3006 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3008 /* Typically the caller expects that sv_any is not NULL now. */
3009 if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3010 sv_upgrade(sv, SVt_PV);
3015 const STRLEN len = s - SvPVX_const(sv);
3020 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3021 PTR2UV(sv),SvPVX_const(sv)));
3022 if (flags & SV_CONST_RETURN)
3023 return (char *)SvPVX_const(sv);
3024 if (flags & SV_MUTABLE_RETURN)
3025 return SvPVX_mutable(sv);
3030 =for apidoc sv_copypv
3032 Copies a stringified representation of the source SV into the
3033 destination SV. Automatically performs any necessary mg_get and
3034 coercion of numeric values into strings. Guaranteed to preserve
3035 UTF8 flag even from overloaded objects. Similar in nature to
3036 sv_2pv[_flags] but operates directly on an SV instead of just the
3037 string. Mostly uses sv_2pv_flags to do its work, except when that
3038 would lose the UTF-8'ness of the PV.
3040 =for apidoc sv_copypv_nomg
3042 Like sv_copypv, but doesn't invoke get magic first.
3044 =for apidoc sv_copypv_flags
3046 Implementation of sv_copypv and sv_copypv_nomg. Calls get magic iff flags
3053 Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
3055 PERL_ARGS_ASSERT_SV_COPYPV;
3057 sv_copypv_flags(dsv, ssv, 0);
3061 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3066 PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3068 if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv))
3070 s = SvPV_nomg_const(ssv,len);
3071 sv_setpvn(dsv,s,len);
3079 =for apidoc sv_2pvbyte
3081 Return a pointer to the byte-encoded representation of the SV, and set *lp
3082 to its length. May cause the SV to be downgraded from UTF-8 as a
3085 Usually accessed via the C<SvPVbyte> macro.
3091 Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
3093 PERL_ARGS_ASSERT_SV_2PVBYTE;
3096 if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3097 || isGV_with_GP(sv) || SvROK(sv)) {
3098 SV *sv2 = sv_newmortal();
3099 sv_copypv_nomg(sv2,sv);
3102 sv_utf8_downgrade(sv,0);
3103 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3107 =for apidoc sv_2pvutf8
3109 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3110 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3112 Usually accessed via the C<SvPVutf8> macro.
3118 Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
3120 PERL_ARGS_ASSERT_SV_2PVUTF8;
3122 if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3123 || isGV_with_GP(sv) || SvROK(sv))
3124 sv = sv_mortalcopy(sv);
3127 sv_utf8_upgrade_nomg(sv);
3128 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3133 =for apidoc sv_2bool
3135 This macro is only used by sv_true() or its macro equivalent, and only if
3136 the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3137 It calls sv_2bool_flags with the SV_GMAGIC flag.
3139 =for apidoc sv_2bool_flags
3141 This function is only used by sv_true() and friends, and only if
3142 the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
3143 contain SV_GMAGIC, then it does an mg_get() first.
3150 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3154 PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3157 if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3163 SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3164 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3167 if(SvGMAGICAL(sv)) {
3169 goto restart; /* call sv_2bool */
3171 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3172 else if(!SvOK(sv)) {
3175 else if(SvPOK(sv)) {
3176 svb = SvPVXtrue(sv);
3178 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3179 svb = (SvIOK(sv) && SvIVX(sv) != 0)
3180 || (SvNOK(sv) && SvNVX(sv) != 0.0);
3184 goto restart; /* call sv_2bool_nomg */
3189 return SvRV(sv) != 0;
3193 RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3194 return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
3198 =for apidoc sv_utf8_upgrade
3200 Converts the PV of an SV to its UTF-8-encoded form.
3201 Forces the SV to string form if it is not already.
3202 Will C<mg_get> on C<sv> if appropriate.
3203 Always sets the SvUTF8 flag to avoid future validity checks even
3204 if the whole string is the same in UTF-8 as not.
3205 Returns the number of bytes in the converted string
3207 This is not a general purpose byte encoding to Unicode interface:
3208 use the Encode extension for that.
3210 =for apidoc sv_utf8_upgrade_nomg
3212 Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
3214 =for apidoc sv_utf8_upgrade_flags
3216 Converts the PV of an SV to its UTF-8-encoded form.
3217 Forces the SV to string form if it is not already.
3218 Always sets the SvUTF8 flag to avoid future validity checks even
3219 if all the bytes are invariant in UTF-8.
3220 If C<flags> has C<SV_GMAGIC> bit set,
3221 will C<mg_get> on C<sv> if appropriate, else not.
3223 If C<flags> has SV_FORCE_UTF8_UPGRADE set, this function assumes that the PV
3224 will expand when converted to UTF-8, and skips the extra work of checking for
3225 that. Typically this flag is used by a routine that has already parsed the
3226 string and found such characters, and passes this information on so that the
3227 work doesn't have to be repeated.
3229 Returns the number of bytes in the converted string.
3231 This is not a general purpose byte encoding to Unicode interface:
3232 use the Encode extension for that.
3234 =for apidoc sv_utf8_upgrade_flags_grow
3236 Like sv_utf8_upgrade_flags, but has an additional parameter C<extra>, which is
3237 the number of unused bytes the string of 'sv' is guaranteed to have free after
3238 it upon return. This allows the caller to reserve extra space that it intends
3239 to fill, to avoid extra grows.
3241 C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags>
3242 are implemented in terms of this function.
3244 Returns the number of bytes in the converted string (not including the spares).
3248 (One might think that the calling routine could pass in the position of the
3249 first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't
3250 have to be found again. But that is not the case, because typically when the
3251 caller is likely to use this flag, it won't be calling this routine unless it
3252 finds something that won't fit into a byte. Otherwise it tries to not upgrade
3253 and just use bytes. But some things that do fit into a byte are variants in
3254 utf8, and the caller may not have been keeping track of these.)
3256 If the routine itself changes the string, it adds a trailing NUL. Such a NUL
3257 isn't guaranteed due to having other routines do the work in some input cases,
3258 or if the input is already flagged as being in utf8.
3260 The speed of this could perhaps be improved for many cases if someone wanted to
3261 write a fast function that counts the number of variant characters in a string,
3262 especially if it could return the position of the first one.
3267 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3271 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3273 if (sv == &PL_sv_undef)
3275 if (!SvPOK_nog(sv)) {
3277 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3278 (void) sv_2pv_flags(sv,&len, flags);
3280 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3284 (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3289 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3294 S_sv_uncow(aTHX_ sv, 0);
3297 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3298 sv_recode_to_utf8(sv, PL_encoding);
3299 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3303 if (SvCUR(sv) == 0) {
3304 if (extra) SvGROW(sv, extra);
3305 } else { /* Assume Latin-1/EBCDIC */
3306 /* This function could be much more efficient if we
3307 * had a FLAG in SVs to signal if there are any variant
3308 * chars in the PV. Given that there isn't such a flag
3309 * make the loop as fast as possible (although there are certainly ways
3310 * to speed this up, eg. through vectorization) */
3311 U8 * s = (U8 *) SvPVX_const(sv);
3312 U8 * e = (U8 *) SvEND(sv);
3314 STRLEN two_byte_count = 0;
3316 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3318 /* See if really will need to convert to utf8. We mustn't rely on our
3319 * incoming SV being well formed and having a trailing '\0', as certain
3320 * code in pp_formline can send us partially built SVs. */
3324 if (NATIVE_BYTE_IS_INVARIANT(ch)) continue;
3326 t--; /* t already incremented; re-point to first variant */
3331 /* utf8 conversion not needed because all are invariants. Mark as
3332 * UTF-8 even if no variant - saves scanning loop */
3334 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3339 /* Here, the string should be converted to utf8, either because of an
3340 * input flag (two_byte_count = 0), or because a character that
3341 * requires 2 bytes was found (two_byte_count = 1). t points either to
3342 * the beginning of the string (if we didn't examine anything), or to
3343 * the first variant. In either case, everything from s to t - 1 will
3344 * occupy only 1 byte each on output.
3346 * There are two main ways to convert. One is to create a new string
3347 * and go through the input starting from the beginning, appending each
3348 * converted value onto the new string as we go along. It's probably
3349 * best to allocate enough space in the string for the worst possible
3350 * case rather than possibly running out of space and having to
3351 * reallocate and then copy what we've done so far. Since everything
3352 * from s to t - 1 is invariant, the destination can be initialized
3353 * with these using a fast memory copy
3355 * The other way is to figure out exactly how big the string should be
3356 * by parsing the entire input. Then you don't have to make it big
3357 * enough to handle the worst possible case, and more importantly, if
3358 * the string you already have is large enough, you don't have to
3359 * allocate a new string, you can copy the last character in the input
3360 * string to the final position(s) that will be occupied by the
3361 * converted string and go backwards, stopping at t, since everything
3362 * before that is invariant.
3364 * There are advantages and disadvantages to each method.
3366 * In the first method, we can allocate a new string, do the memory
3367 * copy from the s to t - 1, and then proceed through the rest of the
3368 * string byte-by-byte.
3370 * In the second method, we proceed through the rest of the input
3371 * string just calculating how big the converted string will be. Then
3372 * there are two cases:
3373 * 1) if the string has enough extra space to handle the converted
3374 * value. We go backwards through the string, converting until we
3375 * get to the position we are at now, and then stop. If this
3376 * position is far enough along in the string, this method is
3377 * faster than the other method. If the memory copy were the same
3378 * speed as the byte-by-byte loop, that position would be about
3379 * half-way, as at the half-way mark, parsing to the end and back
3380 * is one complete string's parse, the same amount as starting
3381 * over and going all the way through. Actually, it would be
3382 * somewhat less than half-way, as it's faster to just count bytes
3383 * than to also copy, and we don't have the overhead of allocating
3384 * a new string, changing the scalar to use it, and freeing the
3385 * existing one. But if the memory copy is fast, the break-even
3386 * point is somewhere after half way. The counting loop could be
3387 * sped up by vectorization, etc, to move the break-even point
3388 * further towards the beginning.
3389 * 2) if the string doesn't have enough space to handle the converted
3390 * value. A new string will have to be allocated, and one might
3391 * as well, given that, start from the beginning doing the first
3392 * method. We've spent extra time parsing the string and in
3393 * exchange all we've gotten is that we know precisely how big to
3394 * make the new one. Perl is more optimized for time than space,
3395 * so this case is a loser.
3396 * So what I've decided to do is not use the 2nd method unless it is
3397 * guaranteed that a new string won't have to be allocated, assuming
3398 * the worst case. I also decided not to put any more conditions on it
3399 * than this, for now. It seems likely that, since the worst case is
3400 * twice as big as the unknown portion of the string (plus 1), we won't
3401 * be guaranteed enough space, causing us to go to the first method,
3402 * unless the string is short, or the first variant character is near
3403 * the end of it. In either of these cases, it seems best to use the
3404 * 2nd method. The only circumstance I can think of where this would
3405 * be really slower is if the string had once had much more data in it
3406 * than it does now, but there is still a substantial amount in it */
3409 STRLEN invariant_head = t - s;
3410 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3411 if (SvLEN(sv) < size) {
3413 /* Here, have decided to allocate a new string */
3418 Newx(dst, size, U8);
3420 /* If no known invariants at the beginning of the input string,
3421 * set so starts from there. Otherwise, can use memory copy to
3422 * get up to where we are now, and then start from here */
3424 if (invariant_head <= 0) {
3427 Copy(s, dst, invariant_head, char);
3428 d = dst + invariant_head;
3432 append_utf8_from_native_byte(*t, &d);
3436 SvPV_free(sv); /* No longer using pre-existing string */
3437 SvPV_set(sv, (char*)dst);
3438 SvCUR_set(sv, d - dst);
3439 SvLEN_set(sv, size);
3442 /* Here, have decided to get the exact size of the string.
3443 * Currently this happens only when we know that there is
3444 * guaranteed enough space to fit the converted string, so
3445 * don't have to worry about growing. If two_byte_count is 0,
3446 * then t points to the first byte of the string which hasn't
3447 * been examined yet. Otherwise two_byte_count is 1, and t
3448 * points to the first byte in the string that will expand to
3449 * two. Depending on this, start examining at t or 1 after t.
3452 U8 *d = t + two_byte_count;
3455 /* Count up the remaining bytes that expand to two */
3458 const U8 chr = *d++;
3459 if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++;
3462 /* The string will expand by just the number of bytes that
3463 * occupy two positions. But we are one afterwards because of
3464 * the increment just above. This is the place to put the
3465 * trailing NUL, and to set the length before we decrement */
3467 d += two_byte_count;
3468 SvCUR_set(sv, d - s);
3472 /* Having decremented d, it points to the position to put the
3473 * very last byte of the expanded string. Go backwards through
3474 * the string, copying and expanding as we go, stopping when we
3475 * get to the part that is invariant the rest of the way down */
3479 if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3482 *d-- = UTF8_EIGHT_BIT_LO(*e);
3483 *d-- = UTF8_EIGHT_BIT_HI(*e);
3489 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3490 /* Update pos. We do it at the end rather than during
3491 * the upgrade, to avoid slowing down the common case
3492 * (upgrade without pos).
3493 * pos can be stored as either bytes or characters. Since
3494 * this was previously a byte string we can just turn off
3495 * the bytes flag. */
3496 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3498 mg->mg_flags &= ~MGf_BYTES;
3500 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3501 magic_setutf8(sv,mg); /* clear UTF8 cache */
3506 /* Mark as UTF-8 even if no variant - saves scanning loop */
3512 =for apidoc sv_utf8_downgrade
3514 Attempts to convert the PV of an SV from characters to bytes.
3515 If the PV contains a character that cannot fit
3516 in a byte, this conversion will fail;
3517 in this case, either returns false or, if C<fail_ok> is not
3520 This is not a general purpose Unicode to byte encoding interface:
3521 use the Encode extension for that.
3527 Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
3531 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3533 if (SvPOKp(sv) && SvUTF8(sv)) {
3537 int mg_flags = SV_GMAGIC;
3540 S_sv_uncow(aTHX_ sv, 0);
3542 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3544 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3545 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
3546 mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3547 SV_GMAGIC|SV_CONST_RETURN);
3548 mg_flags = 0; /* sv_pos_b2u does get magic */
3550 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3551 magic_setutf8(sv,mg); /* clear UTF8 cache */
3554 s = (U8 *) SvPV_flags(sv, len, mg_flags);
3556 if (!utf8_to_bytes(s, &len)) {
3561 Perl_croak(aTHX_ "Wide character in %s",
3564 Perl_croak(aTHX_ "Wide character");
3575 =for apidoc sv_utf8_encode
3577 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3578 flag off so that it looks like octets again.
3584 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3586 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3588 if (SvREADONLY(sv)) {
3589 sv_force_normal_flags(sv, 0);
3591 (void) sv_utf8_upgrade(sv);
3596 =for apidoc sv_utf8_decode
3598 If the PV of the SV is an octet sequence in UTF-8
3599 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3600 so that it looks like a character. If the PV contains only single-byte
3601 characters, the C<SvUTF8> flag stays off.
3602 Scans PV for validity and returns false if the PV is invalid UTF-8.
3608 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3610 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3613 const U8 *start, *c;
3616 /* The octets may have got themselves encoded - get them back as
3619 if (!sv_utf8_downgrade(sv, TRUE))
3622 /* it is actually just a matter of turning the utf8 flag on, but
3623 * we want to make sure everything inside is valid utf8 first.
3625 c = start = (const U8 *) SvPVX_const(sv);
3626 if (!is_utf8_string(c, SvCUR(sv)))
3628 e = (const U8 *) SvEND(sv);
3631 if (!UTF8_IS_INVARIANT(ch)) {
3636 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3637 /* XXX Is this dead code? XS_utf8_decode calls SvSETMAGIC
3638 after this, clearing pos. Does anything on CPAN
3640 /* adjust pos to the start of a UTF8 char sequence */
3641 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3643 I32 pos = mg->mg_len;
3645 for (c = start + pos; c > start; c--) {
3646 if (UTF8_IS_START(*c))
3649 mg->mg_len = c - start;
3652 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3653 magic_setutf8(sv,mg); /* clear UTF8 cache */
3660 =for apidoc sv_setsv
3662 Copies the contents of the source SV C<ssv> into the destination SV
3663 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3664 function if the source SV needs to be reused. Does not handle 'set' magic on
3665 destination SV. Calls 'get' magic on source SV. Loosely speaking, it
3666 performs a copy-by-value, obliterating any previous content of the
3669 You probably want to use one of the assortment of wrappers, such as
3670 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3671 C<SvSetMagicSV_nosteal>.
3673 =for apidoc sv_setsv_flags
3675 Copies the contents of the source SV C<ssv> into the destination SV
3676 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3677 function if the source SV needs to be reused. Does not handle 'set' magic.
3678 Loosely speaking, it performs a copy-by-value, obliterating any previous
3679 content of the destination.
3680 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3681 C<ssv> if appropriate, else not. If the C<flags>
3682 parameter has the C<SV_NOSTEAL> bit set then the
3683 buffers of temps will not be stolen. <sv_setsv>
3684 and C<sv_setsv_nomg> are implemented in terms of this function.
3686 You probably want to use one of the assortment of wrappers, such as
3687 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3688 C<SvSetMagicSV_nosteal>.
3690 This is the primary function for copying scalars, and most other
3691 copy-ish functions and macros use this underneath.
3697 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3699 I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3700 HV *old_stash = NULL;
3702 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3704 if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3705 const char * const name = GvNAME(sstr);
3706 const STRLEN len = GvNAMELEN(sstr);
3708 if (dtype >= SVt_PV) {
3714 SvUPGRADE(dstr, SVt_PVGV);
3715 (void)SvOK_off(dstr);
3716 /* We have to turn this on here, even though we turn it off
3717 below, as GvSTASH will fail an assertion otherwise. */
3718 isGV_with_GP_on(dstr);
3720 GvSTASH(dstr) = GvSTASH(sstr);
3722 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3723 gv_name_set(MUTABLE_GV(dstr), name, len,
3724 GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
3725 SvFAKE_on(dstr); /* can coerce to non-glob */
3728 if(GvGP(MUTABLE_GV(sstr))) {
3729 /* If source has method cache entry, clear it */
3731 SvREFCNT_dec(GvCV(sstr));
3732 GvCV_set(sstr, NULL);
3735 /* If source has a real method, then a method is
3738 GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3744 /* If dest already had a real method, that's a change as well */
3746 !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3747 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3752 /* We don't need to check the name of the destination if it was not a
3753 glob to begin with. */
3754 if(dtype == SVt_PVGV) {
3755 const char * const name = GvNAME((const GV *)dstr);
3758 /* The stash may have been detached from the symbol table, so
3760 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3764 const STRLEN len = GvNAMELEN(dstr);
3765 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3766 || (len == 1 && name[0] == ':')) {
3769 /* Set aside the old stash, so we can reset isa caches on
3771 if((old_stash = GvHV(dstr)))
3772 /* Make sure we do not lose it early. */
3773 SvREFCNT_inc_simple_void_NN(
3774 sv_2mortal((SV *)old_stash)
3780 gp_free(MUTABLE_GV(dstr));
3781 isGV_with_GP_off(dstr); /* SvOK_off does not like globs. */
3782 (void)SvOK_off(dstr);
3783 isGV_with_GP_on(dstr);
3784 GvINTRO_off(dstr); /* one-shot flag */
3785 GvGP_set(dstr, gp_ref(GvGP(sstr)));
3786 if (SvTAINTED(sstr))
3788 if (GvIMPORTED(dstr) != GVf_IMPORTED
3789 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3791 GvIMPORTED_on(dstr);
3794 if(mro_changes == 2) {
3795 if (GvAV((const GV *)sstr)) {
3797 SV * const sref = (SV *)GvAV((const GV *)dstr);
3798 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3799 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3800 AV * const ary = newAV();
3801 av_push(ary, mg->mg_obj); /* takes the refcount */
3802 mg->mg_obj = (SV *)ary;
3804 av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3806 else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3808 mro_isa_changed_in(GvSTASH(dstr));
3810 else if(mro_changes == 3) {
3811 HV * const stash = GvHV(dstr);
3812 if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3818 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3819 if (GvIO(dstr) && dtype == SVt_PVGV) {
3820 DEBUG_o(Perl_deb(aTHX_
3821 "glob_assign_glob clearing PL_stashcache\n"));
3822 /* It's a cache. It will rebuild itself quite happily.
3823 It's a lot of effort to work out exactly which key (or keys)
3824 might be invalidated by the creation of the this file handle.
3826 hv_clear(PL_stashcache);
3832 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3834 SV * const sref = SvRV(sstr);
3836 const int intro = GvINTRO(dstr);
3839 const U32 stype = SvTYPE(sref);
3841 PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3844 GvINTRO_off(dstr); /* one-shot flag */
3845 GvLINE(dstr) = CopLINE(PL_curcop);
3846 GvEGV(dstr) = MUTABLE_GV(dstr);
3851 location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
3852 import_flag = GVf_IMPORTED_CV;
3855 location = (SV **) &GvHV(dstr);
3856 import_flag = GVf_IMPORTED_HV;
3859 location = (SV **) &GvAV(dstr);
3860 import_flag = GVf_IMPORTED_AV;
3863 location = (SV **) &GvIOp(dstr);
3866 location = (SV **) &GvFORM(dstr);
3869 location = &GvSV(dstr);
3870 import_flag = GVf_IMPORTED_SV;
3873 if (stype == SVt_PVCV) {
3874 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3875 if (GvCVGEN(dstr)) {
3876 SvREFCNT_dec(GvCV(dstr));
3877 GvCV_set(dstr, NULL);
3878 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3881 /* SAVEt_GVSLOT takes more room on the savestack and has more
3882 overhead in leave_scope than SAVEt_GENERIC_SV. But for CVs
3883 leave_scope needs access to the GV so it can reset method
3884 caches. We must use SAVEt_GVSLOT whenever the type is
3885 SVt_PVCV, even if the stash is anonymous, as the stash may
3886 gain a name somehow before leave_scope. */
3887 if (stype == SVt_PVCV) {
3888 /* There is no save_pushptrptrptr. Creating it for this
3889 one call site would be overkill. So inline the ss add
3893 SS_ADD_PTR(location);
3894 SS_ADD_PTR(SvREFCNT_inc(*location));
3895 SS_ADD_UV(SAVEt_GVSLOT);
3898 else SAVEGENERICSV(*location);
3901 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3902 CV* const cv = MUTABLE_CV(*location);
3904 if (!GvCVGEN((const GV *)dstr) &&
3905 (CvROOT(cv) || CvXSUB(cv)) &&
3906 /* redundant check that avoids creating the extra SV
3907 most of the time: */
3908 (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
3910 SV * const new_const_sv =
3911 CvCONST((const CV *)sref)
3912 ? cv_const_sv((const CV *)sref)
3914 report_redefined_cv(
3915 sv_2mortal(Perl_newSVpvf(aTHX_
3918 HvNAME_HEK(GvSTASH((const GV *)dstr))
3920 HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
3923 CvCONST((const CV *)sref) ? &new_const_sv : NULL
3927 cv_ckproto_len_flags(cv, (const GV *)dstr,
3928 SvPOK(sref) ? CvPROTO(sref) : NULL,
3929 SvPOK(sref) ? CvPROTOLEN(sref) : 0,
3930 SvPOK(sref) ? SvUTF8(sref) : 0);
3932 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3933 GvASSUMECV_on(dstr);
3934 if(GvSTASH(dstr)) gv_method_changed(dstr); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3936 *location = SvREFCNT_inc_simple_NN(sref);
3937 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3938 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3939 GvFLAGS(dstr) |= import_flag;
3941 if (stype == SVt_PVHV) {
3942 const char * const name = GvNAME((GV*)dstr);
3943 const STRLEN len = GvNAMELEN(dstr);
3946 (len > 1 && name[len-2] == ':' && name[len-1] == ':')
3947 || (len == 1 && name[0] == ':')
3949 && (!dref || HvENAME_get(dref))
3952 (HV *)sref, (HV *)dref,
3958 stype == SVt_PVAV && sref != dref
3959 && strEQ(GvNAME((GV*)dstr), "ISA")
3960 /* The stash may have been detached from the symbol table, so
3961 check its name before doing anything. */
3962 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3965 MAGIC * const omg = dref && SvSMAGICAL(dref)
3966 ? mg_find(dref, PERL_MAGIC_isa)
3968 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3969 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3970 AV * const ary = newAV();
3971 av_push(ary, mg->mg_obj); /* takes the refcount */
3972 mg->mg_obj = (SV *)ary;
3975 if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
3976 SV **svp = AvARRAY((AV *)omg->mg_obj);
3977 I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
3981 SvREFCNT_inc_simple_NN(*svp++)
3987 SvREFCNT_inc_simple_NN(omg->mg_obj)
3991 av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
3996 sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
3998 mg = mg_find(sref, PERL_MAGIC_isa);
4000 /* Since the *ISA assignment could have affected more than
4001 one stash, don't call mro_isa_changed_in directly, but let
4002 magic_clearisa do it for us, as it already has the logic for
4003 dealing with globs vs arrays of globs. */
4005 Perl_magic_clearisa(aTHX_ NULL, mg);
4007 else if (stype == SVt_PVIO) {
4008 DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing PL_stashcache\n"));
4009 /* It's a cache. It will rebuild itself quite happily.
4010 It's a lot of effort to work out exactly which key (or keys)
4011 might be invalidated by the creation of the this file handle.
4013 hv_clear(PL_stashcache);
4017 if (!intro) SvREFCNT_dec(dref);
4018 if (SvTAINTED(sstr))
4023 /* Work around compiler warnings about unsigned >= THRESHOLD when thres-
4025 #if SV_COW_THRESHOLD
4026 # define GE_COW_THRESHOLD(len) ((len) >= SV_COW_THRESHOLD)
4028 # define GE_COW_THRESHOLD(len) 1
4030 #if SV_COWBUF_THRESHOLD
4031 # define GE_COWBUF_THRESHOLD(len) ((len) >= SV_COWBUF_THRESHOLD)
4033 # define GE_COWBUF_THRESHOLD(len) 1
4036 #ifdef PERL_DEBUG_READONLY_COW
4037 # include <sys/mman.h>
4044 Perl_sv_buf_to_ro(pTHX_ SV *sv)
4046 struct perl_memory_debug_header * const header =
4047 (struct perl_memory_debug_header *)(SvPVX(sv)-sTHX);
4048 const MEM_SIZE len = header->size;
4049 PERL_ARGS_ASSERT_SV_BUF_TO_RO;
4050 # ifdef PERL_TRACK_MEMPOOL
4051 if (!header->readonly) header->readonly = 1;
4053 if (mprotect(header, len, PROT_READ))
4054 Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
4055 header, len, errno);
4059 S_sv_buf_to_rw(pTHX_ SV *sv)
4061 struct perl_memory_debug_header * const header =
4062 (struct perl_memory_debug_header *)(SvPVX(sv)-sTHX);
4063 const MEM_SIZE len = header->size;
4064 PERL_ARGS_ASSERT_SV_BUF_TO_RW;
4065 if (mprotect(header, len, PROT_READ|PROT_WRITE))
4066 Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
4067 header, len, errno);
4068 # ifdef PERL_TRACK_MEMPOOL
4069 header->readonly = 0;
4074 # define sv_buf_to_ro(sv) NOOP
4075 # define sv_buf_to_rw(sv) NOOP
4079 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
4086 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4091 if (SvIS_FREED(dstr)) {
4092 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4093 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
4095 SV_CHECK_THINKFIRST_COW_DROP(dstr);
4097 sstr = &PL_sv_undef;
4098 if (SvIS_FREED(sstr)) {
4099 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4100 (void*)sstr, (void*)dstr);
4102 stype = SvTYPE(sstr);
4103 dtype = SvTYPE(dstr);
4105 /* There's a lot of redundancy below but we're going for speed here */
4110 if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
4111 (void)SvOK_off(dstr);
4119 sv_upgrade(dstr, SVt_IV);
4123 sv_upgrade(dstr, SVt_PVIV);
4127 goto end_of_first_switch;
4129 (void)SvIOK_only(dstr);
4130 SvIV_set(dstr, SvIVX(sstr));
4133 /* SvTAINTED can only be true if the SV has taint magic, which in
4134 turn means that the SV type is PVMG (or greater). This is the
4135 case statement for SVt_IV, so this cannot be true (whatever gcov
4137 assert(!SvTAINTED(sstr));
4142 if (dtype < SVt_PV && dtype != SVt_IV)
4143 sv_upgrade(dstr, SVt_IV);
4151 sv_upgrade(dstr, SVt_NV);
4155 sv_upgrade(dstr, SVt_PVNV);
4159 goto end_of_first_switch;
4161 SvNV_set(dstr, SvNVX(sstr));
4162 (void)SvNOK_only(dstr);
4163 /* SvTAINTED can only be true if the SV has taint magic, which in
4164 turn means that the SV type is PVMG (or greater). This is the
4165 case statement for SVt_NV, so this cannot be true (whatever gcov
4167 assert(!SvTAINTED(sstr));
4174 sv_upgrade(dstr, SVt_PV);
4177 if (dtype < SVt_PVIV)
4178 sv_upgrade(dstr, SVt_PVIV);
4181 if (dtype < SVt_PVNV)
4182 sv_upgrade(dstr, SVt_PVNV);
4186 const char * const type = sv_reftype(sstr,0);
4188 /* diag_listed_as: Bizarre copy of %s */
4189 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4191 Perl_croak(aTHX_ "Bizarre copy of %s", type);
4197 if (dtype < SVt_REGEXP)
4199 if (dtype >= SVt_PV) {
4205 sv_upgrade(dstr, SVt_REGEXP);
4213 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4215 if (SvTYPE(sstr) != stype)
4216 stype = SvTYPE(sstr);
4218 if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4219 glob_assign_glob(dstr, sstr, dtype);
4222 if (stype == SVt_PVLV)
4224 if (isREGEXP(sstr)) goto upgregexp;
4225 SvUPGRADE(dstr, SVt_PVNV);
4228 SvUPGRADE(dstr, (svtype)stype);
4230 end_of_first_switch:
4232 /* dstr may have been upgraded. */
4233 dtype = SvTYPE(dstr);
4234 sflags = SvFLAGS(sstr);
4236 if (dtype == SVt_PVCV) {
4237 /* Assigning to a subroutine sets the prototype. */
4240 const char *const ptr = SvPV_const(sstr, len);
4242 SvGROW(dstr, len + 1);
4243 Copy(ptr, SvPVX(dstr), len + 1, char);
4244 SvCUR_set(dstr, len);
4246 SvFLAGS(dstr) |= sflags & SVf_UTF8;
4247 CvAUTOLOAD_off(dstr);
4252 else if (dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM) {
4253 const char * const type = sv_reftype(dstr,0);
4255 /* diag_listed_as: Cannot copy to %s */
4256 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4258 Perl_croak(aTHX_ "Cannot copy to %s", type);
4259 } else if (sflags & SVf_ROK) {
4260 if (isGV_with_GP(dstr)
4261 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4264 if (GvIMPORTED(dstr) != GVf_IMPORTED
4265 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4267 GvIMPORTED_on(dstr);
4272 glob_assign_glob(dstr, sstr, dtype);
4276 if (dtype >= SVt_PV) {
4277 if (isGV_with_GP(dstr)) {
4278 glob_assign_ref(dstr, sstr);
4281 if (SvPVX_const(dstr)) {
4287 (void)SvOK_off(dstr);
4288 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4289 SvFLAGS(dstr) |= sflags & SVf_ROK;
4290 assert(!(sflags & SVp_NOK));
4291 assert(!(sflags & SVp_IOK));
4292 assert(!(sflags & SVf_NOK));
4293 assert(!(sflags & SVf_IOK));
4295 else if (isGV_with_GP(dstr)) {
4296 if (!(sflags & SVf_OK)) {
4297 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4298 "Undefined value assigned to typeglob");
4301 GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
4302 if (dstr != (const SV *)gv) {
4303 const char * const name = GvNAME((const GV *)dstr);
4304 const STRLEN len = GvNAMELEN(dstr);
4305 HV *old_stash = NULL;
4306 bool reset_isa = FALSE;
4307 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4308 || (len == 1 && name[0] == ':')) {
4309 /* Set aside the old stash, so we can reset isa caches
4310 on its subclasses. */
4311 if((old_stash = GvHV(dstr))) {
4312 /* Make sure we do not lose it early. */
4313 SvREFCNT_inc_simple_void_NN(
4314 sv_2mortal((SV *)old_stash)
4321 gp_free(MUTABLE_GV(dstr));
4322 GvGP_set(dstr, gp_ref(GvGP(gv)));
4325 HV * const stash = GvHV(dstr);
4327 old_stash ? (HV *)HvENAME_get(old_stash) : stash
4337 else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4338 && (stype == SVt_REGEXP || isREGEXP(sstr))) {
4339 reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4341 else if (sflags & SVp_POK) {
4342 const STRLEN cur = SvCUR(sstr);
4343 const STRLEN len = SvLEN(sstr);
4346 * We have three basic ways to copy the string:
4352 * Which we choose is based on various factors. The following
4353 * things are listed in order of speed, fastest to slowest:
4355 * - Copying a short string
4356 * - Copy-on-write bookkeeping
4358 * - Copying a long string
4360 * We swipe the string (steal the string buffer) if the SV on the
4361 * rhs is about to be freed anyway (TEMP and refcnt==1). This is a
4362 * big win on long strings. It should be a win on short strings if
4363 * SvPVX_const(dstr) has to be allocated. If not, it should not
4364 * slow things down, as SvPVX_const(sstr) would have been freed
4367 * We also steal the buffer from a PADTMP (operator target) if it
4368 * is ‘long enough’. For short strings, a swipe does not help
4369 * here, as it causes more malloc calls the next time the target
4370 * is used. Benchmarks show that even if SvPVX_const(dstr) has to
4371 * be allocated it is still not worth swiping PADTMPs for short
4372 * strings, as the savings here are small.
4374 * If the rhs is already flagged as a copy-on-write string and COW
4375 * is possible here, we use copy-on-write and make both SVs share
4376 * the string buffer.
4378 * If the rhs is not flagged as copy-on-write, then we see whether
4379 * it is worth upgrading it to such. If the lhs already has a buf-
4380 * fer big enough and the string is short, we skip it and fall back
4381 * to method 3, since memcpy is faster for short strings than the
4382 * later bookkeeping overhead that copy-on-write entails.
4384 * If there is no buffer on the left, or the buffer is too small,
4385 * then we use copy-on-write.
4388 /* Whichever path we take through the next code, we want this true,
4389 and doing it now facilitates the COW check. */
4390 (void)SvPOK_only(dstr);
4394 /* slated for free anyway (and not COW)? */
4395 (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
4396 /* or a swipable TARG */
4397 || ((sflags & (SVs_PADTMP|SVf_READONLY|SVf_IsCOW))
4399 /* whose buffer is worth stealing */
4400 && GE_COWBUF_THRESHOLD(cur)
4403 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4404 (!(flags & SV_NOSTEAL)) &&
4405 /* and we're allowed to steal temps */
4406 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4407 len) /* and really is a string */
4408 { /* Passes the swipe test. */
4409 if (SvPVX_const(dstr)) /* we know that dtype >= SVt_PV */
4411 SvPV_set(dstr, SvPVX_mutable(sstr));
4412 SvLEN_set(dstr, SvLEN(sstr));
4413 SvCUR_set(dstr, SvCUR(sstr));
4416 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4417 SvPV_set(sstr, NULL);
4422 else if (flags & SV_COW_SHARED_HASH_KEYS
4424 #ifdef PERL_OLD_COPY_ON_WRITE
4425 ( sflags & SVf_IsCOW
4426 || ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4427 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4428 && SvTYPE(sstr) >= SVt_PVIV && len
4431 #elif defined(PERL_NEW_COPY_ON_WRITE)
4434 ( (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1)
4435 /* If this is a regular (non-hek) COW, only so
4436 many COW "copies" are possible. */
4437 && CowREFCNT(sstr) != SV_COW_REFCNT_MAX ))
4438 : ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4439 && !(SvFLAGS(dstr) & SVf_BREAK)
4440 && GE_COW_THRESHOLD(cur) && cur+1 < len
4441 && (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1)
4445 && !(SvFLAGS(dstr) & SVf_BREAK)
4448 /* Either it's a shared hash key, or it's suitable for
4451 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4456 if (!(sflags & SVf_IsCOW)) {
4458 # ifdef PERL_OLD_COPY_ON_WRITE
4459 /* Make the source SV into a loop of 1.
4460 (about to become 2) */
4461 SV_COW_NEXT_SV_SET(sstr, sstr);
4463 CowREFCNT(sstr) = 0;
4467 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4473 # ifdef PERL_OLD_COPY_ON_WRITE
4474 assert (SvTYPE(dstr) >= SVt_PVIV);
4475 /* SvIsCOW_normal */
4476 /* splice us in between source and next-after-source. */
4477 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4478 SV_COW_NEXT_SV_SET(sstr, dstr);
4480 if (sflags & SVf_IsCOW) {
4485 SvPV_set(dstr, SvPVX_mutable(sstr));
4490 /* SvIsCOW_shared_hash */
4491 DEBUG_C(PerlIO_printf(Perl_debug_log,
4492 "Copy on write: Sharing hash\n"));
4494 assert (SvTYPE(dstr) >= SVt_PV);
4496 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4498 SvLEN_set(dstr, len);
4499 SvCUR_set(dstr, cur);
4502 /* Failed the swipe test, and we cannot do copy-on-write either.
4503 Have to copy the string. */
4504 SvGROW(dstr, cur + 1); /* inlined from sv_setpvn */
4505 Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
4506 SvCUR_set(dstr, cur);
4507 *SvEND(dstr) = '\0';
4509 if (sflags & SVp_NOK) {
4510 SvNV_set(dstr, SvNVX(sstr));
4512 if (sflags & SVp_IOK) {
4513 SvIV_set(dstr, SvIVX(sstr));
4514 /* Must do this otherwise some other overloaded use of 0x80000000
4515 gets confused. I guess SVpbm_VALID */
4516 if (sflags & SVf_IVisUV)
4519 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4521 const MAGIC * const smg = SvVSTRING_mg(sstr);
4523 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4524 smg->mg_ptr, smg->mg_len);
4525 SvRMAGICAL_on(dstr);
4529 else if (sflags & (SVp_IOK|SVp_NOK)) {
4530 (void)SvOK_off(dstr);
4531 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4532 if (sflags & SVp_IOK) {
4533 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4534 SvIV_set(dstr, SvIVX(sstr));
4536 if (sflags & SVp_NOK) {
4537 SvNV_set(dstr, SvNVX(sstr));
4541 if (isGV_with_GP(sstr)) {
4542 gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4545 (void)SvOK_off(dstr);
4547 if (SvTAINTED(sstr))
4552 =for apidoc sv_setsv_mg
4554 Like C<sv_setsv>, but also handles 'set' magic.
4560 Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
4562 PERL_ARGS_ASSERT_SV_SETSV_MG;
4564 sv_setsv(dstr,sstr);
4569 # ifdef PERL_OLD_COPY_ON_WRITE
4570 # define SVt_COW SVt_PVIV
4572 # define SVt_COW SVt_PV
4575 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4577 STRLEN cur = SvCUR(sstr);
4578 STRLEN len = SvLEN(sstr);
4580 #if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_NEW_COPY_ON_WRITE)
4581 const bool already = cBOOL(SvIsCOW(sstr));
4584 PERL_ARGS_ASSERT_SV_SETSV_COW;
4587 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4588 (void*)sstr, (void*)dstr);
4595 if (SvTHINKFIRST(dstr))
4596 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4597 else if (SvPVX_const(dstr))
4598 Safefree(SvPVX_mutable(dstr));
4602 SvUPGRADE(dstr, SVt_COW);
4604 assert (SvPOK(sstr));
4605 assert (SvPOKp(sstr));
4606 # ifdef PERL_OLD_COPY_ON_WRITE
4607 assert (!SvIOK(sstr));
4608 assert (!SvIOKp(sstr));
4609 assert (!SvNOK(sstr));
4610 assert (!SvNOKp(sstr));
4613 if (SvIsCOW(sstr)) {
4615 if (SvLEN(sstr) == 0) {
4616 /* source is a COW shared hash key. */
4617 DEBUG_C(PerlIO_printf(Perl_debug_log,
4618 "Fast copy on write: Sharing hash\n"));
4619 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4622 # ifdef PERL_OLD_COPY_ON_WRITE
4623 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4625 assert(SvCUR(sstr)+1 < SvLEN(sstr));
4626 assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
4629 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4630 SvUPGRADE(sstr, SVt_COW);
4632 DEBUG_C(PerlIO_printf(Perl_debug_log,
4633 "Fast copy on write: Converting sstr to COW\n"));
4634 # ifdef PERL_OLD_COPY_ON_WRITE
4635 SV_COW_NEXT_SV_SET(dstr, sstr);
4637 CowREFCNT(sstr) = 0;
4640 # ifdef PERL_OLD_COPY_ON_WRITE
4641 SV_COW_NEXT_SV_SET(sstr, dstr);
4643 # ifdef PERL_DEBUG_READONLY_COW
4644 if (already) sv_buf_to_rw(sstr);
4648 new_pv = SvPVX_mutable(sstr);
4652 SvPV_set(dstr, new_pv);
4653 SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
4656 SvLEN_set(dstr, len);
4657 SvCUR_set(dstr, cur);
4666 =for apidoc sv_setpvn
4668 Copies a string into an SV. The C<len> parameter indicates the number of
4669 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4670 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4676 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4681 PERL_ARGS_ASSERT_SV_SETPVN;
4683 SV_CHECK_THINKFIRST_COW_DROP(sv);
4689 /* len is STRLEN which is unsigned, need to copy to signed */
4692 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
4695 SvUPGRADE(sv, SVt_PV);
4697 dptr = SvGROW(sv, len + 1);
4698 Move(ptr,dptr,len,char);
4701 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4703 if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4707 =for apidoc sv_setpvn_mg
4709 Like C<sv_setpvn>, but also handles 'set' magic.
4715 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4717 PERL_ARGS_ASSERT_SV_SETPVN_MG;
4719 sv_setpvn(sv,ptr,len);
4724 =for apidoc sv_setpv
4726 Copies a string into an SV. The string must be null-terminated. Does not
4727 handle 'set' magic. See C<sv_setpv_mg>.
4733 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
4738 PERL_ARGS_ASSERT_SV_SETPV;
4740 SV_CHECK_THINKFIRST_COW_DROP(sv);
4746 SvUPGRADE(sv, SVt_PV);
4748 SvGROW(sv, len + 1);
4749 Move(ptr,SvPVX(sv),len+1,char);
4751 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4753 if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4757 =for apidoc sv_setpv_mg
4759 Like C<sv_setpv>, but also handles 'set' magic.
4765 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
4767 PERL_ARGS_ASSERT_SV_SETPV_MG;
4774 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
4778 PERL_ARGS_ASSERT_SV_SETHEK;
4784 if (HEK_LEN(hek) == HEf_SVKEY) {
4785 sv_setsv(sv, *(SV**)HEK_KEY(hek));
4788 const int flags = HEK_FLAGS(hek);
4789 if (flags & HVhek_WASUTF8) {
4790 STRLEN utf8_len = HEK_LEN(hek);
4791 char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
4792 sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
4795 } else if (flags & HVhek_UNSHARED) {
4796 sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
4799 else SvUTF8_off(sv);
4803 SV_CHECK_THINKFIRST_COW_DROP(sv);
4804 SvUPGRADE(sv, SVt_PV);
4806 SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
4807 SvCUR_set(sv, HEK_LEN(hek));
4813 else SvUTF8_off(sv);
4821 =for apidoc sv_usepvn_flags
4823 Tells an SV to use C<ptr> to find its string value. Normally the
4824 string is stored inside the SV but sv_usepvn allows the SV to use an
4825 outside string. The C<ptr> should point to memory that was allocated
4826 by C<malloc>. It must be the start of a mallocked block
4827 of memory, and not a pointer to the middle of it. The
4828 string length, C<len>, must be supplied. By default
4829 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4830 so that pointer should not be freed or used by the programmer after
4831 giving it to sv_usepvn, and neither should any pointers from "behind"
4832 that pointer (e.g. ptr + 1) be used.
4834 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4835 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4836 will be skipped (i.e. the buffer is actually at least 1 byte longer than
4837 C<len>, and already meets the requirements for storing in C<SvPVX>).
4843 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4848 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4850 SV_CHECK_THINKFIRST_COW_DROP(sv);
4851 SvUPGRADE(sv, SVt_PV);
4854 if (flags & SV_SMAGIC)
4858 if (SvPVX_const(sv))
4862 if (flags & SV_HAS_TRAILING_NUL)
4863 assert(ptr[len] == '\0');
4866 allocate = (flags & SV_HAS_TRAILING_NUL)
4868 #ifdef Perl_safesysmalloc_size
4871 PERL_STRLEN_ROUNDUP(len + 1);
4873 if (flags & SV_HAS_TRAILING_NUL) {
4874 /* It's long enough - do nothing.
4875 Specifically Perl_newCONSTSUB is relying on this. */
4878 /* Force a move to shake out bugs in callers. */
4879 char *new_ptr = (char*)safemalloc(allocate);
4880 Copy(ptr, new_ptr, len, char);
4881 PoisonFree(ptr,len,char);
4885 ptr = (char*) saferealloc (ptr, allocate);
4888 #ifdef Perl_safesysmalloc_size
4889 SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4891 SvLEN_set(sv, allocate);
4895 if (!(flags & SV_HAS_TRAILING_NUL)) {
4898 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4900 if (flags & SV_SMAGIC)
4904 #ifdef PERL_OLD_COPY_ON_WRITE
4905 /* Need to do this *after* making the SV normal, as we need the buffer
4906 pointer to remain valid until after we've copied it. If we let go too early,
4907 another thread could invalidate it by unsharing last of the same hash key
4908 (which it can do by means other than releasing copy-on-write Svs)
4909 or by changing the other copy-on-write SVs in the loop. */
4911 S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
4913 PERL_ARGS_ASSERT_SV_RELEASE_COW;
4915 { /* this SV was SvIsCOW_normal(sv) */
4916 /* we need to find the SV pointing to us. */
4917 SV *current = SV_COW_NEXT_SV(after);
4919 if (current == sv) {
4920 /* The SV we point to points back to us (there were only two of us
4922 Hence other SV is no longer copy on write either. */
4924 sv_buf_to_rw(after);
4926 /* We need to follow the pointers around the loop. */
4928 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4931 /* don't loop forever if the structure is bust, and we have
4932 a pointer into a closed loop. */
4933 assert (current != after);
4934 assert (SvPVX_const(current) == pvx);
4936 /* Make the SV before us point to the SV after us. */
4937 SV_COW_NEXT_SV_SET(current, after);
4943 =for apidoc sv_force_normal_flags
4945 Undo various types of fakery on an SV, where fakery means
4946 "more than" a string: if the PV is a shared string, make
4947 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4948 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4949 we do the copy, and is also used locally; if this is a
4950 vstring, drop the vstring magic. If C<SV_COW_DROP_PV> is set
4951 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4952 SvPOK_off rather than making a copy. (Used where this
4953 scalar is about to be set to some other value.) In addition,
4954 the C<flags> parameter gets passed to C<sv_unref_flags()>
4955 when unreffing. C<sv_force_normal> calls this function
4956 with flags set to 0.
4958 This function is expected to be used to signal to perl that this SV is
4959 about to be written to, and any extra book-keeping needs to be taken care
4960 of. Hence, it croaks on read-only values.
4966 S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
4970 assert(SvIsCOW(sv));
4973 const char * const pvx = SvPVX_const(sv);
4974 const STRLEN len = SvLEN(sv);
4975 const STRLEN cur = SvCUR(sv);
4976 # ifdef PERL_OLD_COPY_ON_WRITE
4977 /* next COW sv in the loop. If len is 0 then this is a shared-hash
4978 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4979 we'll fail an assertion. */
4980 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4984 PerlIO_printf(Perl_debug_log,
4985 "Copy on write: Force normal %ld\n",
4990 # ifdef PERL_NEW_COPY_ON_WRITE
4991 if (len && CowREFCNT(sv) == 0)
4992 /* We own the buffer ourselves. */
4998 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4999 # ifdef PERL_NEW_COPY_ON_WRITE
5000 /* Must do this first, since the macro uses SvPVX. */
5009 if (flags & SV_COW_DROP_PV) {
5010 /* OK, so we don't need to copy our buffer. */
5013 SvGROW(sv, cur + 1);
5014 Move(pvx,SvPVX(sv),cur,char);
5019 # ifdef PERL_OLD_COPY_ON_WRITE
5020 sv_release_COW(sv, pvx, next);
5023 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5030 const char * const pvx = SvPVX_const(sv);
5031 const STRLEN len = SvCUR(sv);
5035 if (flags & SV_COW_DROP_PV) {
5036 /* OK, so we don't need to copy our buffer. */
5039 SvGROW(sv, len + 1);
5040 Move(pvx,SvPVX(sv),len,char);
5043 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5049 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
5051 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
5054 Perl_croak_no_modify();
5055 else if (SvIsCOW(sv))
5056 S_sv_uncow(aTHX_ sv, flags);
5058 sv_unref_flags(sv, flags);
5059 else if (SvFAKE(sv) && isGV_with_GP(sv))
5060 sv_unglob(sv, flags);
5061 else if (SvFAKE(sv) && isREGEXP(sv)) {
5062 /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
5063 to sv_unglob. We only need it here, so inline it. */
5064 const bool islv = SvTYPE(sv) == SVt_PVLV;
5065 const svtype new_type =
5066 islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
5067 SV *const temp = newSV_type(new_type);
5068 regexp *const temp_p = ReANY((REGEXP *)sv);
5070 if (new_type == SVt_PVMG) {
5071 SvMAGIC_set(temp, SvMAGIC(sv));
5072 SvMAGIC_set(sv, NULL);
5073 SvSTASH_set(temp, SvSTASH(sv));
5074 SvSTASH_set(sv, NULL);
5076 if (!islv) SvCUR_set(temp, SvCUR(sv));
5077 /* Remember that SvPVX is in the head, not the body. But
5078 RX_WRAPPED is in the body. */
5079 assert(ReANY((REGEXP *)sv)->mother_re);
5080 /* Their buffer is already owned by someone else. */
5081 if (flags & SV_COW_DROP_PV) {
5082 /* SvLEN is already 0. For SVt_REGEXP, we have a brand new
5083 zeroed body. For SVt_PVLV, it should have been set to 0
5084 before turning into a regexp. */
5085 assert(!SvLEN(islv ? sv : temp));
5086 sv->sv_u.svu_pv = 0;
5089 sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
5090 SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
5094 /* Now swap the rest of the bodies. */
5098 SvFLAGS(sv) &= ~SVTYPEMASK;
5099 SvFLAGS(sv) |= new_type;
5100 SvANY(sv) = SvANY(temp);
5103 SvFLAGS(temp) &= ~(SVTYPEMASK);
5104 SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
5105 SvANY(temp) = temp_p;
5106 temp->sv_u.svu_rx = (regexp *)temp_p;
5108 SvREFCNT_dec_NN(temp);
5110 else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
5116 Efficient removal of characters from the beginning of the string buffer.
5117 SvPOK(sv), or at least SvPOKp(sv), must be true and the C<ptr> must be a
5118 pointer to somewhere inside the string buffer. The C<ptr> becomes the first
5119 character of the adjusted string. Uses the "OOK hack". On return, only
5120 SvPOK(sv) and SvPOKp(sv) among the OK flags will be true.
5122 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
5123 refer to the same chunk of data.
5125 The unfortunate similarity of this function's name to that of Perl's C<chop>
5126 operator is strictly coincidental. This function works from the left;
5127 C<chop> works from the right.
5133 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
5144 PERL_ARGS_ASSERT_SV_CHOP;
5146 if (!ptr || !SvPOKp(sv))
5148 delta = ptr - SvPVX_const(sv);
5150 /* Nothing to do. */
5153 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
5154 if (delta > max_delta)
5155 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
5156 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
5157 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
5158 SV_CHECK_THINKFIRST(sv);
5159 SvPOK_only_UTF8(sv);
5162 if (!SvLEN(sv)) { /* make copy of shared string */
5163 const char *pvx = SvPVX_const(sv);
5164 const STRLEN len = SvCUR(sv);
5165 SvGROW(sv, len + 1);
5166 Move(pvx,SvPVX(sv),len,char);
5172 SvOOK_offset(sv, old_delta);
5174 SvLEN_set(sv, SvLEN(sv) - delta);
5175 SvCUR_set(sv, SvCUR(sv) - delta);
5176 SvPV_set(sv, SvPVX(sv) + delta);
5178 p = (U8 *)SvPVX_const(sv);
5181 /* how many bytes were evacuated? we will fill them with sentinel
5182 bytes, except for the part holding the new offset of course. */
5185 evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5187 assert(evacn <= delta + old_delta);
5191 /* This sets 'delta' to the accumulated value of all deltas so far */
5195 /* If 'delta' fits in a byte, store it just prior to the new beginning of
5196 * the string; otherwise store a 0 byte there and store 'delta' just prior
5197 * to that, using as many bytes as a STRLEN occupies. Thus it overwrites a
5198 * portion of the chopped part of the string */
5199 if (delta < 0x100) {
5203 p -= sizeof(STRLEN);
5204 Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5208 /* Fill the preceding buffer with sentinals to verify that no-one is
5218 =for apidoc sv_catpvn
5220 Concatenates the string onto the end of the string which is in the SV. The
5221 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5222 status set, then the bytes appended should be valid UTF-8.
5223 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
5225 =for apidoc sv_catpvn_flags
5227 Concatenates the string onto the end of the string which is in the SV. The
5228 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5229 status set, then the bytes appended should be valid UTF-8.
5230 If C<flags> has the C<SV_SMAGIC> bit set, will
5231 C<mg_set> on C<dsv> afterwards if appropriate.
5232 C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5233 in terms of this function.
5239 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5243 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5245 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5246 assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5248 if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5249 if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5250 sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5253 else SvGROW(dsv, dlen + slen + 1);
5255 sstr = SvPVX_const(dsv);
5256 Move(sstr, SvPVX(dsv) + dlen, slen, char);
5257 SvCUR_set(dsv, SvCUR(dsv) + slen);
5260 /* We inline bytes_to_utf8, to avoid an extra malloc. */
5261 const char * const send = sstr + slen;
5264 /* Something this code does not account for, which I think is
5265 impossible; it would require the same pv to be treated as
5266 bytes *and* utf8, which would indicate a bug elsewhere. */
5267 assert(sstr != dstr);
5269 SvGROW(dsv, dlen + slen * 2 + 1);
5270 d = (U8 *)SvPVX(dsv) + dlen;
5272 while (sstr < send) {
5273 append_utf8_from_native_byte(*sstr, &d);
5276 SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5279 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
5281 if (flags & SV_SMAGIC)
5286 =for apidoc sv_catsv
5288 Concatenates the string from SV C<ssv> onto the end of the string in SV
5289 C<dsv>. If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5290 Handles 'get' magic on both SVs, but no 'set' magic. See C<sv_catsv_mg> and
5293 =for apidoc sv_catsv_flags
5295 Concatenates the string from SV C<ssv> onto the end of the string in SV
5296 C<dsv>. If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5297 If C<flags> include C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
5298 appropriate. If C<flags> include C<SV_SMAGIC>, C<mg_set> will be called on
5299 the modified SV afterward, if appropriate. C<sv_catsv>, C<sv_catsv_nomg>,
5300 and C<sv_catsv_mg> are implemented in terms of this function.
5305 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
5309 PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5313 const char *spv = SvPV_flags_const(ssv, slen, flags);
5315 if (flags & SV_GMAGIC)
5317 sv_catpvn_flags(dsv, spv, slen,
5318 DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
5319 if (flags & SV_SMAGIC)
5326 =for apidoc sv_catpv
5328 Concatenates the string onto the end of the string which is in the SV.
5329 If the SV has the UTF-8 status set, then the bytes appended should be
5330 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
5335 Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
5342 PERL_ARGS_ASSERT_SV_CATPV;
5346 junk = SvPV_force(sv, tlen);
5348 SvGROW(sv, tlen + len + 1);
5350 ptr = SvPVX_const(sv);
5351 Move(ptr,SvPVX(sv)+tlen,len+1,char);
5352 SvCUR_set(sv, SvCUR(sv) + len);
5353 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5358 =for apidoc sv_catpv_flags
5360 Concatenates the string onto the end of the string which is in the SV.
5361 If the SV has the UTF-8 status set, then the bytes appended should
5362 be valid UTF-8. If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
5363 on the modified SV if appropriate.
5369 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
5371 PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5372 sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
5376 =for apidoc sv_catpv_mg
5378 Like C<sv_catpv>, but also handles 'set' magic.
5384 Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr)
5386 PERL_ARGS_ASSERT_SV_CATPV_MG;
5395 Creates a new SV. A non-zero C<len> parameter indicates the number of
5396 bytes of preallocated string space the SV should have. An extra byte for a
5397 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
5398 space is allocated.) The reference count for the new SV is set to 1.
5400 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
5401 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5402 This aid has been superseded by a new build option, PERL_MEM_LOG (see
5403 L<perlhacktips/PERL_MEM_LOG>). The older API is still there for use in XS
5404 modules supporting older perls.
5410 Perl_newSV(pTHX_ const STRLEN len)
5417 sv_upgrade(sv, SVt_PV);
5418 SvGROW(sv, len + 1);
5423 =for apidoc sv_magicext
5425 Adds magic to an SV, upgrading it if necessary. Applies the
5426 supplied vtable and returns a pointer to the magic added.
5428 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5429 In particular, you can add magic to SvREADONLY SVs, and add more than
5430 one instance of the same 'how'.
5432 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5433 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5434 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5435 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5437 (This is now used as a subroutine by C<sv_magic>.)
5442 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
5443 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5448 PERL_ARGS_ASSERT_SV_MAGICEXT;
5450 if (SvTYPE(sv)==SVt_PVAV) { assert (!AvPAD_NAMELIST(sv)); }
5452 SvUPGRADE(sv, SVt_PVMG);
5453 Newxz(mg, 1, MAGIC);
5454 mg->mg_moremagic = SvMAGIC(sv);
5455 SvMAGIC_set(sv, mg);
5457 /* Sometimes a magic contains a reference loop, where the sv and
5458 object refer to each other. To prevent a reference loop that
5459 would prevent such objects being freed, we look for such loops
5460 and if we find one we avoid incrementing the object refcount.
5462 Note we cannot do this to avoid self-tie loops as intervening RV must
5463 have its REFCNT incremented to keep it in existence.
5466 if (!obj || obj == sv ||
5467 how == PERL_MAGIC_arylen ||
5468 how == PERL_MAGIC_symtab ||
5469 (SvTYPE(obj) == SVt_PVGV &&
5470 (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5471 || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5472 || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5477 mg->mg_obj = SvREFCNT_inc_simple(obj);
5478 mg->mg_flags |= MGf_REFCOUNTED;
5481 /* Normal self-ties simply pass a null object, and instead of
5482 using mg_obj directly, use the SvTIED_obj macro to produce a
5483 new RV as needed. For glob "self-ties", we are tieing the PVIO
5484 with an RV obj pointing to the glob containing the PVIO. In
5485 this case, to avoid a reference loop, we need to weaken the
5489 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5490 obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5496 mg->mg_len = namlen;
5499 mg->mg_ptr = savepvn(name, namlen);
5500 else if (namlen == HEf_SVKEY) {
5501 /* Yes, this is casting away const. This is only for the case of
5502 HEf_SVKEY. I think we need to document this aberation of the
5503 constness of the API, rather than making name non-const, as
5504 that change propagating outwards a long way. */
5505 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5507 mg->mg_ptr = (char *) name;
5509 mg->mg_virtual = (MGVTBL *) vtable;
5516 Perl_sv_magicext_mglob(pTHX_ SV *sv)
5518 PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB;
5519 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
5520 /* This sv is only a delegate. //g magic must be attached to
5525 #ifdef PERL_OLD_COPY_ON_WRITE
5527 sv_force_normal_flags(sv, 0);
5529 return sv_magicext(sv, NULL, PERL_MAGIC_regex_global,
5530 &PL_vtbl_mglob, 0, 0);
5534 =for apidoc sv_magic
5536 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if
5537 necessary, then adds a new magic item of type C<how> to the head of the
5540 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5541 handling of the C<name> and C<namlen> arguments.
5543 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5544 to add more than one instance of the same 'how'.
5550 Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
5551 const char *const name, const I32 namlen)
5554 const MGVTBL *vtable;
5557 unsigned int vtable_index;
5559 PERL_ARGS_ASSERT_SV_MAGIC;
5561 if (how < 0 || (unsigned)how > C_ARRAY_LENGTH(PL_magic_data)
5562 || ((flags = PL_magic_data[how]),
5563 (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
5564 > magic_vtable_max))
5565 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5567 /* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
5568 Useful for attaching extension internal data to perl vars.
5569 Note that multiple extensions may clash if magical scalars
5570 etc holding private data from one are passed to another. */
5572 vtable = (vtable_index == magic_vtable_max)
5573 ? NULL : PL_magic_vtables + vtable_index;
5575 #ifdef PERL_OLD_COPY_ON_WRITE
5577 sv_force_normal_flags(sv, 0);
5579 if (SvREADONLY(sv)) {
5581 !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
5584 Perl_croak_no_modify();
5587 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5588 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5589 /* sv_magic() refuses to add a magic of the same 'how' as an
5592 if (how == PERL_MAGIC_taint)
5598 /* Force pos to be stored as characters, not bytes. */
5599 if (SvMAGICAL(sv) && DO_UTF8(sv)
5600 && (mg = mg_find(sv, PERL_MAGIC_regex_global))
5602 && mg->mg_flags & MGf_BYTES) {
5603 mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len,
5605 mg->mg_flags &= ~MGf_BYTES;
5608 /* Rest of work is done else where */
5609 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5612 case PERL_MAGIC_taint:
5615 case PERL_MAGIC_ext:
5616 case PERL_MAGIC_dbfile:
5623 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
5630 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5632 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5633 for (mg = *mgp; mg; mg = *mgp) {
5634 const MGVTBL* const virt = mg->mg_virtual;
5635 if (mg->mg_type == type && (!flags || virt == vtbl)) {
5636 *mgp = mg->mg_moremagic;
5637 if (virt && virt->svt_free)
5638 virt->svt_free(aTHX_ sv, mg);
5639 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5641 Safefree(mg->mg_ptr);
5642 else if (mg->mg_len == HEf_SVKEY)
5643 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5644 else if (mg->mg_type == PERL_MAGIC_utf8)
5645 Safefree(mg->mg_ptr);
5647 if (mg->mg_flags & MGf_REFCOUNTED)
5648 SvREFCNT_dec(mg->mg_obj);
5652 mgp = &mg->mg_moremagic;
5655 if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
5656 mg_magical(sv); /* else fix the flags now */
5660 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5666 =for apidoc sv_unmagic
5668 Removes all magic of type C<type> from an SV.
5674 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5676 PERL_ARGS_ASSERT_SV_UNMAGIC;
5677 return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5681 =for apidoc sv_unmagicext
5683 Removes all magic of type C<type> with the specified C<vtbl> from an SV.
5689 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
5691 PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5692 return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5696 =for apidoc sv_rvweaken
5698 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5699 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5700 push a back-reference to this RV onto the array of backreferences
5701 associated with that magic. If the RV is magical, set magic will be
5702 called after the RV is cleared.
5708 Perl_sv_rvweaken(pTHX_ SV *const sv)
5712 PERL_ARGS_ASSERT_SV_RVWEAKEN;
5714 if (!SvOK(sv)) /* let undefs pass */
5717 Perl_croak(aTHX_ "Can't weaken a nonreference");
5718 else if (SvWEAKREF(sv)) {
5719 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5722 else if (SvREADONLY(sv)) croak_no_modify();
5724 Perl_sv_add_backref(aTHX_ tsv, sv);
5726 SvREFCNT_dec_NN(tsv);
5730 /* Give tsv backref magic if it hasn't already got it, then push a
5731 * back-reference to sv onto the array associated with the backref magic.
5733 * As an optimisation, if there's only one backref and it's not an AV,
5734 * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5735 * allocate an AV. (Whether the slot holds an AV tells us whether this is
5739 /* A discussion about the backreferences array and its refcount:
5741 * The AV holding the backreferences is pointed to either as the mg_obj of
5742 * PERL_MAGIC_backref, or in the specific case of a HV, from the
5743 * xhv_backreferences field. The array is created with a refcount
5744 * of 2. This means that if during global destruction the array gets
5745 * picked on before its parent to have its refcount decremented by the
5746 * random zapper, it won't actually be freed, meaning it's still there for
5747 * when its parent gets freed.
5749 * When the parent SV is freed, the extra ref is killed by
5750 * Perl_sv_kill_backrefs. The other ref is killed, in the case of magic,
5751 * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5753 * When a single backref SV is stored directly, it is not reference
5758 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5765 PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5767 /* find slot to store array or singleton backref */
5769 if (SvTYPE(tsv) == SVt_PVHV) {
5770 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5773 mg = mg_find(tsv, PERL_MAGIC_backref);
5775 mg = sv_magicext(tsv, NULL, PERL_MAGIC_backref, &PL_vtbl_backref, NULL, 0);
5776 svp = &(mg->mg_obj);
5779 /* create or retrieve the array */
5781 if ( (!*svp && SvTYPE(sv) == SVt_PVAV)
5782 || (*svp && SvTYPE(*svp) != SVt_PVAV)
5786 mg->mg_flags |= MGf_REFCOUNTED;
5789 SvREFCNT_inc_simple_void_NN(av);
5790 /* av now has a refcnt of 2; see discussion above */
5791 av_extend(av, *svp ? 2 : 1);
5793 /* move single existing backref to the array */
5794 AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5799 av = MUTABLE_AV(*svp);
5801 /* optimisation: store single backref directly in HvAUX or mg_obj */
5805 assert(SvTYPE(av) == SVt_PVAV);
5806 if (AvFILLp(av) >= AvMAX(av)) {
5807 av_extend(av, AvFILLp(av)+1);
5810 /* push new backref */
5811 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5814 /* delete a back-reference to ourselves from the backref magic associated
5815 * with the SV we point to.
5819 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5824 PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5826 if (SvTYPE(tsv) == SVt_PVHV) {
5828 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5830 else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
5831 /* It's possible for the the last (strong) reference to tsv to have
5832 become freed *before* the last thing holding a weak reference.
5833 If both survive longer than the backreferences array, then when
5834 the referent's reference count drops to 0 and it is freed, it's
5835 not able to chase the backreferences, so they aren't NULLed.
5837 For example, a CV holds a weak reference to its stash. If both the
5838 CV and the stash survive longer than the backreferences array,
5839 and the CV gets picked for the SvBREAK() treatment first,
5840 *and* it turns out that the stash is only being kept alive because
5841 of an our variable in the pad of the CV, then midway during CV
5842 destruction the stash gets freed, but CvSTASH() isn't set to NULL.
5843 It ends up pointing to the freed HV. Hence it's chased in here, and
5844 if this block wasn't here, it would hit the !svp panic just below.
5846 I don't believe that "better" destruction ordering is going to help
5847 here - during global destruction there's always going to be the
5848 chance that something goes out of order. We've tried to make it
5849 foolproof before, and it only resulted in evolutionary pressure on
5850 fools. Which made us look foolish for our hubris. :-(
5856 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5857 svp = mg ? &(mg->mg_obj) : NULL;
5861 Perl_croak(aTHX_ "panic: del_backref, svp=0");
5863 /* It's possible that sv is being freed recursively part way through the
5864 freeing of tsv. If this happens, the backreferences array of tsv has
5865 already been freed, and so svp will be NULL. If this is the case,
5866 we should not panic. Instead, nothing needs doing, so return. */
5867 if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
5869 Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
5870 *svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
5873 if (SvTYPE(*svp) == SVt_PVAV) {
5877 AV * const av = (AV*)*svp;
5879 assert(!SvIS_FREED(av));
5883 /* for an SV with N weak references to it, if all those
5884 * weak refs are deleted, then sv_del_backref will be called
5885 * N times and O(N^2) compares will be done within the backref
5886 * array. To ameliorate this potential slowness, we:
5887 * 1) make sure this code is as tight as possible;
5888 * 2) when looking for SV, look for it at both the head and tail of the
5889 * array first before searching the rest, since some create/destroy
5890 * patterns will cause the backrefs to be freed in order.
5897 SV **p = &svp[fill];
5898 SV *const topsv = *p;
5905 /* We weren't the last entry.
5906 An unordered list has this property that you
5907 can take the last element off the end to fill
5908 the hole, and it's still an unordered list :-)
5914 break; /* should only be one */
5921 AvFILLp(av) = fill-1;
5923 else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) {
5924 /* freed AV; skip */
5927 /* optimisation: only a single backref, stored directly */
5929 Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p", *svp, sv);
5936 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5942 PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5947 /* after multiple passes through Perl_sv_clean_all() for a thingy
5948 * that has badly leaked, the backref array may have gotten freed,
5949 * since we only protect it against 1 round of cleanup */
5950 if (SvIS_FREED(av)) {
5951 if (PL_in_clean_all) /* All is fair */
5954 "panic: magic_killbackrefs (freed backref AV/SV)");
5958 is_array = (SvTYPE(av) == SVt_PVAV);
5960 assert(!SvIS_FREED(av));
5963 last = svp + AvFILLp(av);
5966 /* optimisation: only a single backref, stored directly */
5972 while (svp <= last) {
5974 SV *const referrer = *svp;
5975 if (SvWEAKREF(referrer)) {
5976 /* XXX Should we check that it hasn't changed? */
5977 assert(SvROK(referrer));
5978 SvRV_set(referrer, 0);
5980 SvWEAKREF_off(referrer);
5981 SvSETMAGIC(referrer);
5982 } else if (SvTYPE(referrer) == SVt_PVGV ||
5983 SvTYPE(referrer) == SVt_PVLV) {
5984 assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
5985 /* You lookin' at me? */
5986 assert(GvSTASH(referrer));
5987 assert(GvSTASH(referrer) == (const HV *)sv);
5988 GvSTASH(referrer) = 0;
5989 } else if (SvTYPE(referrer) == SVt_PVCV ||
5990 SvTYPE(referrer) == SVt_PVFM) {
5991 if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
5992 /* You lookin' at me? */
5993 assert(CvSTASH(referrer));
5994 assert(CvSTASH(referrer) == (const HV *)sv);
5995 SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
5998 assert(SvTYPE(sv) == SVt_PVGV);
5999 /* You lookin' at me? */
6000 assert(CvGV(referrer));
6001 assert(CvGV(referrer) == (const GV *)sv);
6002 anonymise_cv_maybe(MUTABLE_GV(sv),
6003 MUTABLE_CV(referrer));
6008 "panic: magic_killbackrefs (flags=%"UVxf")",
6009 (UV)SvFLAGS(referrer));
6020 SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */
6026 =for apidoc sv_insert
6028 Inserts a string at the specified offset/length within the SV. Similar to
6029 the Perl substr() function. Handles get magic.
6031 =for apidoc sv_insert_flags
6033 Same as C<sv_insert>, but the extra C<flags> are passed to the
6034 C<SvPV_force_flags> that applies to C<bigstr>.
6040 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
6047 SSize_t i; /* better be sizeof(STRLEN) or bad things happen */
6050 PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
6053 Perl_croak(aTHX_ "Can't modify nonexistent substring");
6054 SvPV_force_flags(bigstr, curlen, flags);
6055 (void)SvPOK_only_UTF8(bigstr);
6056 if (offset + len > curlen) {
6057 SvGROW(bigstr, offset+len+1);
6058 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
6059 SvCUR_set(bigstr, offset+len);
6063 i = littlelen - len;
6064 if (i > 0) { /* string might grow */
6065 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
6066 mid = big + offset + len;
6067 midend = bigend = big + SvCUR(bigstr);
6070 while (midend > mid) /* shove everything down */
6071 *--bigend = *--midend;
6072 Move(little,big+offset,littlelen,char);
6073 SvCUR_set(bigstr, SvCUR(bigstr) + i);
6078 Move(little,SvPVX(bigstr)+offset,len,char);
6083 big = SvPVX(bigstr);
6086 bigend = big + SvCUR(bigstr);
6088 if (midend > bigend)
6089 Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
6092 if (mid - big > bigend - midend) { /* faster to shorten from end */
6094 Move(little, mid, littlelen,char);
6097 i = bigend - midend;
6099 Move(midend, mid, i,char);
6103 SvCUR_set(bigstr, mid - big);
6105 else if ((i = mid - big)) { /* faster from front */
6106 midend -= littlelen;
6108 Move(big, midend - i, i, char);
6109 sv_chop(bigstr,midend-i);
6111 Move(little, mid, littlelen,char);
6113 else if (littlelen) {
6114 midend -= littlelen;
6115 sv_chop(bigstr,midend);
6116 Move(little,midend,littlelen,char);
6119 sv_chop(bigstr,midend);
6125 =for apidoc sv_replace
6127 Make the first argument a copy of the second, then delete the original.
6128 The target SV physically takes over ownership of the body of the source SV
6129 and inherits its flags; however, the target keeps any magic it owns,
6130 and any magic in the source is discarded.
6131 Note that this is a rather specialist SV copying operation; most of the
6132 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
6138 Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
6141 const U32 refcnt = SvREFCNT(sv);
6143 PERL_ARGS_ASSERT_SV_REPLACE;
6145 SV_CHECK_THINKFIRST_COW_DROP(sv);
6146 if (SvREFCNT(nsv) != 1) {
6147 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
6148 " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
6150 if (SvMAGICAL(sv)) {
6154 sv_upgrade(nsv, SVt_PVMG);
6155 SvMAGIC_set(nsv, SvMAGIC(sv));
6156 SvFLAGS(nsv) |= SvMAGICAL(sv);
6158 SvMAGIC_set(sv, NULL);
6162 assert(!SvREFCNT(sv));
6163 #ifdef DEBUG_LEAKING_SCALARS
6164 sv->sv_flags = nsv->sv_flags;
6165 sv->sv_any = nsv->sv_any;
6166 sv->sv_refcnt = nsv->sv_refcnt;
6167 sv->sv_u = nsv->sv_u;
6169 StructCopy(nsv,sv,SV);
6171 if(SvTYPE(sv) == SVt_IV) {
6173 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
6177 #ifdef PERL_OLD_COPY_ON_WRITE
6178 if (SvIsCOW_normal(nsv)) {
6179 /* We need to follow the pointers around the loop to make the
6180 previous SV point to sv, rather than nsv. */
6183 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
6186 assert(SvPVX_const(current) == SvPVX_const(nsv));
6188 /* Make the SV before us point to the SV after us. */
6190 PerlIO_printf(Perl_debug_log, "previous is\n");
6192 PerlIO_printf(Perl_debug_log,
6193 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
6194 (UV) SV_COW_NEXT_SV(current), (UV) sv);
6196 SV_COW_NEXT_SV_SET(current, sv);
6199 SvREFCNT(sv) = refcnt;
6200 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
6205 /* We're about to free a GV which has a CV that refers back to us.
6206 * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
6210 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
6215 PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
6218 assert(SvREFCNT(gv) == 0);
6219 assert(isGV(gv) && isGV_with_GP(gv));
6221 assert(!CvANON(cv));
6222 assert(CvGV(cv) == gv);
6223 assert(!CvNAMED(cv));
6225 /* will the CV shortly be freed by gp_free() ? */
6226 if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
6227 SvANY(cv)->xcv_gv_u.xcv_gv = NULL;
6231 /* if not, anonymise: */
6232 gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv)))
6233 ? newSVhek(HvENAME_HEK(GvSTASH(gv)))
6234 : newSVpvn_flags( "__ANON__", 8, 0 );
6235 sv_catpvs(gvname, "::__ANON__");
6236 anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
6237 SvREFCNT_dec_NN(gvname);
6241 SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
6246 =for apidoc sv_clear
6248 Clear an SV: call any destructors, free up any memory used by the body,
6249 and free the body itself. The SV's head is I<not> freed, although
6250 its type is set to all 1's so that it won't inadvertently be assumed
6251 to be live during global destruction etc.
6252 This function should only be called when REFCNT is zero. Most of the time
6253 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
6260 Perl_sv_clear(pTHX_ SV *const orig_sv)
6265 const struct body_details *sv_type_details;
6271 PERL_ARGS_ASSERT_SV_CLEAR;
6273 /* within this loop, sv is the SV currently being freed, and
6274 * iter_sv is the most recent AV or whatever that's being iterated
6275 * over to provide more SVs */
6281 assert(SvREFCNT(sv) == 0);
6282 assert(SvTYPE(sv) != (svtype)SVTYPEMASK);
6284 if (type <= SVt_IV) {
6285 /* See the comment in sv.h about the collusion between this
6286 * early return and the overloading of the NULL slots in the
6290 SvFLAGS(sv) &= SVf_BREAK;
6291 SvFLAGS(sv) |= SVTYPEMASK;
6295 assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */
6297 if (type >= SVt_PVMG) {
6299 if (!curse(sv, 1)) goto get_next_sv;
6300 type = SvTYPE(sv); /* destructor may have changed it */
6302 /* Free back-references before magic, in case the magic calls
6303 * Perl code that has weak references to sv. */
6304 if (type == SVt_PVHV) {
6305 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6309 else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
6310 SvREFCNT_dec(SvOURSTASH(sv));
6312 else if (type == SVt_PVAV && AvPAD_NAMELIST(sv)) {
6313 assert(!SvMAGICAL(sv));
6314 } else if (SvMAGIC(sv)) {
6315 /* Free back-references before other types of magic. */
6316 sv_unmagic(sv, PERL_MAGIC_backref);
6320 if (type == SVt_PVMG && SvPAD_TYPED(sv))
6321 SvREFCNT_dec(SvSTASH(sv));
6324 /* case SVt_INVLIST: */
6327 IoIFP(sv) != PerlIO_stdin() &&
6328 IoIFP(sv) != PerlIO_stdout() &&
6329 IoIFP(sv) != PerlIO_stderr() &&
6330 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6332 io_close(MUTABLE_IO(sv), FALSE);
6334 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6335 PerlDir_close(IoDIRP(sv));
6336 IoDIRP(sv) = (DIR*)NULL;
6337 Safefree(IoTOP_NAME(sv));
6338 Safefree(IoFMT_NAME(sv));
6339 Safefree(IoBOTTOM_NAME(sv));
6340 if ((const GV *)sv == PL_statgv)
6344 /* FIXME for plugins */
6346 pregfree2((REGEXP*) sv);
6350 cv_undef(MUTABLE_CV(sv));
6351 /* If we're in a stash, we don't own a reference to it.
6352 * However it does have a back reference to us, which needs to
6354 if ((stash = CvSTASH(sv)))
6355 sv_del_backref(MUTABLE_SV(stash), sv);
6358 if (PL_last_swash_hv == (const HV *)sv) {
6359 PL_last_swash_hv = NULL;
6361 if (HvTOTALKEYS((HV*)sv) > 0) {
6363 /* this statement should match the one at the beginning of
6364 * hv_undef_flags() */
6365 if ( PL_phase != PERL_PHASE_DESTRUCT
6366 && (name = HvNAME((HV*)sv)))
6368 if (PL_stashcache) {
6369 DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n",
6371 (void)hv_deletehek(PL_stashcache,
6372 HvNAME_HEK((HV*)sv), G_DISCARD);
6374 hv_name_set((HV*)sv, NULL, 0, 0);
6377 /* save old iter_sv in unused SvSTASH field */
6378 assert(!SvOBJECT(sv));
6379 SvSTASH(sv) = (HV*)iter_sv;
6382 /* save old hash_index in unused SvMAGIC field */
6383 assert(!SvMAGICAL(sv));
6384 assert(!SvMAGIC(sv));
6385 ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index;
6388 next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index);
6389 goto get_next_sv; /* process this new sv */
6391 /* free empty hash */
6392 Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6393 assert(!HvARRAY((HV*)sv));
6397 AV* av = MUTABLE_AV(sv);
6398 if (PL_comppad == av) {
6402 if (AvREAL(av) && AvFILLp(av) > -1) {
6403 next_sv = AvARRAY(av)[AvFILLp(av)--];
6404 /* save old iter_sv in top-most slot of AV,
6405 * and pray that it doesn't get wiped in the meantime */
6406 AvARRAY(av)[AvMAX(av)] = iter_sv;
6408 goto get_next_sv; /* process this new sv */
6410 Safefree(AvALLOC(av));
6415 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
6416 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
6417 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
6418 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
6420 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
6421 SvREFCNT_dec(LvTARG(sv));
6422 if (isREGEXP(sv)) goto freeregexp;
6424 if (isGV_with_GP(sv)) {
6425 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
6426 && HvENAME_get(stash))
6427 mro_method_changed_in(stash);
6428 gp_free(MUTABLE_GV(sv));
6430 unshare_hek(GvNAME_HEK(sv));
6431 /* If we're in a stash, we don't own a reference to it.
6432 * However it does have a back reference to us, which
6433 * needs to be cleared. */
6434 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
6435 sv_del_backref(MUTABLE_SV(stash), sv);
6437 /* FIXME. There are probably more unreferenced pointers to SVs
6438 * in the interpreter struct that we should check and tidy in
6439 * a similar fashion to this: */
6440 /* See also S_sv_unglob, which does the same thing. */
6441 if ((const GV *)sv == PL_last_in_gv)
6442 PL_last_in_gv = NULL;
6443 else if ((const GV *)sv == PL_statgv)
6445 else if ((const GV *)sv == PL_stderrgv)
6453 /* Don't bother with SvOOK_off(sv); as we're only going to
6457 SvOOK_offset(sv, offset);
6458 SvPV_set(sv, SvPVX_mutable(sv) - offset);
6459 /* Don't even bother with turning off the OOK flag. */
6464 SV * const target = SvRV(sv);
6466 sv_del_backref(target, sv);
6472 else if (SvPVX_const(sv)
6473 && !(SvTYPE(sv) == SVt_PVIO
6474 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6478 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6482 # ifdef PERL_OLD_COPY_ON_WRITE
6483 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
6485 if (CowREFCNT(sv)) {
6493 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6497 # ifdef PERL_OLD_COPY_ON_WRITE
6501 Safefree(SvPVX_mutable(sv));
6505 else if (SvPVX_const(sv) && SvLEN(sv)
6506 && !(SvTYPE(sv) == SVt_PVIO
6507 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6508 Safefree(SvPVX_mutable(sv));
6509 else if (SvPVX_const(sv) && SvIsCOW(sv)) {
6510 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6520 SvFLAGS(sv) &= SVf_BREAK;
6521 SvFLAGS(sv) |= SVTYPEMASK;
6523 sv_type_details = bodies_by_type + type;
6524 if (sv_type_details->arena) {
6525 del_body(((char *)SvANY(sv) + sv_type_details->offset),
6526 &PL_body_roots[type]);
6528 else if (sv_type_details->body_size) {
6529 safefree(SvANY(sv));
6533 /* caller is responsible for freeing the head of the original sv */
6534 if (sv != orig_sv && !SvREFCNT(sv))
6537 /* grab and free next sv, if any */
6545 else if (!iter_sv) {
6547 } else if (SvTYPE(iter_sv) == SVt_PVAV) {
6548 AV *const av = (AV*)iter_sv;
6549 if (AvFILLp(av) > -1) {
6550 sv = AvARRAY(av)[AvFILLp(av)--];
6552 else { /* no more elements of current AV to free */
6555 /* restore previous value, squirrelled away */
6556 iter_sv = AvARRAY(av)[AvMAX(av)];
6557 Safefree(AvALLOC(av));
6560 } else if (SvTYPE(iter_sv) == SVt_PVHV) {
6561 sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index);
6562 if (!sv && !HvTOTALKEYS((HV *)iter_sv)) {
6563 /* no more elements of current HV to free */
6566 /* Restore previous values of iter_sv and hash_index,
6567 * squirrelled away */
6568 assert(!SvOBJECT(sv));
6569 iter_sv = (SV*)SvSTASH(sv);
6570 assert(!SvMAGICAL(sv));
6571 hash_index = ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index;
6573 /* perl -DA does not like rubbish in SvMAGIC. */
6577 /* free any remaining detritus from the hash struct */
6578 Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6579 assert(!HvARRAY((HV*)sv));
6584 /* unrolled SvREFCNT_dec and sv_free2 follows: */
6588 if (!SvREFCNT(sv)) {
6592 if (--(SvREFCNT(sv)))
6596 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6597 "Attempt to free temp prematurely: SV 0x%"UVxf
6598 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6602 if (SvIMMORTAL(sv)) {
6603 /* make sure SvREFCNT(sv)==0 happens very seldom */
6604 SvREFCNT(sv) = SvREFCNT_IMMORTAL;
6613 /* This routine curses the sv itself, not the object referenced by sv. So
6614 sv does not have to be ROK. */
6617 S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
6620 PERL_ARGS_ASSERT_CURSE;
6621 assert(SvOBJECT(sv));
6623 if (PL_defstash && /* Still have a symbol table? */
6629 stash = SvSTASH(sv);
6630 assert(SvTYPE(stash) == SVt_PVHV);
6631 if (HvNAME(stash)) {
6632 CV* destructor = NULL;
6633 assert (SvOOK(stash));
6634 if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash);
6635 if (!destructor || HvMROMETA(stash)->destroy_gen
6636 != PL_sub_generation)
6639 gv_fetchmeth_autoload(stash, "DESTROY", 7, 0);
6640 if (gv) destructor = GvCV(gv);
6641 if (!SvOBJECT(stash))
6644 destructor ? (HV *)destructor : ((HV *)0)+1;
6645 HvAUX(stash)->xhv_mro_meta->destroy_gen =
6649 assert(!destructor || destructor == ((CV *)0)+1
6650 || SvTYPE(destructor) == SVt_PVCV);
6651 if (destructor && destructor != ((CV *)0)+1
6652 /* A constant subroutine can have no side effects, so
6653 don't bother calling it. */
6654 && !CvCONST(destructor)
6655 /* Don't bother calling an empty destructor or one that
6656 returns immediately. */
6657 && (CvISXSUB(destructor)
6658 || (CvSTART(destructor)
6659 && (CvSTART(destructor)->op_next->op_type
6661 && (CvSTART(destructor)->op_next->op_type
6663 || CvSTART(destructor)->op_next->op_next->op_type
6669 SV* const tmpref = newRV(sv);
6670 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
6672 PUSHSTACKi(PERLSI_DESTROY);
6677 call_sv(MUTABLE_SV(destructor),
6678 G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
6682 if(SvREFCNT(tmpref) < 2) {
6683 /* tmpref is not kept alive! */
6685 SvRV_set(tmpref, NULL);
6688 SvREFCNT_dec_NN(tmpref);
6691 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
6694 if (check_refcnt && SvREFCNT(sv)) {
6695 if (PL_in_clean_objs)
6697 "DESTROY created new reference to dead object '%"HEKf"'",
6698 HEKfARG(HvNAME_HEK(stash)));
6699 /* DESTROY gave object new lease on life */
6705 HV * const stash = SvSTASH(sv);
6706 /* Curse before freeing the stash, as freeing the stash could cause
6707 a recursive call into S_curse. */
6708 SvOBJECT_off(sv); /* Curse the object. */
6709 SvSTASH_set(sv,0); /* SvREFCNT_dec may try to read this */
6710 SvREFCNT_dec(stash); /* possibly of changed persuasion */
6716 =for apidoc sv_newref
6718 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6725 Perl_sv_newref(pTHX_ SV *const sv)
6727 PERL_UNUSED_CONTEXT;
6736 Decrement an SV's reference count, and if it drops to zero, call
6737 C<sv_clear> to invoke destructors and free up any memory used by
6738 the body; finally, deallocate the SV's head itself.
6739 Normally called via a wrapper macro C<SvREFCNT_dec>.
6745 Perl_sv_free(pTHX_ SV *const sv)
6751 /* Private helper function for SvREFCNT_dec().
6752 * Called with rc set to original SvREFCNT(sv), where rc == 0 or 1 */
6755 Perl_sv_free2(pTHX_ SV *const sv, const U32 rc)
6759 PERL_ARGS_ASSERT_SV_FREE2;
6761 if (LIKELY( rc == 1 )) {
6767 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6768 "Attempt to free temp prematurely: SV 0x%"UVxf
6769 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6773 if (SvIMMORTAL(sv)) {
6774 /* make sure SvREFCNT(sv)==0 happens very seldom */
6775 SvREFCNT(sv) = SvREFCNT_IMMORTAL;
6779 if (! SvREFCNT(sv)) /* may have have been resurrected */
6784 /* handle exceptional cases */
6788 if (SvFLAGS(sv) & SVf_BREAK)
6789 /* this SV's refcnt has been artificially decremented to
6790 * trigger cleanup */
6792 if (PL_in_clean_all) /* All is fair */
6794 if (SvIMMORTAL(sv)) {
6795 /* make sure SvREFCNT(sv)==0 happens very seldom */
6796 SvREFCNT(sv) = SvREFCNT_IMMORTAL;
6799 if (ckWARN_d(WARN_INTERNAL)) {
6800 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
6801 Perl_dump_sv_child(aTHX_ sv);
6803 #ifdef DEBUG_LEAKING_SCALARS
6806 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6807 if (PL_warnhook == PERL_WARNHOOK_FATAL
6808 || ckDEAD(packWARN(WARN_INTERNAL))) {
6809 /* Don't let Perl_warner cause us to escape our fate: */
6813 /* This may not return: */
6814 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6815 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6816 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6819 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6829 Returns the length of the string in the SV. Handles magic and type
6830 coercion and sets the UTF8 flag appropriately. See also C<SvCUR>, which
6831 gives raw access to the xpv_cur slot.
6837 Perl_sv_len(pTHX_ SV *const sv)
6844 (void)SvPV_const(sv, len);
6849 =for apidoc sv_len_utf8
6851 Returns the number of characters in the string in an SV, counting wide
6852 UTF-8 bytes as a single character. Handles magic and type coercion.
6858 * The length is cached in PERL_MAGIC_utf8, in the mg_len field. Also the
6859 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6860 * (Note that the mg_len is not the length of the mg_ptr field.
6861 * This allows the cache to store the character length of the string without
6862 * needing to malloc() extra storage to attach to the mg_ptr.)
6867 Perl_sv_len_utf8(pTHX_ SV *const sv)
6873 return sv_len_utf8_nomg(sv);
6877 Perl_sv_len_utf8_nomg(pTHX_ SV * const sv)
6881 const U8 *s = (U8*)SvPV_nomg_const(sv, len);
6883 PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG;
6885 if (PL_utf8cache && SvUTF8(sv)) {
6887 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6889 if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
6890 if (mg->mg_len != -1)
6893 /* We can use the offset cache for a headstart.
6894 The longer value is stored in the first pair. */
6895 STRLEN *cache = (STRLEN *) mg->mg_ptr;
6897 ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
6901 if (PL_utf8cache < 0) {
6902 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6903 assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
6907 ulen = Perl_utf8_length(aTHX_ s, s + len);
6908 utf8_mg_len_cache_update(sv, &mg, ulen);
6912 return SvUTF8(sv) ? Perl_utf8_length(aTHX_ s, s + len) : len;
6915 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6918 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6919 STRLEN *const uoffset_p, bool *const at_end)
6921 const U8 *s = start;
6922 STRLEN uoffset = *uoffset_p;
6924 PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6926 while (s < send && uoffset) {
6933 else if (s > send) {
6935 /* This is the existing behaviour. Possibly it should be a croak, as
6936 it's actually a bounds error */
6939 *uoffset_p -= uoffset;
6943 /* Given the length of the string in both bytes and UTF-8 characters, decide
6944 whether to walk forwards or backwards to find the byte corresponding to
6945 the passed in UTF-8 offset. */
6947 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6948 STRLEN uoffset, const STRLEN uend)
6950 STRLEN backw = uend - uoffset;
6952 PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6954 if (uoffset < 2 * backw) {
6955 /* The assumption is that going forwards is twice the speed of going
6956 forward (that's where the 2 * backw comes from).
6957 (The real figure of course depends on the UTF-8 data.) */
6958 const U8 *s = start;
6960 while (s < send && uoffset--)
6970 while (UTF8_IS_CONTINUATION(*send))
6973 return send - start;
6976 /* For the string representation of the given scalar, find the byte
6977 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
6978 give another position in the string, *before* the sought offset, which
6979 (which is always true, as 0, 0 is a valid pair of positions), which should
6980 help reduce the amount of linear searching.
6981 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6982 will be used to reduce the amount of linear searching. The cache will be
6983 created if necessary, and the found value offered to it for update. */
6985 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6986 const U8 *const send, STRLEN uoffset,
6987 STRLEN uoffset0, STRLEN boffset0)
6989 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
6991 bool at_end = FALSE;
6993 PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6995 assert (uoffset >= uoffset0);
7000 if (!SvREADONLY(sv) && !SvGMAGICAL(sv) && SvPOK(sv)
7002 && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
7003 (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
7004 if ((*mgp)->mg_ptr) {
7005 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
7006 if (cache[0] == uoffset) {
7007 /* An exact match. */
7010 if (cache[2] == uoffset) {
7011 /* An exact match. */
7015 if (cache[0] < uoffset) {
7016 /* The cache already knows part of the way. */
7017 if (cache[0] > uoffset0) {
7018 /* The cache knows more than the passed in pair */
7019 uoffset0 = cache[0];
7020 boffset0 = cache[1];
7022 if ((*mgp)->mg_len != -1) {
7023 /* And we know the end too. */
7025 + sv_pos_u2b_midway(start + boffset0, send,
7027 (*mgp)->mg_len - uoffset0);
7029 uoffset -= uoffset0;
7031 + sv_pos_u2b_forwards(start + boffset0,
7032 send, &uoffset, &at_end);
7033 uoffset += uoffset0;
7036 else if (cache[2] < uoffset) {
7037 /* We're between the two cache entries. */
7038 if (cache[2] > uoffset0) {
7039 /* and the cache knows more than the passed in pair */
7040 uoffset0 = cache[2];
7041 boffset0 = cache[3];
7045 + sv_pos_u2b_midway(start + boffset0,
7048 cache[0] - uoffset0);
7051 + sv_pos_u2b_midway(start + boffset0,
7054 cache[2] - uoffset0);
7058 else if ((*mgp)->mg_len != -1) {
7059 /* If we can take advantage of a passed in offset, do so. */
7060 /* In fact, offset0 is either 0, or less than offset, so don't
7061 need to worry about the other possibility. */
7063 + sv_pos_u2b_midway(start + boffset0, send,
7065 (*mgp)->mg_len - uoffset0);
7070 if (!found || PL_utf8cache < 0) {
7071 STRLEN real_boffset;
7072 uoffset -= uoffset0;
7073 real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
7074 send, &uoffset, &at_end);
7075 uoffset += uoffset0;
7077 if (found && PL_utf8cache < 0)
7078 assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
7080 boffset = real_boffset;
7083 if (PL_utf8cache && !SvGMAGICAL(sv) && SvPOK(sv)) {
7085 utf8_mg_len_cache_update(sv, mgp, uoffset);
7087 utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
7094 =for apidoc sv_pos_u2b_flags
7096 Converts the offset from a count of UTF-8 chars from
7097 the start of the string, to a count of the equivalent number of bytes; if
7098 lenp is non-zero, it does the same to lenp, but this time starting from
7099 the offset, rather than from the start
7100 of the string. Handles type coercion.
7101 I<flags> is passed to C<SvPV_flags>, and usually should be
7102 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
7108 * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
7109 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7110 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
7115 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
7122 PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
7124 start = (U8*)SvPV_flags(sv, len, flags);
7126 const U8 * const send = start + len;
7128 boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
7131 && *lenp /* don't bother doing work for 0, as its bytes equivalent
7132 is 0, and *lenp is already set to that. */) {
7133 /* Convert the relative offset to absolute. */
7134 const STRLEN uoffset2 = uoffset + *lenp;
7135 const STRLEN boffset2
7136 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
7137 uoffset, boffset) - boffset;
7151 =for apidoc sv_pos_u2b
7153 Converts the value pointed to by offsetp from a count of UTF-8 chars from
7154 the start of the string, to a count of the equivalent number of bytes; if
7155 lenp is non-zero, it does the same to lenp, but this time starting from
7156 the offset, rather than from the start of the string. Handles magic and
7159 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
7166 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
7167 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7168 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
7172 /* This function is subject to size and sign problems */
7175 Perl_sv_pos_u2b(pTHX_ SV *const sv, I32 *const offsetp, I32 *const lenp)
7177 PERL_ARGS_ASSERT_SV_POS_U2B;
7180 STRLEN ulen = (STRLEN)*lenp;
7181 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
7182 SV_GMAGIC|SV_CONST_RETURN);
7185 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
7186 SV_GMAGIC|SV_CONST_RETURN);
7191 S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
7194 PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
7195 if (SvREADONLY(sv) || SvGMAGICAL(sv) || !SvPOK(sv))
7198 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
7199 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
7200 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
7204 (*mgp)->mg_len = ulen;
7207 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
7208 byte length pairing. The (byte) length of the total SV is passed in too,
7209 as blen, because for some (more esoteric) SVs, the call to SvPV_const()
7210 may not have updated SvCUR, so we can't rely on reading it directly.
7212 The proffered utf8/byte length pairing isn't used if the cache already has
7213 two pairs, and swapping either for the proffered pair would increase the
7214 RMS of the intervals between known byte offsets.
7216 The cache itself consists of 4 STRLEN values
7217 0: larger UTF-8 offset
7218 1: corresponding byte offset
7219 2: smaller UTF-8 offset
7220 3: corresponding byte offset
7222 Unused cache pairs have the value 0, 0.
7223 Keeping the cache "backwards" means that the invariant of
7224 cache[0] >= cache[2] is maintained even with empty slots, which means that
7225 the code that uses it doesn't need to worry if only 1 entry has actually
7226 been set to non-zero. It also makes the "position beyond the end of the
7227 cache" logic much simpler, as the first slot is always the one to start
7231 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
7232 const STRLEN utf8, const STRLEN blen)
7236 PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
7241 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
7242 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
7243 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
7245 (*mgp)->mg_len = -1;
7249 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
7250 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
7251 (*mgp)->mg_ptr = (char *) cache;
7255 if (PL_utf8cache < 0 && SvPOKp(sv)) {
7256 /* SvPOKp() because it's possible that sv has string overloading, and
7257 therefore is a reference, hence SvPVX() is actually a pointer.
7258 This cures the (very real) symptoms of RT 69422, but I'm not actually
7259 sure whether we should even be caching the results of UTF-8
7260 operations on overloading, given that nothing stops overloading
7261 returning a different value every time it's called. */
7262 const U8 *start = (const U8 *) SvPVX_const(sv);
7263 const STRLEN realutf8 = utf8_length(start, start + byte);
7265 assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
7269 /* Cache is held with the later position first, to simplify the code
7270 that deals with unbounded ends. */
7272 ASSERT_UTF8_CACHE(cache);
7273 if (cache[1] == 0) {
7274 /* Cache is totally empty */
7277 } else if (cache[3] == 0) {
7278 if (byte > cache[1]) {
7279 /* New one is larger, so goes first. */
7280 cache[2] = cache[0];
7281 cache[3] = cache[1];
7289 #define THREEWAY_SQUARE(a,b,c,d) \
7290 ((float)((d) - (c))) * ((float)((d) - (c))) \
7291 + ((float)((c) - (b))) * ((float)((c) - (b))) \
7292 + ((float)((b) - (a))) * ((float)((b) - (a)))
7294 /* Cache has 2 slots in use, and we know three potential pairs.
7295 Keep the two that give the lowest RMS distance. Do the
7296 calculation in bytes simply because we always know the byte
7297 length. squareroot has the same ordering as the positive value,
7298 so don't bother with the actual square root. */
7299 if (byte > cache[1]) {
7300 /* New position is after the existing pair of pairs. */
7301 const float keep_earlier
7302 = THREEWAY_SQUARE(0, cache[3], byte, blen);
7303 const float keep_later
7304 = THREEWAY_SQUARE(0, cache[1], byte, blen);
7306 if (keep_later < keep_earlier) {
7307 cache[2] = cache[0];
7308 cache[3] = cache[1];
7317 else if (byte > cache[3]) {
7318 /* New position is between the existing pair of pairs. */
7319 const float keep_earlier
7320 = THREEWAY_SQUARE(0, cache[3], byte, blen);
7321 const float keep_later
7322 = THREEWAY_SQUARE(0, byte, cache[1], blen);
7324 if (keep_later < keep_earlier) {
7334 /* New position is before the existing pair of pairs. */
7335 const float keep_earlier
7336 = THREEWAY_SQUARE(0, byte, cache[3], blen);
7337 const float keep_later
7338 = THREEWAY_SQUARE(0, byte, cache[1], blen);
7340 if (keep_later < keep_earlier) {
7345 cache[0] = cache[2];
7346 cache[1] = cache[3];
7352 ASSERT_UTF8_CACHE(cache);
7355 /* We already know all of the way, now we may be able to walk back. The same
7356 assumption is made as in S_sv_pos_u2b_midway(), namely that walking
7357 backward is half the speed of walking forward. */
7359 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
7360 const U8 *end, STRLEN endu)
7362 const STRLEN forw = target - s;
7363 STRLEN backw = end - target;
7365 PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
7367 if (forw < 2 * backw) {
7368 return utf8_length(s, target);
7371 while (end > target) {
7373 while (UTF8_IS_CONTINUATION(*end)) {
7382 =for apidoc sv_pos_b2u_flags
7384 Converts the offset from a count of bytes from the start of the string, to
7385 a count of the equivalent number of UTF-8 chars. Handles type coercion.
7386 I<flags> is passed to C<SvPV_flags>, and usually should be
7387 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
7393 * sv_pos_b2u_flags() uses, like sv_pos_u2b_flags(), the mg_ptr of the
7394 * potential PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8
7399 Perl_sv_pos_b2u_flags(pTHX_ SV *const sv, STRLEN const offset, U32 flags)
7402 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
7408 PERL_ARGS_ASSERT_SV_POS_B2U_FLAGS;
7410 s = (const U8*)SvPV_flags(sv, blen, flags);
7413 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%"UVuf
7414 ", byte=%"UVuf, (UV)blen, (UV)offset);
7420 && SvTYPE(sv) >= SVt_PVMG
7421 && (mg = mg_find(sv, PERL_MAGIC_utf8)))
7424 STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7425 if (cache[1] == offset) {
7426 /* An exact match. */
7429 if (cache[3] == offset) {
7430 /* An exact match. */
7434 if (cache[1] < offset) {
7435 /* We already know part of the way. */
7436 if (mg->mg_len != -1) {
7437 /* Actually, we know the end too. */
7439 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
7440 s + blen, mg->mg_len - cache[0]);
7442 len = cache[0] + utf8_length(s + cache[1], send);
7445 else if (cache[3] < offset) {
7446 /* We're between the two cached pairs, so we do the calculation
7447 offset by the byte/utf-8 positions for the earlier pair,
7448 then add the utf-8 characters from the string start to
7450 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
7451 s + cache[1], cache[0] - cache[2])
7455 else { /* cache[3] > offset */
7456 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
7460 ASSERT_UTF8_CACHE(cache);
7462 } else if (mg->mg_len != -1) {
7463 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
7467 if (!found || PL_utf8cache < 0) {
7468 const STRLEN real_len = utf8_length(s, send);
7470 if (found && PL_utf8cache < 0)
7471 assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
7477 utf8_mg_len_cache_update(sv, &mg, len);
7479 utf8_mg_pos_cache_update(sv, &mg, offset, len, blen);
7486 =for apidoc sv_pos_b2u
7488 Converts the value pointed to by offsetp from a count of bytes from the
7489 start of the string, to a count of the equivalent number of UTF-8 chars.
7490 Handles magic and type coercion.
7492 Use C<sv_pos_b2u_flags> in preference, which correctly handles strings
7499 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
7500 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7505 Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp)
7507 PERL_ARGS_ASSERT_SV_POS_B2U;
7512 *offsetp = (I32)sv_pos_b2u_flags(sv, (STRLEN)*offsetp,
7513 SV_GMAGIC|SV_CONST_RETURN);
7517 S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
7518 STRLEN real, SV *const sv)
7520 PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
7522 /* As this is debugging only code, save space by keeping this test here,
7523 rather than inlining it in all the callers. */
7524 if (from_cache == real)
7527 /* Need to turn the assertions off otherwise we may recurse infinitely
7528 while printing error messages. */
7529 SAVEI8(PL_utf8cache);
7531 Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
7532 func, (UV) from_cache, (UV) real, SVfARG(sv));
7538 Returns a boolean indicating whether the strings in the two SVs are
7539 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7540 coerce its args to strings if necessary.
7542 =for apidoc sv_eq_flags
7544 Returns a boolean indicating whether the strings in the two SVs are
7545 identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings
7546 if necessary. If the flags include SV_GMAGIC, it handles get-magic, too.
7552 Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
7560 SV* svrecode = NULL;
7567 /* if pv1 and pv2 are the same, second SvPV_const call may
7568 * invalidate pv1 (if we are handling magic), so we may need to
7570 if (sv1 == sv2 && flags & SV_GMAGIC
7571 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
7572 pv1 = SvPV_const(sv1, cur1);
7573 sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
7575 pv1 = SvPV_flags_const(sv1, cur1, flags);
7583 pv2 = SvPV_flags_const(sv2, cur2, flags);
7585 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7586 /* Differing utf8ness.
7587 * Do not UTF8size the comparands as a side-effect. */
7590 svrecode = newSVpvn(pv2, cur2);
7591 sv_recode_to_utf8(svrecode, PL_encoding);
7592 pv2 = SvPV_const(svrecode, cur2);
7595 svrecode = newSVpvn(pv1, cur1);
7596 sv_recode_to_utf8(svrecode, PL_encoding);
7597 pv1 = SvPV_const(svrecode, cur1);
7599 /* Now both are in UTF-8. */
7601 SvREFCNT_dec_NN(svrecode);
7607 /* sv1 is the UTF-8 one */
7608 return bytes_cmp_utf8((const U8*)pv2, cur2,
7609 (const U8*)pv1, cur1) == 0;
7612 /* sv2 is the UTF-8 one */
7613 return bytes_cmp_utf8((const U8*)pv1, cur1,
7614 (const U8*)pv2, cur2) == 0;
7620 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
7622 SvREFCNT_dec(svrecode);
7630 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7631 string in C<sv1> is less than, equal to, or greater than the string in
7632 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7633 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
7635 =for apidoc sv_cmp_flags
7637 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7638 string in C<sv1> is less than, equal to, or greater than the string in
7639 C<sv2>. Is UTF-8 and 'use bytes' aware and will coerce its args to strings
7640 if necessary. If the flags include SV_GMAGIC, it handles get magic. See
7641 also C<sv_cmp_locale_flags>.
7647 Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2)
7649 return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
7653 Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2,
7658 const char *pv1, *pv2;
7660 SV *svrecode = NULL;
7667 pv1 = SvPV_flags_const(sv1, cur1, flags);
7674 pv2 = SvPV_flags_const(sv2, cur2, flags);
7676 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7677 /* Differing utf8ness.
7678 * Do not UTF8size the comparands as a side-effect. */
7681 svrecode = newSVpvn(pv2, cur2);
7682 sv_recode_to_utf8(svrecode, PL_encoding);
7683 pv2 = SvPV_const(svrecode, cur2);
7686 const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2,
7687 (const U8*)pv1, cur1);
7688 return retval ? retval < 0 ? -1 : +1 : 0;
7693 svrecode = newSVpvn(pv1, cur1);
7694 sv_recode_to_utf8(svrecode, PL_encoding);
7695 pv1 = SvPV_const(svrecode, cur1);
7698 const int retval = bytes_cmp_utf8((const U8*)pv1, cur1,
7699 (const U8*)pv2, cur2);
7700 return retval ? retval < 0 ? -1 : +1 : 0;
7706 cmp = cur2 ? -1 : 0;
7710 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
7713 cmp = retval < 0 ? -1 : 1;
7714 } else if (cur1 == cur2) {
7717 cmp = cur1 < cur2 ? -1 : 1;
7721 SvREFCNT_dec(svrecode);
7727 =for apidoc sv_cmp_locale
7729 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7730 'use bytes' aware, handles get magic, and will coerce its args to strings
7731 if necessary. See also C<sv_cmp>.
7733 =for apidoc sv_cmp_locale_flags
7735 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7736 'use bytes' aware and will coerce its args to strings if necessary. If the
7737 flags contain SV_GMAGIC, it handles get magic. See also C<sv_cmp_flags>.
7743 Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2)
7745 return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
7749 Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2,
7753 #ifdef USE_LOCALE_COLLATE
7759 if (PL_collation_standard)
7763 pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
7765 pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
7767 if (!pv1 || !len1) {
7778 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
7781 return retval < 0 ? -1 : 1;
7784 * When the result of collation is equality, that doesn't mean
7785 * that there are no differences -- some locales exclude some
7786 * characters from consideration. So to avoid false equalities,
7787 * we use the raw string as a tiebreaker.
7793 #endif /* USE_LOCALE_COLLATE */
7795 return sv_cmp(sv1, sv2);
7799 #ifdef USE_LOCALE_COLLATE
7802 =for apidoc sv_collxfrm
7804 This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag. See
7805 C<sv_collxfrm_flags>.
7807 =for apidoc sv_collxfrm_flags
7809 Add Collate Transform magic to an SV if it doesn't already have it. If the
7810 flags contain SV_GMAGIC, it handles get-magic.
7812 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
7813 scalar data of the variable, but transformed to such a format that a normal
7814 memory comparison can be used to compare the data according to the locale
7821 Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
7826 PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
7828 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
7829 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
7835 Safefree(mg->mg_ptr);
7836 s = SvPV_flags_const(sv, len, flags);
7837 if ((xf = mem_collxfrm(s, len, &xlen))) {
7839 #ifdef PERL_OLD_COPY_ON_WRITE
7841 sv_force_normal_flags(sv, 0);
7843 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
7857 if (mg && mg->mg_ptr) {
7859 return mg->mg_ptr + sizeof(PL_collation_ix);
7867 #endif /* USE_LOCALE_COLLATE */
7870 S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7872 SV * const tsv = newSV(0);
7875 sv_gets(tsv, fp, 0);
7876 sv_utf8_upgrade_nomg(tsv);
7877 SvCUR_set(sv,append);
7880 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7884 S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7887 const STRLEN recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7888 /* Grab the size of the record we're getting */
7889 char *buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7897 /* With a true, record-oriented file on VMS, we need to use read directly
7898 * to ensure that we respect RMS record boundaries. The user is responsible
7899 * for providing a PL_rs value that corresponds to the FAB$W_MRS (maximum
7900 * record size) field. N.B. This is likely to produce invalid results on
7901 * varying-width character data when a record ends mid-character.
7903 fd = PerlIO_fileno(fp);
7905 && PerlLIO_fstat(fd, &st) == 0
7906 && (st.st_fab_rfm == FAB$C_VAR
7907 || st.st_fab_rfm == FAB$C_VFC
7908 || st.st_fab_rfm == FAB$C_FIX)) {
7910 bytesread = PerlLIO_read(fd, buffer, recsize);
7912 else /* in-memory file from PerlIO::Scalar
7913 * or not a record-oriented file
7917 bytesread = PerlIO_read(fp, buffer, recsize);
7919 /* At this point, the logic in sv_get() means that sv will
7920 be treated as utf-8 if the handle is utf8.
7922 if (PerlIO_isutf8(fp) && bytesread > 0) {
7923 char *bend = buffer + bytesread;
7924 char *bufp = buffer;
7925 size_t charcount = 0;
7926 bool charstart = TRUE;
7929 while (charcount < recsize) {
7930 /* count accumulated characters */
7931 while (bufp < bend) {
7933 skip = UTF8SKIP(bufp);
7935 if (bufp + skip > bend) {
7936 /* partial at the end */
7947 if (charcount < recsize) {
7949 STRLEN bufp_offset = bufp - buffer;
7950 SSize_t morebytesread;
7952 /* originally I read enough to fill any incomplete
7953 character and the first byte of the next
7954 character if needed, but if there's many
7955 multi-byte encoded characters we're going to be
7956 making a read call for every character beyond
7957 the original read size.
7959 So instead, read the rest of the character if
7960 any, and enough bytes to match at least the
7961 start bytes for each character we're going to
7965 readsize = recsize - charcount;
7967 readsize = skip - (bend - bufp) + recsize - charcount - 1;
7968 buffer = SvGROW(sv, append + bytesread + readsize + 1) + append;
7969 bend = buffer + bytesread;
7970 morebytesread = PerlIO_read(fp, bend, readsize);
7971 if (morebytesread <= 0) {
7972 /* we're done, if we still have incomplete
7973 characters the check code in sv_gets() will
7976 I'd originally considered doing
7977 PerlIO_ungetc() on all but the lead
7978 character of the incomplete character, but
7979 read() doesn't do that, so I don't.
7984 /* prepare to scan some more */
7985 bytesread += morebytesread;
7986 bend = buffer + bytesread;
7987 bufp = buffer + bufp_offset;
7995 SvCUR_set(sv, bytesread + append);
7996 buffer[bytesread] = '\0';
7997 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
8003 Get a line from the filehandle and store it into the SV, optionally
8004 appending to the currently-stored string. If C<append> is not 0, the
8005 line is appended to the SV instead of overwriting it. C<append> should
8006 be set to the byte offset that the appended string should start at
8007 in the SV (typically, C<SvCUR(sv)> is a suitable choice).
8013 Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
8024 PERL_ARGS_ASSERT_SV_GETS;
8026 if (SvTHINKFIRST(sv))
8027 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
8028 /* XXX. If you make this PVIV, then copy on write can copy scalars read
8030 However, perlbench says it's slower, because the existing swipe code
8031 is faster than copy on write.
8032 Swings and roundabouts. */
8033 SvUPGRADE(sv, SVt_PV);
8036 if (PerlIO_isutf8(fp)) {
8038 sv_utf8_upgrade_nomg(sv);
8039 sv_pos_u2b(sv,&append,0);
8041 } else if (SvUTF8(sv)) {
8042 return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append);
8050 if (PerlIO_isutf8(fp))
8053 if (IN_PERL_COMPILETIME) {
8054 /* we always read code in line mode */
8058 else if (RsSNARF(PL_rs)) {
8059 /* If it is a regular disk file use size from stat() as estimate
8060 of amount we are going to read -- may result in mallocing
8061 more memory than we really need if the layers below reduce
8062 the size we read (e.g. CRLF or a gzip layer).
8065 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
8066 const Off_t offset = PerlIO_tell(fp);
8067 if (offset != (Off_t) -1 && st.st_size + append > offset) {
8068 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
8074 else if (RsRECORD(PL_rs)) {
8075 return S_sv_gets_read_record(aTHX_ sv, fp, append);
8077 else if (RsPARA(PL_rs)) {
8083 /* Get $/ i.e. PL_rs into same encoding as stream wants */
8084 if (PerlIO_isutf8(fp)) {
8085 rsptr = SvPVutf8(PL_rs, rslen);
8088 if (SvUTF8(PL_rs)) {
8089 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
8090 Perl_croak(aTHX_ "Wide character in $/");
8093 rsptr = SvPV_const(PL_rs, rslen);
8097 rslast = rslen ? rsptr[rslen - 1] : '\0';
8099 if (rspara) { /* have to do this both before and after */
8100 do { /* to make sure file boundaries work right */
8103 i = PerlIO_getc(fp);
8107 PerlIO_ungetc(fp,i);
8113 /* See if we know enough about I/O mechanism to cheat it ! */
8115 /* This used to be #ifdef test - it is made run-time test for ease
8116 of abstracting out stdio interface. One call should be cheap
8117 enough here - and may even be a macro allowing compile
8121 if (PerlIO_fast_gets(fp)) {
8124 * We're going to steal some values from the stdio struct
8125 * and put EVERYTHING in the innermost loop into registers.
8131 #if defined(VMS) && defined(PERLIO_IS_STDIO)
8132 /* An ungetc()d char is handled separately from the regular
8133 * buffer, so we getc() it back out and stuff it in the buffer.
8135 i = PerlIO_getc(fp);
8136 if (i == EOF) return 0;
8137 *(--((*fp)->_ptr)) = (unsigned char) i;
8141 /* Here is some breathtakingly efficient cheating */
8143 cnt = PerlIO_get_cnt(fp); /* get count into register */
8144 /* make sure we have the room */
8145 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
8146 /* Not room for all of it
8147 if we are looking for a separator and room for some
8149 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
8150 /* just process what we have room for */
8151 shortbuffered = cnt - SvLEN(sv) + append + 1;
8152 cnt -= shortbuffered;
8156 /* remember that cnt can be negative */
8157 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
8162 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
8163 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
8164 DEBUG_P(PerlIO_printf(Perl_debug_log,
8165 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
8166 DEBUG_P(PerlIO_printf(Perl_debug_log,
8167 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%zd, base=%"
8169 PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
8170 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
8175 while (cnt > 0) { /* this | eat */
8177 if ((*bp++ = *ptr++) == rslast) /* really | dust */
8178 goto thats_all_folks; /* screams | sed :-) */
8182 Copy(ptr, bp, cnt, char); /* this | eat */
8183 bp += cnt; /* screams | dust */
8184 ptr += cnt; /* louder | sed :-) */
8186 assert (!shortbuffered);
8187 goto cannot_be_shortbuffered;
8191 if (shortbuffered) { /* oh well, must extend */
8192 cnt = shortbuffered;
8194 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
8196 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
8197 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
8201 cannot_be_shortbuffered:
8202 DEBUG_P(PerlIO_printf(Perl_debug_log,
8203 "Screamer: going to getc, ptr=%"UVuf", cnt=%zd\n",
8205 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
8207 DEBUG_Pv(PerlIO_printf(Perl_debug_log,
8208 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf"\n",
8209 PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
8210 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
8212 /* This used to call 'filbuf' in stdio form, but as that behaves like
8213 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
8214 another abstraction. */
8215 i = PerlIO_getc(fp); /* get more characters */
8217 DEBUG_Pv(PerlIO_printf(Perl_debug_log,
8218 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf"\n",
8219 PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
8220 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
8222 cnt = PerlIO_get_cnt(fp);
8223 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
8224 DEBUG_P(PerlIO_printf(Perl_debug_log,
8225 "Screamer: after getc, ptr=%"UVuf", cnt=%zd\n",
8228 if (i == EOF) /* all done for ever? */
8229 goto thats_really_all_folks;
8231 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
8233 SvGROW(sv, bpx + cnt + 2);
8234 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
8236 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
8238 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
8239 goto thats_all_folks;
8243 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
8244 memNE((char*)bp - rslen, rsptr, rslen))
8245 goto screamer; /* go back to the fray */
8246 thats_really_all_folks:
8248 cnt += shortbuffered;
8249 DEBUG_P(PerlIO_printf(Perl_debug_log,
8250 "Screamer: quitting, ptr=%"UVuf", cnt=%zd\n",PTR2UV(ptr),cnt));
8251 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
8252 DEBUG_P(PerlIO_printf(Perl_debug_log,
8253 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf
8255 PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
8256 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
8258 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
8259 DEBUG_P(PerlIO_printf(Perl_debug_log,
8260 "Screamer: done, len=%ld, string=|%.*s|\n",
8261 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
8265 /*The big, slow, and stupid way. */
8266 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
8267 STDCHAR *buf = NULL;
8268 Newx(buf, 8192, STDCHAR);
8276 const STDCHAR * const bpe = buf + sizeof(buf);
8278 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
8279 ; /* keep reading */
8283 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
8284 /* Accommodate broken VAXC compiler, which applies U8 cast to
8285 * both args of ?: operator, causing EOF to change into 255
8288 i = (U8)buf[cnt - 1];
8294 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
8296 sv_catpvn_nomg(sv, (char *) buf, cnt);
8298 sv_setpvn(sv, (char *) buf, cnt); /* "nomg" is implied */
8300 if (i != EOF && /* joy */
8302 SvCUR(sv) < rslen ||
8303 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
8307 * If we're reading from a TTY and we get a short read,
8308 * indicating that the user hit his EOF character, we need
8309 * to notice it now, because if we try to read from the TTY
8310 * again, the EOF condition will disappear.
8312 * The comparison of cnt to sizeof(buf) is an optimization
8313 * that prevents unnecessary calls to feof().
8317 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
8321 #ifdef USE_HEAP_INSTEAD_OF_STACK
8326 if (rspara) { /* have to do this both before and after */
8327 while (i != EOF) { /* to make sure file boundaries work right */
8328 i = PerlIO_getc(fp);
8330 PerlIO_ungetc(fp,i);
8336 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
8342 Auto-increment of the value in the SV, doing string to numeric conversion
8343 if necessary. Handles 'get' magic and operator overloading.
8349 Perl_sv_inc(pTHX_ SV *const sv)
8358 =for apidoc sv_inc_nomg
8360 Auto-increment of the value in the SV, doing string to numeric conversion
8361 if necessary. Handles operator overloading. Skips handling 'get' magic.
8367 Perl_sv_inc_nomg(pTHX_ SV *const sv)
8375 if (SvTHINKFIRST(sv)) {
8376 if (SvREADONLY(sv)) {
8377 Perl_croak_no_modify();
8381 if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg))
8383 i = PTR2IV(SvRV(sv));
8387 else sv_force_normal_flags(sv, 0);
8389 flags = SvFLAGS(sv);
8390 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
8391 /* It's (privately or publicly) a float, but not tested as an
8392 integer, so test it to see. */
8394 flags = SvFLAGS(sv);
8396 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
8397 /* It's publicly an integer, or privately an integer-not-float */
8398 #ifdef PERL_PRESERVE_IVUV
8402 if (SvUVX(sv) == UV_MAX)
8403 sv_setnv(sv, UV_MAX_P1);
8405 (void)SvIOK_only_UV(sv);
8406 SvUV_set(sv, SvUVX(sv) + 1);
8408 if (SvIVX(sv) == IV_MAX)
8409 sv_setuv(sv, (UV)IV_MAX + 1);
8411 (void)SvIOK_only(sv);
8412 SvIV_set(sv, SvIVX(sv) + 1);
8417 if (flags & SVp_NOK) {
8418 const NV was = SvNVX(sv);
8419 if (NV_OVERFLOWS_INTEGERS_AT &&
8420 was >= NV_OVERFLOWS_INTEGERS_AT) {
8421 /* diag_listed_as: Lost precision when %s %f by 1 */
8422 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
8423 "Lost precision when incrementing %" NVff " by 1",
8426 (void)SvNOK_only(sv);
8427 SvNV_set(sv, was + 1.0);
8431 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
8432 if ((flags & SVTYPEMASK) < SVt_PVIV)
8433 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
8434 (void)SvIOK_only(sv);
8439 while (isALPHA(*d)) d++;
8440 while (isDIGIT(*d)) d++;
8441 if (d < SvEND(sv)) {
8442 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8443 #ifdef PERL_PRESERVE_IVUV
8444 /* Got to punt this as an integer if needs be, but we don't issue
8445 warnings. Probably ought to make the sv_iv_please() that does
8446 the conversion if possible, and silently. */
8447 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
8448 /* Need to try really hard to see if it's an integer.
8449 9.22337203685478e+18 is an integer.
8450 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8451 so $a="9.22337203685478e+18"; $a+0; $a++
8452 needs to be the same as $a="9.22337203685478e+18"; $a++
8459 /* sv_2iv *should* have made this an NV */
8460 if (flags & SVp_NOK) {
8461 (void)SvNOK_only(sv);
8462 SvNV_set(sv, SvNVX(sv) + 1.0);
8465 /* I don't think we can get here. Maybe I should assert this
8466 And if we do get here I suspect that sv_setnv will croak. NWC
8468 #if defined(USE_LONG_DOUBLE)
8469 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",
8470 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8472 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8473 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8476 #endif /* PERL_PRESERVE_IVUV */
8477 if (!numtype && ckWARN(WARN_NUMERIC))
8478 not_incrementable(sv);
8479 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
8483 while (d >= SvPVX_const(sv)) {
8491 /* MKS: The original code here died if letters weren't consecutive.
8492 * at least it didn't have to worry about non-C locales. The
8493 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
8494 * arranged in order (although not consecutively) and that only
8495 * [A-Za-z] are accepted by isALPHA in the C locale.
8497 if (*d != 'z' && *d != 'Z') {
8498 do { ++*d; } while (!isALPHA(*d));
8501 *(d--) -= 'z' - 'a';
8506 *(d--) -= 'z' - 'a' + 1;
8510 /* oh,oh, the number grew */
8511 SvGROW(sv, SvCUR(sv) + 2);
8512 SvCUR_set(sv, SvCUR(sv) + 1);
8513 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
8524 Auto-decrement of the value in the SV, doing string to numeric conversion
8525 if necessary. Handles 'get' magic and operator overloading.
8531 Perl_sv_dec(pTHX_ SV *const sv)
8541 =for apidoc sv_dec_nomg
8543 Auto-decrement of the value in the SV, doing string to numeric conversion
8544 if necessary. Handles operator overloading. Skips handling 'get' magic.
8550 Perl_sv_dec_nomg(pTHX_ SV *const sv)
8557 if (SvTHINKFIRST(sv)) {
8558 if (SvREADONLY(sv)) {
8559 Perl_croak_no_modify();
8563 if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg))
8565 i = PTR2IV(SvRV(sv));
8569 else sv_force_normal_flags(sv, 0);
8571 /* Unlike sv_inc we don't have to worry about string-never-numbers
8572 and keeping them magic. But we mustn't warn on punting */
8573 flags = SvFLAGS(sv);
8574 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
8575 /* It's publicly an integer, or privately an integer-not-float */
8576 #ifdef PERL_PRESERVE_IVUV
8580 if (SvUVX(sv) == 0) {
8581 (void)SvIOK_only(sv);
8585 (void)SvIOK_only_UV(sv);
8586 SvUV_set(sv, SvUVX(sv) - 1);
8589 if (SvIVX(sv) == IV_MIN) {
8590 sv_setnv(sv, (NV)IV_MIN);
8594 (void)SvIOK_only(sv);
8595 SvIV_set(sv, SvIVX(sv) - 1);
8600 if (flags & SVp_NOK) {
8603 const NV was = SvNVX(sv);
8604 if (NV_OVERFLOWS_INTEGERS_AT &&
8605 was <= -NV_OVERFLOWS_INTEGERS_AT) {
8606 /* diag_listed_as: Lost precision when %s %f by 1 */
8607 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
8608 "Lost precision when decrementing %" NVff " by 1",
8611 (void)SvNOK_only(sv);
8612 SvNV_set(sv, was - 1.0);
8616 if (!(flags & SVp_POK)) {
8617 if ((flags & SVTYPEMASK) < SVt_PVIV)
8618 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
8620 (void)SvIOK_only(sv);
8623 #ifdef PERL_PRESERVE_IVUV
8625 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8626 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
8627 /* Need to try really hard to see if it's an integer.
8628 9.22337203685478e+18 is an integer.
8629 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8630 so $a="9.22337203685478e+18"; $a+0; $a--
8631 needs to be the same as $a="9.22337203685478e+18"; $a--
8638 /* sv_2iv *should* have made this an NV */
8639 if (flags & SVp_NOK) {
8640 (void)SvNOK_only(sv);
8641 SvNV_set(sv, SvNVX(sv) - 1.0);
8644 /* I don't think we can get here. Maybe I should assert this
8645 And if we do get here I suspect that sv_setnv will croak. NWC
8647 #if defined(USE_LONG_DOUBLE)
8648 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",
8649 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8651 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8652 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8656 #endif /* PERL_PRESERVE_IVUV */
8657 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
8660 /* this define is used to eliminate a chunk of duplicated but shared logic
8661 * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
8662 * used anywhere but here - yves
8664 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
8667 PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
8671 =for apidoc sv_mortalcopy
8673 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
8674 The new SV is marked as mortal. It will be destroyed "soon", either by an
8675 explicit call to FREETMPS, or by an implicit call at places such as
8676 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
8681 /* Make a string that will exist for the duration of the expression
8682 * evaluation. Actually, it may have to last longer than that, but
8683 * hopefully we won't free it until it has been assigned to a
8684 * permanent location. */
8687 Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags)
8692 if (flags & SV_GMAGIC)
8693 SvGETMAGIC(oldstr); /* before new_SV, in case it dies */
8695 sv_setsv_flags(sv,oldstr,flags & ~SV_GMAGIC);
8696 PUSH_EXTEND_MORTAL__SV_C(sv);
8702 =for apidoc sv_newmortal
8704 Creates a new null SV which is mortal. The reference count of the SV is
8705 set to 1. It will be destroyed "soon", either by an explicit call to
8706 FREETMPS, or by an implicit call at places such as statement boundaries.
8707 See also C<sv_mortalcopy> and C<sv_2mortal>.
8713 Perl_sv_newmortal(pTHX)
8719 SvFLAGS(sv) = SVs_TEMP;
8720 PUSH_EXTEND_MORTAL__SV_C(sv);
8726 =for apidoc newSVpvn_flags
8728 Creates a new SV and copies a string into it. The reference count for the
8729 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
8730 string. You are responsible for ensuring that the source string is at least
8731 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
8732 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
8733 If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before
8734 returning. If C<SVf_UTF8> is set, C<s>
8735 is considered to be in UTF-8 and the
8736 C<SVf_UTF8> flag will be set on the new SV.
8737 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
8739 #define newSVpvn_utf8(s, len, u) \
8740 newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
8746 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
8751 /* All the flags we don't support must be zero.
8752 And we're new code so I'm going to assert this from the start. */
8753 assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
8755 sv_setpvn(sv,s,len);
8757 /* This code used to do a sv_2mortal(), however we now unroll the call to
8758 * sv_2mortal() and do what it does ourselves here. Since we have asserted
8759 * that flags can only have the SVf_UTF8 and/or SVs_TEMP flags set above we
8760 * can use it to enable the sv flags directly (bypassing SvTEMP_on), which
8761 * in turn means we dont need to mask out the SVf_UTF8 flag below, which
8762 * means that we eliminate quite a few steps than it looks - Yves
8763 * (explaining patch by gfx) */
8765 SvFLAGS(sv) |= flags;
8767 if(flags & SVs_TEMP){
8768 PUSH_EXTEND_MORTAL__SV_C(sv);
8775 =for apidoc sv_2mortal
8777 Marks an existing SV as mortal. The SV will be destroyed "soon", either
8778 by an explicit call to FREETMPS, or by an implicit call at places such as
8779 statement boundaries. SvTEMP() is turned on which means that the SV's
8780 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
8781 and C<sv_mortalcopy>.
8787 Perl_sv_2mortal(pTHX_ SV *const sv)
8794 PUSH_EXTEND_MORTAL__SV_C(sv);
8802 Creates a new SV and copies a string into it. The reference count for the
8803 SV is set to 1. If C<len> is zero, Perl will compute the length using
8804 strlen(). For efficiency, consider using C<newSVpvn> instead.
8810 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
8816 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
8821 =for apidoc newSVpvn
8823 Creates a new SV and copies a buffer into it, which may contain NUL characters
8824 (C<\0>) and other binary data. The reference count for the SV is set to 1.
8825 Note that if C<len> is zero, Perl will create a zero length (Perl) string. You
8826 are responsible for ensuring that the source buffer is at least
8827 C<len> bytes long. If the C<buffer> argument is NULL the new SV will be
8834 Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len)
8840 sv_setpvn(sv,buffer,len);
8845 =for apidoc newSVhek
8847 Creates a new SV from the hash key structure. It will generate scalars that
8848 point to the shared string table where possible. Returns a new (undefined)
8849 SV if the hek is NULL.
8855 Perl_newSVhek(pTHX_ const HEK *const hek)
8865 if (HEK_LEN(hek) == HEf_SVKEY) {
8866 return newSVsv(*(SV**)HEK_KEY(hek));
8868 const int flags = HEK_FLAGS(hek);
8869 if (flags & HVhek_WASUTF8) {
8871 Andreas would like keys he put in as utf8 to come back as utf8
8873 STRLEN utf8_len = HEK_LEN(hek);
8874 SV * const sv = newSV_type(SVt_PV);
8875 char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
8876 /* bytes_to_utf8() allocates a new string, which we can repurpose: */
8877 sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
8880 } else if (flags & HVhek_UNSHARED) {
8881 /* A hash that isn't using shared hash keys has to have
8882 the flag in every key so that we know not to try to call
8883 share_hek_hek on it. */
8885 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
8890 /* This will be overwhelminly the most common case. */
8892 /* Inline most of newSVpvn_share(), because share_hek_hek() is far
8893 more efficient than sharepvn(). */
8897 sv_upgrade(sv, SVt_PV);
8898 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
8899 SvCUR_set(sv, HEK_LEN(hek));
8911 =for apidoc newSVpvn_share
8913 Creates a new SV with its SvPVX_const pointing to a shared string in the string
8914 table. If the string does not already exist in the table, it is
8915 created first. Turns on the SvIsCOW flag (or READONLY
8916 and FAKE in 5.16 and earlier). If the C<hash> parameter
8917 is non-zero, that value is used; otherwise the hash is computed.
8918 The string's hash can later be retrieved from the SV
8919 with the C<SvSHARED_HASH()> macro. The idea here is
8920 that as the string table is used for shared hash keys these strings will have
8921 SvPVX_const == HeKEY and hash lookup will avoid string compare.
8927 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
8931 bool is_utf8 = FALSE;
8932 const char *const orig_src = src;
8935 STRLEN tmplen = -len;
8937 /* See the note in hv.c:hv_fetch() --jhi */
8938 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
8942 PERL_HASH(hash, src, len);
8944 /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
8945 changes here, update it there too. */
8946 sv_upgrade(sv, SVt_PV);
8947 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
8954 if (src != orig_src)
8960 =for apidoc newSVpv_share
8962 Like C<newSVpvn_share>, but takes a nul-terminated string instead of a
8969 Perl_newSVpv_share(pTHX_ const char *src, U32 hash)
8971 return newSVpvn_share(src, strlen(src), hash);
8974 #if defined(PERL_IMPLICIT_CONTEXT)
8976 /* pTHX_ magic can't cope with varargs, so this is a no-context
8977 * version of the main function, (which may itself be aliased to us).
8978 * Don't access this version directly.
8982 Perl_newSVpvf_nocontext(const char *const pat, ...)
8988 PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
8990 va_start(args, pat);
8991 sv = vnewSVpvf(pat, &args);
8998 =for apidoc newSVpvf
9000 Creates a new SV and initializes it with the string formatted like
9007 Perl_newSVpvf(pTHX_ const char *const pat, ...)
9012 PERL_ARGS_ASSERT_NEWSVPVF;
9014 va_start(args, pat);
9015 sv = vnewSVpvf(pat, &args);
9020 /* backend for newSVpvf() and newSVpvf_nocontext() */
9023 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
9028 PERL_ARGS_ASSERT_VNEWSVPVF;
9031 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9038 Creates a new SV and copies a floating point value into it.
9039 The reference count for the SV is set to 1.
9045 Perl_newSVnv(pTHX_ const NV n)
9058 Creates a new SV and copies an integer into it. The reference count for the
9065 Perl_newSViv(pTHX_ const IV i)
9078 Creates a new SV and copies an unsigned integer into it.
9079 The reference count for the SV is set to 1.
9085 Perl_newSVuv(pTHX_ const UV u)
9096 =for apidoc newSV_type
9098 Creates a new SV, of the type specified. The reference count for the new SV
9105 Perl_newSV_type(pTHX_ const svtype type)
9110 sv_upgrade(sv, type);
9115 =for apidoc newRV_noinc
9117 Creates an RV wrapper for an SV. The reference count for the original
9118 SV is B<not> incremented.
9124 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
9127 SV *sv = newSV_type(SVt_IV);
9129 PERL_ARGS_ASSERT_NEWRV_NOINC;
9132 SvRV_set(sv, tmpRef);
9137 /* newRV_inc is the official function name to use now.
9138 * newRV_inc is in fact #defined to newRV in sv.h
9142 Perl_newRV(pTHX_ SV *const sv)
9146 PERL_ARGS_ASSERT_NEWRV;
9148 return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
9154 Creates a new SV which is an exact duplicate of the original SV.
9161 Perl_newSVsv(pTHX_ SV *const old)
9168 if (SvTYPE(old) == (svtype)SVTYPEMASK) {
9169 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
9172 /* Do this here, otherwise we leak the new SV if this croaks. */
9175 /* SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
9176 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
9177 sv_setsv_flags(sv, old, SV_NOSTEAL);
9182 =for apidoc sv_reset
9184 Underlying implementation for the C<reset> Perl function.
9185 Note that the perl-level function is vaguely deprecated.
9191 Perl_sv_reset(pTHX_ const char *s, HV *const stash)
9193 PERL_ARGS_ASSERT_SV_RESET;
9195 sv_resetpvn(*s ? s : NULL, strlen(s), stash);
9199 Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash)
9202 char todo[PERL_UCHAR_MAX+1];
9205 if (!stash || SvTYPE(stash) != SVt_PVHV)
9208 if (!s) { /* reset ?? searches */
9209 MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
9211 const U32 count = mg->mg_len / sizeof(PMOP**);
9212 PMOP **pmp = (PMOP**) mg->mg_ptr;
9213 PMOP *const *const end = pmp + count;
9217 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
9219 (*pmp)->op_pmflags &= ~PMf_USED;
9227 /* reset variables */
9229 if (!HvARRAY(stash))
9232 Zero(todo, 256, char);
9236 I32 i = (unsigned char)*s;
9240 max = (unsigned char)*s++;
9241 for ( ; i <= max; i++) {
9244 for (i = 0; i <= (I32) HvMAX(stash); i++) {
9246 for (entry = HvARRAY(stash)[i];
9248 entry = HeNEXT(entry))
9253 if (!todo[(U8)*HeKEY(entry)])
9255 gv = MUTABLE_GV(HeVAL(entry));
9257 if (sv && !SvREADONLY(sv)) {
9258 SV_CHECK_THINKFIRST_COW_DROP(sv);
9259 if (!isGV(sv)) SvOK_off(sv);
9264 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
9275 Using various gambits, try to get an IO from an SV: the IO slot if its a
9276 GV; or the recursive result if we're an RV; or the IO slot of the symbol
9277 named after the PV if we're a string.
9279 'Get' magic is ignored on the sv passed in, but will be called on
9280 C<SvRV(sv)> if sv is an RV.
9286 Perl_sv_2io(pTHX_ SV *const sv)
9291 PERL_ARGS_ASSERT_SV_2IO;
9293 switch (SvTYPE(sv)) {
9295 io = MUTABLE_IO(sv);
9299 if (isGV_with_GP(sv)) {
9300 gv = MUTABLE_GV(sv);
9303 Perl_croak(aTHX_ "Bad filehandle: %"HEKf,
9304 HEKfARG(GvNAME_HEK(gv)));
9310 Perl_croak(aTHX_ PL_no_usym, "filehandle");
9312 SvGETMAGIC(SvRV(sv));
9313 return sv_2io(SvRV(sv));
9315 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
9322 if (SvGMAGICAL(sv)) {
9323 newsv = sv_newmortal();
9324 sv_setsv_nomg(newsv, sv);
9326 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(newsv));
9336 Using various gambits, try to get a CV from an SV; in addition, try if
9337 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
9338 The flags in C<lref> are passed to gv_fetchsv.
9344 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
9350 PERL_ARGS_ASSERT_SV_2CV;
9357 switch (SvTYPE(sv)) {
9361 return MUTABLE_CV(sv);
9371 sv = amagic_deref_call(sv, to_cv_amg);
9374 if (SvTYPE(sv) == SVt_PVCV) {
9375 cv = MUTABLE_CV(sv);
9380 else if(SvGETMAGIC(sv), isGV_with_GP(sv))
9381 gv = MUTABLE_GV(sv);
9383 Perl_croak(aTHX_ "Not a subroutine reference");
9385 else if (isGV_with_GP(sv)) {
9386 gv = MUTABLE_GV(sv);
9389 gv = gv_fetchsv_nomg(sv, lref, SVt_PVCV);
9396 /* Some flags to gv_fetchsv mean don't really create the GV */
9397 if (!isGV_with_GP(gv)) {
9402 if (lref & ~GV_ADDMG && !GvCVu(gv)) {
9403 /* XXX this is probably not what they think they're getting.
9404 * It has the same effect as "sub name;", i.e. just a forward
9415 Returns true if the SV has a true value by Perl's rules.
9416 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
9417 instead use an in-line version.
9423 Perl_sv_true(pTHX_ SV *const sv)
9428 const XPV* const tXpv = (XPV*)SvANY(sv);
9430 (tXpv->xpv_cur > 1 ||
9431 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
9438 return SvIVX(sv) != 0;
9441 return SvNVX(sv) != 0.0;
9443 return sv_2bool(sv);
9449 =for apidoc sv_pvn_force
9451 Get a sensible string out of the SV somehow.
9452 A private implementation of the C<SvPV_force> macro for compilers which
9453 can't cope with complex macro expressions. Always use the macro instead.
9455 =for apidoc sv_pvn_force_flags
9457 Get a sensible string out of the SV somehow.
9458 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
9459 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
9460 implemented in terms of this function.
9461 You normally want to use the various wrapper macros instead: see
9462 C<SvPV_force> and C<SvPV_force_nomg>
9468 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
9472 PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
9474 if (flags & SV_GMAGIC) SvGETMAGIC(sv);
9475 if (SvTHINKFIRST(sv) && (!SvROK(sv) || SvREADONLY(sv)))
9476 sv_force_normal_flags(sv, 0);
9486 if (SvTYPE(sv) > SVt_PVLV
9487 || isGV_with_GP(sv))
9488 /* diag_listed_as: Can't coerce %s to %s in %s */
9489 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
9491 s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC);
9498 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
9501 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
9502 SvGROW(sv, len + 1);
9503 Move(s,SvPVX(sv),len,char);
9505 SvPVX(sv)[len] = '\0';
9508 SvPOK_on(sv); /* validate pointer */
9510 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
9511 PTR2UV(sv),SvPVX_const(sv)));
9514 (void)SvPOK_only_UTF8(sv);
9515 return SvPVX_mutable(sv);
9519 =for apidoc sv_pvbyten_force
9521 The backend for the C<SvPVbytex_force> macro. Always use the macro
9528 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
9530 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
9532 sv_pvn_force(sv,lp);
9533 sv_utf8_downgrade(sv,0);
9539 =for apidoc sv_pvutf8n_force
9541 The backend for the C<SvPVutf8x_force> macro. Always use the macro
9548 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
9550 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
9553 sv_utf8_upgrade_nomg(sv);
9559 =for apidoc sv_reftype
9561 Returns a string describing what the SV is a reference to.
9567 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
9569 PERL_ARGS_ASSERT_SV_REFTYPE;
9570 if (ob && SvOBJECT(sv)) {
9571 return SvPV_nolen_const(sv_ref(NULL, sv, ob));
9574 switch (SvTYPE(sv)) {
9589 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
9590 /* tied lvalues should appear to be
9591 * scalars for backwards compatibility */
9592 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
9593 ? "SCALAR" : "LVALUE");
9594 case SVt_PVAV: return "ARRAY";
9595 case SVt_PVHV: return "HASH";
9596 case SVt_PVCV: return "CODE";
9597 case SVt_PVGV: return (char *) (isGV_with_GP(sv)
9598 ? "GLOB" : "SCALAR");
9599 case SVt_PVFM: return "FORMAT";
9600 case SVt_PVIO: return "IO";
9601 case SVt_INVLIST: return "INVLIST";
9602 case SVt_REGEXP: return "REGEXP";
9603 default: return "UNKNOWN";
9611 Returns a SV describing what the SV passed in is a reference to.
9617 Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob)
9619 PERL_ARGS_ASSERT_SV_REF;
9622 dst = sv_newmortal();
9624 if (ob && SvOBJECT(sv)) {
9625 HvNAME_get(SvSTASH(sv))
9626 ? sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)))
9627 : sv_setpvn(dst, "__ANON__", 8);
9630 const char * reftype = sv_reftype(sv, 0);
9631 sv_setpv(dst, reftype);
9637 =for apidoc sv_isobject
9639 Returns a boolean indicating whether the SV is an RV pointing to a blessed
9640 object. If the SV is not an RV, or if the object is not blessed, then this
9647 Perl_sv_isobject(pTHX_ SV *sv)
9663 Returns a boolean indicating whether the SV is blessed into the specified
9664 class. This does not check for subtypes; use C<sv_derived_from> to verify
9665 an inheritance relationship.
9671 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
9675 PERL_ARGS_ASSERT_SV_ISA;
9685 hvname = HvNAME_get(SvSTASH(sv));
9689 return strEQ(hvname, name);
9695 Creates a new SV for the existing RV, C<rv>, to point to. If C<rv> is not an
9696 RV then it will be upgraded to one. If C<classname> is non-null then the new
9697 SV will be blessed in the specified package. The new SV is returned and its
9698 reference count is 1. The reference count 1 is owned by C<rv>.
9704 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
9709 PERL_ARGS_ASSERT_NEWSVRV;
9713 SV_CHECK_THINKFIRST_COW_DROP(rv);
9715 if (SvTYPE(rv) >= SVt_PVMG) {
9716 const U32 refcnt = SvREFCNT(rv);
9720 SvREFCNT(rv) = refcnt;
9722 sv_upgrade(rv, SVt_IV);
9723 } else if (SvROK(rv)) {
9724 SvREFCNT_dec(SvRV(rv));
9726 prepare_SV_for_RV(rv);
9734 HV* const stash = gv_stashpv(classname, GV_ADD);
9735 (void)sv_bless(rv, stash);
9741 Perl_newSVavdefelem(pTHX_ AV *av, SSize_t ix, bool extendible)
9743 SV * const lv = newSV_type(SVt_PVLV);
9744 PERL_ARGS_ASSERT_NEWSVAVDEFELEM;
9746 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
9747 LvTARG(lv) = SvREFCNT_inc_simple_NN(av);
9748 LvSTARGOFF(lv) = ix;
9749 LvTARGLEN(lv) = extendible ? 1 : (STRLEN)UV_MAX;
9754 =for apidoc sv_setref_pv
9756 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
9757 argument will be upgraded to an RV. That RV will be modified to point to
9758 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
9759 into the SV. The C<classname> argument indicates the package for the
9760 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9761 will have a reference count of 1, and the RV will be returned.
9763 Do not use with other Perl types such as HV, AV, SV, CV, because those
9764 objects will become corrupted by the pointer copy process.
9766 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
9772 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
9776 PERL_ARGS_ASSERT_SV_SETREF_PV;
9779 sv_setsv(rv, &PL_sv_undef);
9783 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
9788 =for apidoc sv_setref_iv
9790 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
9791 argument will be upgraded to an RV. That RV will be modified to point to
9792 the new SV. The C<classname> argument indicates the package for the
9793 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9794 will have a reference count of 1, and the RV will be returned.
9800 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
9802 PERL_ARGS_ASSERT_SV_SETREF_IV;
9804 sv_setiv(newSVrv(rv,classname), iv);
9809 =for apidoc sv_setref_uv
9811 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
9812 argument will be upgraded to an RV. That RV will be modified to point to
9813 the new SV. The C<classname> argument indicates the package for the
9814 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9815 will have a reference count of 1, and the RV will be returned.
9821 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
9823 PERL_ARGS_ASSERT_SV_SETREF_UV;
9825 sv_setuv(newSVrv(rv,classname), uv);
9830 =for apidoc sv_setref_nv
9832 Copies a double into a new SV, optionally blessing the SV. The C<rv>
9833 argument will be upgraded to an RV. That RV will be modified to point to
9834 the new SV. The C<classname> argument indicates the package for the
9835 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9836 will have a reference count of 1, and the RV will be returned.
9842 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
9844 PERL_ARGS_ASSERT_SV_SETREF_NV;
9846 sv_setnv(newSVrv(rv,classname), nv);
9851 =for apidoc sv_setref_pvn
9853 Copies a string into a new SV, optionally blessing the SV. The length of the
9854 string must be specified with C<n>. The C<rv> argument will be upgraded to
9855 an RV. That RV will be modified to point to the new SV. The C<classname>
9856 argument indicates the package for the blessing. Set C<classname> to
9857 C<NULL> to avoid the blessing. The new SV will have a reference count
9858 of 1, and the RV will be returned.
9860 Note that C<sv_setref_pv> copies the pointer while this copies the string.
9866 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
9867 const char *const pv, const STRLEN n)
9869 PERL_ARGS_ASSERT_SV_SETREF_PVN;
9871 sv_setpvn(newSVrv(rv,classname), pv, n);
9876 =for apidoc sv_bless
9878 Blesses an SV into a specified package. The SV must be an RV. The package
9879 must be designated by its stash (see C<gv_stashpv()>). The reference count
9880 of the SV is unaffected.
9886 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
9890 HV *oldstash = NULL;
9892 PERL_ARGS_ASSERT_SV_BLESS;
9896 Perl_croak(aTHX_ "Can't bless non-reference value");
9898 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
9899 if (SvREADONLY(tmpRef))
9900 Perl_croak_no_modify();
9901 if (SvOBJECT(tmpRef)) {
9902 oldstash = SvSTASH(tmpRef);
9905 SvOBJECT_on(tmpRef);
9906 SvUPGRADE(tmpRef, SVt_PVMG);
9907 SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
9908 SvREFCNT_dec(oldstash);
9910 if(SvSMAGICAL(tmpRef))
9911 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
9919 /* Downgrades a PVGV to a PVMG. If it's actually a PVLV, we leave the type
9920 * as it is after unglobbing it.
9923 PERL_STATIC_INLINE void
9924 S_sv_unglob(pTHX_ SV *const sv, U32 flags)
9929 SV * const temp = flags & SV_COW_DROP_PV ? NULL : sv_newmortal();
9931 PERL_ARGS_ASSERT_SV_UNGLOB;
9933 assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
9935 if (!(flags & SV_COW_DROP_PV))
9936 gv_efullname3(temp, MUTABLE_GV(sv), "*");
9939 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
9940 && HvNAME_get(stash))
9941 mro_method_changed_in(stash);
9942 gp_free(MUTABLE_GV(sv));
9945 sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
9949 if (GvNAME_HEK(sv)) {
9950 unshare_hek(GvNAME_HEK(sv));
9952 isGV_with_GP_off(sv);
9954 if(SvTYPE(sv) == SVt_PVGV) {
9955 /* need to keep SvANY(sv) in the right arena */
9956 xpvmg = new_XPVMG();
9957 StructCopy(SvANY(sv), xpvmg, XPVMG);
9958 del_XPVGV(SvANY(sv));
9961 SvFLAGS(sv) &= ~SVTYPEMASK;
9962 SvFLAGS(sv) |= SVt_PVMG;
9965 /* Intentionally not calling any local SET magic, as this isn't so much a
9966 set operation as merely an internal storage change. */
9967 if (flags & SV_COW_DROP_PV) SvOK_off(sv);
9968 else sv_setsv_flags(sv, temp, 0);
9970 if ((const GV *)sv == PL_last_in_gv)
9971 PL_last_in_gv = NULL;
9972 else if ((const GV *)sv == PL_statgv)
9977 =for apidoc sv_unref_flags
9979 Unsets the RV status of the SV, and decrements the reference count of
9980 whatever was being referenced by the RV. This can almost be thought of
9981 as a reversal of C<newSVrv>. The C<cflags> argument can contain
9982 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
9983 (otherwise the decrementing is conditional on the reference count being
9984 different from one or the reference being a readonly SV).
9991 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
9993 SV* const target = SvRV(ref);
9995 PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
9997 if (SvWEAKREF(ref)) {
9998 sv_del_backref(target, ref);
10000 SvRV_set(ref, NULL);
10003 SvRV_set(ref, NULL);
10005 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
10006 assigned to as BEGIN {$a = \"Foo"} will fail. */
10007 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
10008 SvREFCNT_dec_NN(target);
10009 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
10010 sv_2mortal(target); /* Schedule for freeing later */
10014 =for apidoc sv_untaint
10016 Untaint an SV. Use C<SvTAINTED_off> instead.
10022 Perl_sv_untaint(pTHX_ SV *const sv)
10024 PERL_ARGS_ASSERT_SV_UNTAINT;
10026 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
10027 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
10034 =for apidoc sv_tainted
10036 Test an SV for taintedness. Use C<SvTAINTED> instead.
10042 Perl_sv_tainted(pTHX_ SV *const sv)
10044 PERL_ARGS_ASSERT_SV_TAINTED;
10046 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
10047 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
10048 if (mg && (mg->mg_len & 1) )
10055 =for apidoc sv_setpviv
10057 Copies an integer into the given SV, also updating its string value.
10058 Does not handle 'set' magic. See C<sv_setpviv_mg>.
10064 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
10066 char buf[TYPE_CHARS(UV)];
10068 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
10070 PERL_ARGS_ASSERT_SV_SETPVIV;
10072 sv_setpvn(sv, ptr, ebuf - ptr);
10076 =for apidoc sv_setpviv_mg
10078 Like C<sv_setpviv>, but also handles 'set' magic.
10084 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
10086 PERL_ARGS_ASSERT_SV_SETPVIV_MG;
10088 sv_setpviv(sv, iv);
10092 #if defined(PERL_IMPLICIT_CONTEXT)
10094 /* pTHX_ magic can't cope with varargs, so this is a no-context
10095 * version of the main function, (which may itself be aliased to us).
10096 * Don't access this version directly.
10100 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
10105 PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
10107 va_start(args, pat);
10108 sv_vsetpvf(sv, pat, &args);
10112 /* pTHX_ magic can't cope with varargs, so this is a no-context
10113 * version of the main function, (which may itself be aliased to us).
10114 * Don't access this version directly.
10118 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
10123 PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
10125 va_start(args, pat);
10126 sv_vsetpvf_mg(sv, pat, &args);
10132 =for apidoc sv_setpvf
10134 Works like C<sv_catpvf> but copies the text into the SV instead of
10135 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
10141 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
10145 PERL_ARGS_ASSERT_SV_SETPVF;
10147 va_start(args, pat);
10148 sv_vsetpvf(sv, pat, &args);
10153 =for apidoc sv_vsetpvf
10155 Works like C<sv_vcatpvf> but copies the text into the SV instead of
10156 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
10158 Usually used via its frontend C<sv_setpvf>.
10164 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
10166 PERL_ARGS_ASSERT_SV_VSETPVF;
10168 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
10172 =for apidoc sv_setpvf_mg
10174 Like C<sv_setpvf>, but also handles 'set' magic.
10180 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
10184 PERL_ARGS_ASSERT_SV_SETPVF_MG;
10186 va_start(args, pat);
10187 sv_vsetpvf_mg(sv, pat, &args);
10192 =for apidoc sv_vsetpvf_mg
10194 Like C<sv_vsetpvf>, but also handles 'set' magic.
10196 Usually used via its frontend C<sv_setpvf_mg>.
10202 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
10204 PERL_ARGS_ASSERT_SV_VSETPVF_MG;
10206 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
10210 #if defined(PERL_IMPLICIT_CONTEXT)
10212 /* pTHX_ magic can't cope with varargs, so this is a no-context
10213 * version of the main function, (which may itself be aliased to us).
10214 * Don't access this version directly.
10218 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
10223 PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
10225 va_start(args, pat);
10226 sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
10230 /* pTHX_ magic can't cope with varargs, so this is a no-context
10231 * version of the main function, (which may itself be aliased to us).
10232 * Don't access this version directly.
10236 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
10241 PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
10243 va_start(args, pat);
10244 sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
10251 =for apidoc sv_catpvf
10253 Processes its arguments like C<sprintf> and appends the formatted
10254 output to an SV. If the appended data contains "wide" characters
10255 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
10256 and characters >255 formatted with %c), the original SV might get
10257 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
10258 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
10259 valid UTF-8; if the original SV was bytes, the pattern should be too.
10264 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
10268 PERL_ARGS_ASSERT_SV_CATPVF;
10270 va_start(args, pat);
10271 sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
10276 =for apidoc sv_vcatpvf
10278 Processes its arguments like C<vsprintf> and appends the formatted output
10279 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
10281 Usually used via its frontend C<sv_catpvf>.
10287 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
10289 PERL_ARGS_ASSERT_SV_VCATPVF;
10291 sv_vcatpvfn_flags(sv, pat, strlen(pat), args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
10295 =for apidoc sv_catpvf_mg
10297 Like C<sv_catpvf>, but also handles 'set' magic.
10303 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
10307 PERL_ARGS_ASSERT_SV_CATPVF_MG;
10309 va_start(args, pat);
10310 sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
10316 =for apidoc sv_vcatpvf_mg
10318 Like C<sv_vcatpvf>, but also handles 'set' magic.
10320 Usually used via its frontend C<sv_catpvf_mg>.
10326 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
10328 PERL_ARGS_ASSERT_SV_VCATPVF_MG;
10330 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
10335 =for apidoc sv_vsetpvfn
10337 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
10340 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
10346 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
10347 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
10349 PERL_ARGS_ASSERT_SV_VSETPVFN;
10352 sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, 0);
10357 * Warn of missing argument to sprintf, and then return a defined value
10358 * to avoid inappropriate "use of uninit" warnings [perl #71000].
10360 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
10362 S_vcatpvfn_missing_argument(pTHX) {
10363 if (ckWARN(WARN_MISSING)) {
10364 Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
10365 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
10372 S_expect_number(pTHX_ char **const pattern)
10377 PERL_ARGS_ASSERT_EXPECT_NUMBER;
10379 switch (**pattern) {
10380 case '1': case '2': case '3':
10381 case '4': case '5': case '6':
10382 case '7': case '8': case '9':
10383 var = *(*pattern)++ - '0';
10384 while (isDIGIT(**pattern)) {
10385 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
10387 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
10395 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
10397 const int neg = nv < 0;
10400 PERL_ARGS_ASSERT_F0CONVERT;
10408 if (uv & 1 && uv == nv)
10409 uv--; /* Round to even */
10411 const unsigned dig = uv % 10;
10413 } while (uv /= 10);
10424 =for apidoc sv_vcatpvfn
10426 =for apidoc sv_vcatpvfn_flags
10428 Processes its arguments like C<vsprintf> and appends the formatted output
10429 to an SV. Uses an array of SVs if the C style variable argument list is
10430 missing (NULL). When running with taint checks enabled, indicates via
10431 C<maybe_tainted> if results are untrustworthy (often due to the use of
10434 If called as C<sv_vcatpvfn> or flags include C<SV_GMAGIC>, calls get magic.
10436 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
10441 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
10442 vecstr = (U8*)SvPV_const(vecsv,veclen);\
10443 vec_utf8 = DO_UTF8(vecsv);
10445 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
10448 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
10449 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
10451 PERL_ARGS_ASSERT_SV_VCATPVFN;
10453 sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
10457 Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
10458 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted,
10464 const char *patend;
10467 static const char nullstr[] = "(null)";
10469 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
10470 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
10472 /* Times 4: a decimal digit takes more than 3 binary digits.
10473 * NV_DIG: mantissa takes than many decimal digits.
10474 * Plus 32: Playing safe. */
10475 char ebuf[IV_DIG * 4 + NV_DIG + 32];
10476 /* large enough for "%#.#f" --chip */
10477 /* what about long double NVs? --jhi */
10479 DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED;
10481 PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
10482 PERL_UNUSED_ARG(maybe_tainted);
10484 if (flags & SV_GMAGIC)
10487 /* no matter what, this is a string now */
10488 (void)SvPV_force_nomg(sv, origlen);
10490 /* special-case "", "%s", and "%-p" (SVf - see below) */
10493 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
10495 const char * const s = va_arg(*args, char*);
10496 sv_catpv_nomg(sv, s ? s : nullstr);
10498 else if (svix < svmax) {
10499 /* we want get magic on the source but not the target. sv_catsv can't do that, though */
10500 SvGETMAGIC(*svargs);
10501 sv_catsv_nomg(sv, *svargs);
10504 S_vcatpvfn_missing_argument(aTHX);
10507 if (args && patlen == 3 && pat[0] == '%' &&
10508 pat[1] == '-' && pat[2] == 'p') {
10509 argsv = MUTABLE_SV(va_arg(*args, void*));
10510 sv_catsv_nomg(sv, argsv);
10514 #ifndef USE_LONG_DOUBLE
10515 /* special-case "%.<number>[gf]" */
10516 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
10517 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
10518 unsigned digits = 0;
10522 while (*pp >= '0' && *pp <= '9')
10523 digits = 10 * digits + (*pp++ - '0');
10524 if (pp - pat == (int)patlen - 1 && svix < svmax) {
10525 const NV nv = SvNV(*svargs);
10527 /* Add check for digits != 0 because it seems that some
10528 gconverts are buggy in this case, and we don't yet have
10529 a Configure test for this. */
10530 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
10531 /* 0, point, slack */
10532 STORE_LC_NUMERIC_SET_TO_NEEDED();
10533 V_Gconvert(nv, (int)digits, 0, ebuf);
10534 sv_catpv_nomg(sv, ebuf);
10535 if (*ebuf) /* May return an empty string for digits==0 */
10538 } else if (!digits) {
10541 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
10542 sv_catpvn_nomg(sv, p, l);
10548 #endif /* !USE_LONG_DOUBLE */
10550 if (!args && svix < svmax && DO_UTF8(*svargs))
10553 patend = (char*)pat + patlen;
10554 for (p = (char*)pat; p < patend; p = q) {
10557 bool vectorize = FALSE;
10558 bool vectorarg = FALSE;
10559 bool vec_utf8 = FALSE;
10565 bool has_precis = FALSE;
10567 const I32 osvix = svix;
10568 bool is_utf8 = FALSE; /* is this item utf8? */
10569 #ifdef HAS_LDBL_SPRINTF_BUG
10570 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10571 with sfio - Allen <allens@cpan.org> */
10572 bool fix_ldbl_sprintf_bug = FALSE;
10576 U8 utf8buf[UTF8_MAXBYTES+1];
10577 STRLEN esignlen = 0;
10579 const char *eptr = NULL;
10580 const char *fmtstart;
10583 const U8 *vecstr = NULL;
10590 /* we need a long double target in case HAS_LONG_DOUBLE but
10591 not USE_LONG_DOUBLE
10593 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
10601 const char *dotstr = ".";
10602 STRLEN dotstrlen = 1;
10603 I32 efix = 0; /* explicit format parameter index */
10604 I32 ewix = 0; /* explicit width index */
10605 I32 epix = 0; /* explicit precision index */
10606 I32 evix = 0; /* explicit vector index */
10607 bool asterisk = FALSE;
10609 /* echo everything up to the next format specification */
10610 for (q = p; q < patend && *q != '%'; ++q) ;
10612 if (has_utf8 && !pat_utf8)
10613 sv_catpvn_nomg_utf8_upgrade(sv, p, q - p, nsv);
10615 sv_catpvn_nomg(sv, p, q - p);
10624 We allow format specification elements in this order:
10625 \d+\$ explicit format parameter index
10627 v|\*(\d+\$)?v vector with optional (optionally specified) arg
10628 0 flag (as above): repeated to allow "v02"
10629 \d+|\*(\d+\$)? width using optional (optionally specified) arg
10630 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
10632 [%bcdefginopsuxDFOUX] format (mandatory)
10637 As of perl5.9.3, printf format checking is on by default.
10638 Internally, perl uses %p formats to provide an escape to
10639 some extended formatting. This block deals with those
10640 extensions: if it does not match, (char*)q is reset and
10641 the normal format processing code is used.
10643 Currently defined extensions are:
10644 %p include pointer address (standard)
10645 %-p (SVf) include an SV (previously %_)
10646 %-<num>p include an SV with precision <num>
10648 %3p include a HEK with precision of 256
10649 %4p char* preceded by utf8 flag and length
10650 %<num>p (where num is 1 or > 4) reserved for future
10653 Robin Barker 2005-07-14 (but modified since)
10655 %1p (VDf) removed. RMB 2007-10-19
10662 else if (strnEQ(q, UTF8f, sizeof(UTF8f)-1)) { /* UTF8f */
10663 /* The argument has already gone through cBOOL, so the cast
10665 is_utf8 = (bool)va_arg(*args, int);
10666 elen = va_arg(*args, UV);
10667 eptr = va_arg(*args, char *);
10668 q += sizeof(UTF8f)-1;
10671 n = expect_number(&q);
10673 if (sv) { /* SVf */
10678 argsv = MUTABLE_SV(va_arg(*args, void*));
10679 eptr = SvPV_const(argsv, elen);
10680 if (DO_UTF8(argsv))
10684 else if (n==2 || n==3) { /* HEKf */
10685 HEK * const hek = va_arg(*args, HEK *);
10686 eptr = HEK_KEY(hek);
10687 elen = HEK_LEN(hek);
10688 if (HEK_UTF8(hek)) is_utf8 = TRUE;
10689 if (n==3) precis = 256, has_precis = TRUE;
10693 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
10694 "internal %%<num>p might conflict with future printf extensions");
10700 if ( (width = expect_number(&q)) ) {
10715 if (plus == '+' && *q == ' ') /* '+' over ' ' */
10744 if ( (ewix = expect_number(&q)) )
10753 if ((vectorarg = asterisk)) {
10766 width = expect_number(&q);
10769 if (vectorize && vectorarg) {
10770 /* vectorizing, but not with the default "." */
10772 vecsv = va_arg(*args, SV*);
10774 vecsv = (evix > 0 && evix <= svmax)
10775 ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
10777 vecsv = svix < svmax
10778 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10780 dotstr = SvPV_const(vecsv, dotstrlen);
10781 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
10782 bad with tied or overloaded values that return UTF8. */
10783 if (DO_UTF8(vecsv))
10785 else if (has_utf8) {
10786 vecsv = sv_mortalcopy(vecsv);
10787 sv_utf8_upgrade(vecsv);
10788 dotstr = SvPV_const(vecsv, dotstrlen);
10795 i = va_arg(*args, int);
10797 i = (ewix ? ewix <= svmax : svix < svmax) ?
10798 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10800 width = (i < 0) ? -i : i;
10810 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
10812 /* XXX: todo, support specified precision parameter */
10816 i = va_arg(*args, int);
10818 i = (ewix ? ewix <= svmax : svix < svmax)
10819 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10821 has_precis = !(i < 0);
10825 while (isDIGIT(*q))
10826 precis = precis * 10 + (*q++ - '0');
10835 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
10836 vecsv = svargs[efix ? efix-1 : svix++];
10837 vecstr = (U8*)SvPV_const(vecsv,veclen);
10838 vec_utf8 = DO_UTF8(vecsv);
10840 /* if this is a version object, we need to convert
10841 * back into v-string notation and then let the
10842 * vectorize happen normally
10844 if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) {
10845 if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
10846 Perl_ck_warner_d(aTHX_ packWARN(WARN_PRINTF),
10847 "vector argument not supported with alpha versions");
10850 vecsv = sv_newmortal();
10851 scan_vstring((char *)vecstr, (char *)vecstr + veclen,
10853 vecstr = (U8*)SvPV_const(vecsv, veclen);
10854 vec_utf8 = DO_UTF8(vecsv);
10868 case 'I': /* Ix, I32x, and I64x */
10869 # ifdef USE_64_BIT_INT
10870 if (q[1] == '6' && q[2] == '4') {
10876 if (q[1] == '3' && q[2] == '2') {
10880 # ifdef USE_64_BIT_INT
10886 #if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
10898 #if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
10899 if (*q == 'l') { /* lld, llf */
10908 if (*++q == 'h') { /* hhd, hhu */
10937 if (!vectorize && !args) {
10939 const I32 i = efix-1;
10940 argsv = (i >= 0 && i < svmax)
10941 ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
10943 argsv = (svix >= 0 && svix < svmax)
10944 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10948 switch (c = *q++) {
10955 uv = (args) ? va_arg(*args, int) : SvIV(argsv);
10957 (!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv)))
10959 eptr = (char*)utf8buf;
10960 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
10974 eptr = va_arg(*args, char*);
10976 elen = strlen(eptr);
10978 eptr = (char *)nullstr;
10979 elen = sizeof nullstr - 1;
10983 eptr = SvPV_const(argsv, elen);
10984 if (DO_UTF8(argsv)) {
10985 STRLEN old_precis = precis;
10986 if (has_precis && precis < elen) {
10987 STRLEN ulen = sv_or_pv_len_utf8(argsv, eptr, elen);
10988 STRLEN p = precis > ulen ? ulen : precis;
10989 precis = sv_or_pv_pos_u2b(argsv, eptr, p, 0);
10990 /* sticks at end */
10992 if (width) { /* fudge width (can't fudge elen) */
10993 if (has_precis && precis < elen)
10994 width += precis - old_precis;
10997 elen - sv_or_pv_len_utf8(argsv,eptr,elen);
11004 if (has_precis && precis < elen)
11011 if (alt || vectorize)
11013 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
11034 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
11043 esignbuf[esignlen++] = plus;
11047 case 'c': iv = (char)va_arg(*args, int); break;
11048 case 'h': iv = (short)va_arg(*args, int); break;
11049 case 'l': iv = va_arg(*args, long); break;
11050 case 'V': iv = va_arg(*args, IV); break;
11051 case 'z': iv = va_arg(*args, SSize_t); break;
11052 case 't': iv = va_arg(*args, ptrdiff_t); break;
11053 default: iv = va_arg(*args, int); break;
11055 case 'j': iv = va_arg(*args, intmax_t); break;
11059 iv = va_arg(*args, Quad_t); break;
11066 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
11068 case 'c': iv = (char)tiv; break;
11069 case 'h': iv = (short)tiv; break;
11070 case 'l': iv = (long)tiv; break;
11072 default: iv = tiv; break;
11075 iv = (Quad_t)tiv; break;
11081 if ( !vectorize ) /* we already set uv above */
11086 esignbuf[esignlen++] = plus;
11090 esignbuf[esignlen++] = '-';
11134 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
11145 case 'c': uv = (unsigned char)va_arg(*args, unsigned); break;
11146 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
11147 case 'l': uv = va_arg(*args, unsigned long); break;
11148 case 'V': uv = va_arg(*args, UV); break;
11149 case 'z': uv = va_arg(*args, Size_t); break;
11150 case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */
11152 case 'j': uv = va_arg(*args, uintmax_t); break;
11154 default: uv = va_arg(*args, unsigned); break;
11157 uv = va_arg(*args, Uquad_t); break;
11164 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
11166 case 'c': uv = (unsigned char)tuv; break;
11167 case 'h': uv = (unsigned short)tuv; break;
11168 case 'l': uv = (unsigned long)tuv; break;
11170 default: uv = tuv; break;
11173 uv = (Uquad_t)tuv; break;
11182 char *ptr = ebuf + sizeof ebuf;
11183 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
11189 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
11193 } while (uv >>= 4);
11195 esignbuf[esignlen++] = '0';
11196 esignbuf[esignlen++] = c; /* 'x' or 'X' */
11202 *--ptr = '0' + dig;
11203 } while (uv >>= 3);
11204 if (alt && *ptr != '0')
11210 *--ptr = '0' + dig;
11211 } while (uv >>= 1);
11213 esignbuf[esignlen++] = '0';
11214 esignbuf[esignlen++] = c;
11217 default: /* it had better be ten or less */
11220 *--ptr = '0' + dig;
11221 } while (uv /= base);
11224 elen = (ebuf + sizeof ebuf) - ptr;
11228 zeros = precis - elen;
11229 else if (precis == 0 && elen == 1 && *eptr == '0'
11230 && !(base == 8 && alt)) /* "%#.0o" prints "0" */
11233 /* a precision nullifies the 0 flag. */
11240 /* FLOATING POINT */
11243 c = 'f'; /* maybe %F isn't supported here */
11245 case 'e': case 'E':
11247 case 'g': case 'G':
11251 /* This is evil, but floating point is even more evil */
11253 /* for SV-style calling, we can only get NV
11254 for C-style calling, we assume %f is double;
11255 for simplicity we allow any of %Lf, %llf, %qf for long double
11259 #if defined(USE_LONG_DOUBLE)
11263 /* [perl #20339] - we should accept and ignore %lf rather than die */
11267 #if defined(USE_LONG_DOUBLE)
11268 intsize = args ? 0 : 'q';
11272 #if defined(HAS_LONG_DOUBLE)
11285 /* now we need (long double) if intsize == 'q', else (double) */
11287 #if LONG_DOUBLESIZE > DOUBLESIZE
11289 va_arg(*args, long double) :
11290 va_arg(*args, double)
11292 va_arg(*args, double)
11297 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
11298 else. frexp() has some unspecified behaviour for those three */
11299 if (c != 'e' && c != 'E' && (nv * 0) == 0) {
11301 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
11302 will cast our (long double) to (double) */
11303 (void)Perl_frexp(nv, &i);
11304 if (i == PERL_INT_MIN)
11305 Perl_die(aTHX_ "panic: frexp");
11307 need = BIT_DIGITS(i);
11309 need += has_precis ? precis : 6; /* known default */
11314 #ifdef HAS_LDBL_SPRINTF_BUG
11315 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
11316 with sfio - Allen <allens@cpan.org> */
11319 # define MY_DBL_MAX DBL_MAX
11320 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
11321 # if DOUBLESIZE >= 8
11322 # define MY_DBL_MAX 1.7976931348623157E+308L
11324 # define MY_DBL_MAX 3.40282347E+38L
11328 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
11329 # define MY_DBL_MAX_BUG 1L
11331 # define MY_DBL_MAX_BUG MY_DBL_MAX
11335 # define MY_DBL_MIN DBL_MIN
11336 # else /* XXX guessing! -Allen */
11337 # if DOUBLESIZE >= 8
11338 # define MY_DBL_MIN 2.2250738585072014E-308L
11340 # define MY_DBL_MIN 1.17549435E-38L
11344 if ((intsize == 'q') && (c == 'f') &&
11345 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
11346 (need < DBL_DIG)) {
11347 /* it's going to be short enough that
11348 * long double precision is not needed */
11350 if ((nv <= 0L) && (nv >= -0L))
11351 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
11353 /* would use Perl_fp_class as a double-check but not
11354 * functional on IRIX - see perl.h comments */
11356 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
11357 /* It's within the range that a double can represent */
11358 #if defined(DBL_MAX) && !defined(DBL_MIN)
11359 if ((nv >= ((long double)1/DBL_MAX)) ||
11360 (nv <= (-(long double)1/DBL_MAX)))
11362 fix_ldbl_sprintf_bug = TRUE;
11365 if (fix_ldbl_sprintf_bug == TRUE) {
11375 # undef MY_DBL_MAX_BUG
11378 #endif /* HAS_LDBL_SPRINTF_BUG */
11380 need += 20; /* fudge factor */
11381 if (PL_efloatsize < need) {
11382 Safefree(PL_efloatbuf);
11383 PL_efloatsize = need + 20; /* more fudge */
11384 Newx(PL_efloatbuf, PL_efloatsize, char);
11385 PL_efloatbuf[0] = '\0';
11388 if ( !(width || left || plus || alt) && fill != '0'
11389 && has_precis && intsize != 'q' ) { /* Shortcuts */
11390 /* See earlier comment about buggy Gconvert when digits,
11392 if ( c == 'g' && precis) {
11393 STORE_LC_NUMERIC_SET_TO_NEEDED();
11394 V_Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
11395 /* May return an empty string for digits==0 */
11396 if (*PL_efloatbuf) {
11397 elen = strlen(PL_efloatbuf);
11398 goto float_converted;
11400 } else if ( c == 'f' && !precis) {
11401 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
11406 char *ptr = ebuf + sizeof ebuf;
11409 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
11410 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
11411 if (intsize == 'q') {
11412 /* Copy the one or more characters in a long double
11413 * format before the 'base' ([efgEFG]) character to
11414 * the format string. */
11415 static char const prifldbl[] = PERL_PRIfldbl;
11416 char const *p = prifldbl + sizeof(prifldbl) - 3;
11417 while (p >= prifldbl) { *--ptr = *p--; }
11422 do { *--ptr = '0' + (base % 10); } while (base /= 10);
11427 do { *--ptr = '0' + (base % 10); } while (base /= 10);
11439 /* No taint. Otherwise we are in the strange situation
11440 * where printf() taints but print($float) doesn't.
11443 STORE_LC_NUMERIC_SET_TO_NEEDED();
11445 /* hopefully the above makes ptr a very constrained format
11446 * that is safe to use, even though it's not literal */
11447 GCC_DIAG_IGNORE(-Wformat-nonliteral);
11448 #if defined(HAS_LONG_DOUBLE)
11449 elen = ((intsize == 'q')
11450 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
11451 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
11453 elen = my_sprintf(PL_efloatbuf, ptr, nv);
11458 eptr = PL_efloatbuf;
11460 #ifdef USE_LOCALE_NUMERIC
11461 if (PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
11462 && instr(eptr, SvPVX_const(PL_numeric_radix_sv)))
11475 i = SvCUR(sv) - origlen;
11478 case 'c': *(va_arg(*args, char*)) = i; break;
11479 case 'h': *(va_arg(*args, short*)) = i; break;
11480 default: *(va_arg(*args, int*)) = i; break;
11481 case 'l': *(va_arg(*args, long*)) = i; break;
11482 case 'V': *(va_arg(*args, IV*)) = i; break;
11483 case 'z': *(va_arg(*args, SSize_t*)) = i; break;
11484 case 't': *(va_arg(*args, ptrdiff_t*)) = i; break;
11486 case 'j': *(va_arg(*args, intmax_t*)) = i; break;
11490 *(va_arg(*args, Quad_t*)) = i; break;
11497 sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)i);
11498 continue; /* not "break" */
11505 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
11506 && ckWARN(WARN_PRINTF))
11508 SV * const msg = sv_newmortal();
11509 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
11510 (PL_op->op_type == OP_PRTF) ? "" : "s");
11511 if (fmtstart < patend) {
11512 const char * const fmtend = q < patend ? q : patend;
11514 sv_catpvs(msg, "\"%");
11515 for (f = fmtstart; f < fmtend; f++) {
11517 sv_catpvn_nomg(msg, f, 1);
11519 Perl_sv_catpvf(aTHX_ msg,
11520 "\\%03"UVof, (UV)*f & 0xFF);
11523 sv_catpvs(msg, "\"");
11525 sv_catpvs(msg, "end of string");
11527 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
11530 /* output mangled stuff ... */
11536 /* ... right here, because formatting flags should not apply */
11537 SvGROW(sv, SvCUR(sv) + elen + 1);
11539 Copy(eptr, p, elen, char);
11542 SvCUR_set(sv, p - SvPVX_const(sv));
11544 continue; /* not "break" */
11547 if (is_utf8 != has_utf8) {
11550 sv_utf8_upgrade(sv);
11553 const STRLEN old_elen = elen;
11554 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
11555 sv_utf8_upgrade(nsv);
11556 eptr = SvPVX_const(nsv);
11559 if (width) { /* fudge width (can't fudge elen) */
11560 width += elen - old_elen;
11566 have = esignlen + zeros + elen;
11568 croak_memory_wrap();
11570 need = (have > width ? have : width);
11573 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
11574 croak_memory_wrap();
11575 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
11577 if (esignlen && fill == '0') {
11579 for (i = 0; i < (int)esignlen; i++)
11580 *p++ = esignbuf[i];
11582 if (gap && !left) {
11583 memset(p, fill, gap);
11586 if (esignlen && fill != '0') {
11588 for (i = 0; i < (int)esignlen; i++)
11589 *p++ = esignbuf[i];
11593 for (i = zeros; i; i--)
11597 Copy(eptr, p, elen, char);
11601 memset(p, ' ', gap);
11606 Copy(dotstr, p, dotstrlen, char);
11610 vectorize = FALSE; /* done iterating over vecstr */
11617 SvCUR_set(sv, p - SvPVX_const(sv));
11625 RESTORE_LC_NUMERIC(); /* Done outside loop, so don't have to save/restore
11629 /* =========================================================================
11631 =head1 Cloning an interpreter
11633 All the macros and functions in this section are for the private use of
11634 the main function, perl_clone().
11636 The foo_dup() functions make an exact copy of an existing foo thingy.
11637 During the course of a cloning, a hash table is used to map old addresses
11638 to new addresses. The table is created and manipulated with the
11639 ptr_table_* functions.
11643 * =========================================================================*/
11646 #if defined(USE_ITHREADS)
11648 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
11649 #ifndef GpREFCNT_inc
11650 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
11654 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
11655 that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
11656 If this changes, please unmerge ss_dup.
11657 Likewise, sv_dup_inc_multiple() relies on this fact. */
11658 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup_inc(s,t))
11659 #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
11660 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
11661 #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
11662 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
11663 #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
11664 #define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t))
11665 #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
11666 #define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t))
11667 #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
11668 #define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t))
11669 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
11670 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
11672 /* clone a parser */
11675 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
11679 PERL_ARGS_ASSERT_PARSER_DUP;
11684 /* look for it in the table first */
11685 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
11689 /* create anew and remember what it is */
11690 Newxz(parser, 1, yy_parser);
11691 ptr_table_store(PL_ptr_table, proto, parser);
11693 /* XXX these not yet duped */
11694 parser->old_parser = NULL;
11695 parser->stack = NULL;
11697 parser->stack_size = 0;
11698 /* XXX parser->stack->state = 0; */
11700 /* XXX eventually, just Copy() most of the parser struct ? */
11702 parser->lex_brackets = proto->lex_brackets;
11703 parser->lex_casemods = proto->lex_casemods;
11704 parser->lex_brackstack = savepvn(proto->lex_brackstack,
11705 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
11706 parser->lex_casestack = savepvn(proto->lex_casestack,
11707 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
11708 parser->lex_defer = proto->lex_defer;
11709 parser->lex_dojoin = proto->lex_dojoin;
11710 parser->lex_expect = proto->lex_expect;
11711 parser->lex_formbrack = proto->lex_formbrack;
11712 parser->lex_inpat = proto->lex_inpat;
11713 parser->lex_inwhat = proto->lex_inwhat;
11714 parser->lex_op = proto->lex_op;
11715 parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
11716 parser->lex_starts = proto->lex_starts;
11717 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
11718 parser->multi_close = proto->multi_close;
11719 parser->multi_open = proto->multi_open;
11720 parser->multi_start = proto->multi_start;
11721 parser->multi_end = proto->multi_end;
11722 parser->preambled = proto->preambled;
11723 parser->sublex_info = proto->sublex_info; /* XXX not quite right */
11724 parser->linestr = sv_dup_inc(proto->linestr, param);
11725 parser->expect = proto->expect;
11726 parser->copline = proto->copline;
11727 parser->last_lop_op = proto->last_lop_op;
11728 parser->lex_state = proto->lex_state;
11729 parser->rsfp = fp_dup(proto->rsfp, '<', param);
11730 /* rsfp_filters entries have fake IoDIRP() */
11731 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
11732 parser->in_my = proto->in_my;
11733 parser->in_my_stash = hv_dup(proto->in_my_stash, param);
11734 parser->error_count = proto->error_count;
11737 parser->linestr = sv_dup_inc(proto->linestr, param);
11740 char * const ols = SvPVX(proto->linestr);
11741 char * const ls = SvPVX(parser->linestr);
11743 parser->bufptr = ls + (proto->bufptr >= ols ?
11744 proto->bufptr - ols : 0);
11745 parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
11746 proto->oldbufptr - ols : 0);
11747 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
11748 proto->oldoldbufptr - ols : 0);
11749 parser->linestart = ls + (proto->linestart >= ols ?
11750 proto->linestart - ols : 0);
11751 parser->last_uni = ls + (proto->last_uni >= ols ?
11752 proto->last_uni - ols : 0);
11753 parser->last_lop = ls + (proto->last_lop >= ols ?
11754 proto->last_lop - ols : 0);
11756 parser->bufend = ls + SvCUR(parser->linestr);
11759 Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
11763 parser->endwhite = proto->endwhite;
11764 parser->faketokens = proto->faketokens;
11765 parser->lasttoke = proto->lasttoke;
11766 parser->nextwhite = proto->nextwhite;
11767 parser->realtokenstart = proto->realtokenstart;
11768 parser->skipwhite = proto->skipwhite;
11769 parser->thisclose = proto->thisclose;
11770 parser->thismad = proto->thismad;
11771 parser->thisopen = proto->thisopen;
11772 parser->thisstuff = proto->thisstuff;
11773 parser->thistoken = proto->thistoken;
11774 parser->thiswhite = proto->thiswhite;
11776 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
11777 parser->curforce = proto->curforce;
11779 Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
11780 Copy(proto->nexttype, parser->nexttype, 5, I32);
11781 parser->nexttoke = proto->nexttoke;
11784 /* XXX should clone saved_curcop here, but we aren't passed
11785 * proto_perl; so do it in perl_clone_using instead */
11791 /* duplicate a file handle */
11794 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
11798 PERL_ARGS_ASSERT_FP_DUP;
11799 PERL_UNUSED_ARG(type);
11802 return (PerlIO*)NULL;
11804 /* look for it in the table first */
11805 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
11809 /* create anew and remember what it is */
11810 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
11811 ptr_table_store(PL_ptr_table, fp, ret);
11815 /* duplicate a directory handle */
11818 Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
11825 const Direntry_t *dirent;
11826 char smallbuf[256];
11832 PERL_UNUSED_CONTEXT;
11833 PERL_ARGS_ASSERT_DIRP_DUP;
11838 /* look for it in the table first */
11839 ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
11845 PERL_UNUSED_ARG(param);
11849 /* open the current directory (so we can switch back) */
11850 if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
11852 /* chdir to our dir handle and open the present working directory */
11853 if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
11854 PerlDir_close(pwd);
11855 return (DIR *)NULL;
11857 /* Now we should have two dir handles pointing to the same dir. */
11859 /* Be nice to the calling code and chdir back to where we were. */
11860 rc = fchdir(my_dirfd(pwd));
11861 /* XXX If this fails, then what? */
11862 PERL_UNUSED_VAR(rc);
11864 /* We have no need of the pwd handle any more. */
11865 PerlDir_close(pwd);
11868 # define d_namlen(d) (d)->d_namlen
11870 # define d_namlen(d) strlen((d)->d_name)
11872 /* Iterate once through dp, to get the file name at the current posi-
11873 tion. Then step back. */
11874 pos = PerlDir_tell(dp);
11875 if ((dirent = PerlDir_read(dp))) {
11876 len = d_namlen(dirent);
11877 if (len <= sizeof smallbuf) name = smallbuf;
11878 else Newx(name, len, char);
11879 Move(dirent->d_name, name, len, char);
11881 PerlDir_seek(dp, pos);
11883 /* Iterate through the new dir handle, till we find a file with the
11885 if (!dirent) /* just before the end */
11887 pos = PerlDir_tell(ret);
11888 if (PerlDir_read(ret)) continue; /* not there yet */
11889 PerlDir_seek(ret, pos); /* step back */
11893 const long pos0 = PerlDir_tell(ret);
11895 pos = PerlDir_tell(ret);
11896 if ((dirent = PerlDir_read(ret))) {
11897 if (len == d_namlen(dirent)
11898 && memEQ(name, dirent->d_name, len)) {
11900 PerlDir_seek(ret, pos); /* step back */
11903 /* else we are not there yet; keep iterating */
11905 else { /* This is not meant to happen. The best we can do is
11906 reset the iterator to the beginning. */
11907 PerlDir_seek(ret, pos0);
11914 if (name && name != smallbuf)
11919 ret = win32_dirp_dup(dp, param);
11922 /* pop it in the pointer table */
11924 ptr_table_store(PL_ptr_table, dp, ret);
11929 /* duplicate a typeglob */
11932 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
11936 PERL_ARGS_ASSERT_GP_DUP;
11940 /* look for it in the table first */
11941 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
11945 /* create anew and remember what it is */
11947 ptr_table_store(PL_ptr_table, gp, ret);
11950 /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
11951 on Newxz() to do this for us. */
11952 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
11953 ret->gp_io = io_dup_inc(gp->gp_io, param);
11954 ret->gp_form = cv_dup_inc(gp->gp_form, param);
11955 ret->gp_av = av_dup_inc(gp->gp_av, param);
11956 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
11957 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
11958 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
11959 ret->gp_cvgen = gp->gp_cvgen;
11960 ret->gp_line = gp->gp_line;
11961 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
11965 /* duplicate a chain of magic */
11968 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
11970 MAGIC *mgret = NULL;
11971 MAGIC **mgprev_p = &mgret;
11973 PERL_ARGS_ASSERT_MG_DUP;
11975 for (; mg; mg = mg->mg_moremagic) {
11978 if ((param->flags & CLONEf_JOIN_IN)
11979 && mg->mg_type == PERL_MAGIC_backref)
11980 /* when joining, we let the individual SVs add themselves to
11981 * backref as needed. */
11984 Newx(nmg, 1, MAGIC);
11986 mgprev_p = &(nmg->mg_moremagic);
11988 /* There was a comment "XXX copy dynamic vtable?" but as we don't have
11989 dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
11990 from the original commit adding Perl_mg_dup() - revision 4538.
11991 Similarly there is the annotation "XXX random ptr?" next to the
11992 assignment to nmg->mg_ptr. */
11995 /* FIXME for plugins
11996 if (nmg->mg_type == PERL_MAGIC_qr) {
11997 nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
12001 nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
12002 ? nmg->mg_type == PERL_MAGIC_backref
12003 /* The backref AV has its reference
12004 * count deliberately bumped by 1 */
12005 ? SvREFCNT_inc(av_dup_inc((const AV *)
12006 nmg->mg_obj, param))
12007 : sv_dup_inc(nmg->mg_obj, param)
12008 : sv_dup(nmg->mg_obj, param);
12010 if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
12011 if (nmg->mg_len > 0) {
12012 nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
12013 if (nmg->mg_type == PERL_MAGIC_overload_table &&
12014 AMT_AMAGIC((AMT*)nmg->mg_ptr))
12016 AMT * const namtp = (AMT*)nmg->mg_ptr;
12017 sv_dup_inc_multiple((SV**)(namtp->table),
12018 (SV**)(namtp->table), NofAMmeth, param);
12021 else if (nmg->mg_len == HEf_SVKEY)
12022 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
12024 if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
12025 nmg->mg_virtual->svt_dup(aTHX_ nmg, param);
12031 #endif /* USE_ITHREADS */
12033 struct ptr_tbl_arena {
12034 struct ptr_tbl_arena *next;
12035 struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */
12038 /* create a new pointer-mapping table */
12041 Perl_ptr_table_new(pTHX)
12044 PERL_UNUSED_CONTEXT;
12046 Newx(tbl, 1, PTR_TBL_t);
12047 tbl->tbl_max = 511;
12048 tbl->tbl_items = 0;
12049 tbl->tbl_arena = NULL;
12050 tbl->tbl_arena_next = NULL;
12051 tbl->tbl_arena_end = NULL;
12052 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
12056 #define PTR_TABLE_HASH(ptr) \
12057 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
12059 /* map an existing pointer using a table */
12061 STATIC PTR_TBL_ENT_t *
12062 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
12064 PTR_TBL_ENT_t *tblent;
12065 const UV hash = PTR_TABLE_HASH(sv);
12067 PERL_ARGS_ASSERT_PTR_TABLE_FIND;
12069 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
12070 for (; tblent; tblent = tblent->next) {
12071 if (tblent->oldval == sv)
12078 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
12080 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
12082 PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
12083 PERL_UNUSED_CONTEXT;
12085 return tblent ? tblent->newval : NULL;
12088 /* add a new entry to a pointer-mapping table */
12091 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
12093 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
12095 PERL_ARGS_ASSERT_PTR_TABLE_STORE;
12096 PERL_UNUSED_CONTEXT;
12099 tblent->newval = newsv;
12101 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
12103 if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
12104 struct ptr_tbl_arena *new_arena;
12106 Newx(new_arena, 1, struct ptr_tbl_arena);
12107 new_arena->next = tbl->tbl_arena;
12108 tbl->tbl_arena = new_arena;
12109 tbl->tbl_arena_next = new_arena->array;
12110 tbl->tbl_arena_end = new_arena->array
12111 + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
12114 tblent = tbl->tbl_arena_next++;
12116 tblent->oldval = oldsv;
12117 tblent->newval = newsv;
12118 tblent->next = tbl->tbl_ary[entry];
12119 tbl->tbl_ary[entry] = tblent;
12121 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
12122 ptr_table_split(tbl);
12126 /* double the hash bucket size of an existing ptr table */
12129 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
12131 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
12132 const UV oldsize = tbl->tbl_max + 1;
12133 UV newsize = oldsize * 2;
12136 PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
12137 PERL_UNUSED_CONTEXT;
12139 Renew(ary, newsize, PTR_TBL_ENT_t*);
12140 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
12141 tbl->tbl_max = --newsize;
12142 tbl->tbl_ary = ary;
12143 for (i=0; i < oldsize; i++, ary++) {
12144 PTR_TBL_ENT_t **entp = ary;
12145 PTR_TBL_ENT_t *ent = *ary;
12146 PTR_TBL_ENT_t **curentp;
12149 curentp = ary + oldsize;
12151 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
12153 ent->next = *curentp;
12163 /* remove all the entries from a ptr table */
12164 /* Deprecated - will be removed post 5.14 */
12167 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
12169 if (tbl && tbl->tbl_items) {
12170 struct ptr_tbl_arena *arena = tbl->tbl_arena;
12172 Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
12175 struct ptr_tbl_arena *next = arena->next;
12181 tbl->tbl_items = 0;
12182 tbl->tbl_arena = NULL;
12183 tbl->tbl_arena_next = NULL;
12184 tbl->tbl_arena_end = NULL;
12188 /* clear and free a ptr table */
12191 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
12193 struct ptr_tbl_arena *arena;
12199 arena = tbl->tbl_arena;
12202 struct ptr_tbl_arena *next = arena->next;
12208 Safefree(tbl->tbl_ary);
12212 #if defined(USE_ITHREADS)
12215 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
12217 PERL_ARGS_ASSERT_RVPV_DUP;
12219 assert(!isREGEXP(sstr));
12221 if (SvWEAKREF(sstr)) {
12222 SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
12223 if (param->flags & CLONEf_JOIN_IN) {
12224 /* if joining, we add any back references individually rather
12225 * than copying the whole backref array */
12226 Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
12230 SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
12232 else if (SvPVX_const(sstr)) {
12233 /* Has something there */
12235 /* Normal PV - clone whole allocated space */
12236 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
12237 /* sstr may not be that normal, but actually copy on write.
12238 But we are a true, independent SV, so: */
12242 /* Special case - not normally malloced for some reason */
12243 if (isGV_with_GP(sstr)) {
12244 /* Don't need to do anything here. */
12246 else if ((SvIsCOW(sstr))) {
12247 /* A "shared" PV - clone it as "shared" PV */
12249 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
12253 /* Some other special case - random pointer */
12254 SvPV_set(dstr, (char *) SvPVX_const(sstr));
12259 /* Copy the NULL */
12260 SvPV_set(dstr, NULL);
12264 /* duplicate a list of SVs. source and dest may point to the same memory. */
12266 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
12267 SSize_t items, CLONE_PARAMS *const param)
12269 PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
12271 while (items-- > 0) {
12272 *dest++ = sv_dup_inc(*source++, param);
12278 /* duplicate an SV of any type (including AV, HV etc) */
12281 S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12286 PERL_ARGS_ASSERT_SV_DUP_COMMON;
12288 if (SvTYPE(sstr) == (svtype)SVTYPEMASK) {
12289 #ifdef DEBUG_LEAKING_SCALARS_ABORT
12294 /* look for it in the table first */
12295 dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
12299 if(param->flags & CLONEf_JOIN_IN) {
12300 /** We are joining here so we don't want do clone
12301 something that is bad **/
12302 if (SvTYPE(sstr) == SVt_PVHV) {
12303 const HEK * const hvname = HvNAME_HEK(sstr);
12305 /** don't clone stashes if they already exist **/
12306 dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
12307 HEK_UTF8(hvname) ? SVf_UTF8 : 0));
12308 ptr_table_store(PL_ptr_table, sstr, dstr);
12312 else if (SvTYPE(sstr) == SVt_PVGV && !SvFAKE(sstr)) {
12313 HV *stash = GvSTASH(sstr);
12314 const HEK * hvname;
12315 if (stash && (hvname = HvNAME_HEK(stash))) {
12316 /** don't clone GVs if they already exist **/
12318 stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
12319 HEK_UTF8(hvname) ? SVf_UTF8 : 0);
12321 stash, GvNAME(sstr),
12327 if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) {
12328 ptr_table_store(PL_ptr_table, sstr, *svp);
12335 /* create anew and remember what it is */
12338 #ifdef DEBUG_LEAKING_SCALARS
12339 dstr->sv_debug_optype = sstr->sv_debug_optype;
12340 dstr->sv_debug_line = sstr->sv_debug_line;
12341 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
12342 dstr->sv_debug_parent = (SV*)sstr;
12343 FREE_SV_DEBUG_FILE(dstr);
12344 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
12347 ptr_table_store(PL_ptr_table, sstr, dstr);
12350 SvFLAGS(dstr) = SvFLAGS(sstr);
12351 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
12352 SvREFCNT(dstr) = 0; /* must be before any other dups! */
12355 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
12356 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
12357 (void*)PL_watch_pvx, SvPVX_const(sstr));
12360 /* don't clone objects whose class has asked us not to */
12361 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
12366 switch (SvTYPE(sstr)) {
12368 SvANY(dstr) = NULL;
12371 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
12373 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
12375 SvIV_set(dstr, SvIVX(sstr));
12379 SvANY(dstr) = new_XNV();
12380 SvNV_set(dstr, SvNVX(sstr));
12384 /* These are all the types that need complex bodies allocating. */
12386 const svtype sv_type = SvTYPE(sstr);
12387 const struct body_details *const sv_type_details
12388 = bodies_by_type + sv_type;
12392 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
12408 assert(sv_type_details->body_size);
12409 if (sv_type_details->arena) {
12410 new_body_inline(new_body, sv_type);
12412 = (void*)((char*)new_body - sv_type_details->offset);
12414 new_body = new_NOARENA(sv_type_details);
12418 SvANY(dstr) = new_body;
12421 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
12422 ((char*)SvANY(dstr)) + sv_type_details->offset,
12423 sv_type_details->copy, char);
12425 Copy(((char*)SvANY(sstr)),
12426 ((char*)SvANY(dstr)),
12427 sv_type_details->body_size + sv_type_details->offset, char);
12430 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
12431 && !isGV_with_GP(dstr)
12433 && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
12434 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
12436 /* The Copy above means that all the source (unduplicated) pointers
12437 are now in the destination. We can check the flags and the
12438 pointers in either, but it's possible that there's less cache
12439 missing by always going for the destination.
12440 FIXME - instrument and check that assumption */
12441 if (sv_type >= SVt_PVMG) {
12442 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
12443 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
12444 } else if (sv_type == SVt_PVAV && AvPAD_NAMELIST(dstr)) {
12446 } else if (SvMAGIC(dstr))
12447 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
12448 if (SvOBJECT(dstr) && SvSTASH(dstr))
12449 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
12450 else SvSTASH_set(dstr, 0); /* don't copy DESTROY cache */
12453 /* The cast silences a GCC warning about unhandled types. */
12454 switch ((int)sv_type) {
12465 /* FIXME for plugins */
12466 dstr->sv_u.svu_rx = ((REGEXP *)dstr)->sv_any;
12467 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
12470 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
12471 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
12472 LvTARG(dstr) = dstr;
12473 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
12474 LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
12476 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
12477 if (isREGEXP(sstr)) goto duprex;
12479 /* non-GP case already handled above */
12480 if(isGV_with_GP(sstr)) {
12481 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
12482 /* Don't call sv_add_backref here as it's going to be
12483 created as part of the magic cloning of the symbol
12484 table--unless this is during a join and the stash
12485 is not actually being cloned. */
12486 /* Danger Will Robinson - GvGP(dstr) isn't initialised
12487 at the point of this comment. */
12488 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
12489 if (param->flags & CLONEf_JOIN_IN)
12490 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
12491 GvGP_set(dstr, gp_dup(GvGP(sstr), param));
12492 (void)GpREFCNT_inc(GvGP(dstr));
12496 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
12497 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
12498 /* I have no idea why fake dirp (rsfps)
12499 should be treated differently but otherwise
12500 we end up with leaks -- sky*/
12501 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
12502 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
12503 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
12505 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
12506 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
12507 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
12508 if (IoDIRP(dstr)) {
12509 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr), param);
12512 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
12514 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param);
12516 if (IoOFP(dstr) == IoIFP(sstr))
12517 IoOFP(dstr) = IoIFP(dstr);
12519 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
12520 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
12521 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
12522 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
12525 /* avoid cloning an empty array */
12526 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
12527 SV **dst_ary, **src_ary;
12528 SSize_t items = AvFILLp((const AV *)sstr) + 1;
12530 src_ary = AvARRAY((const AV *)sstr);
12531 Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
12532 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
12533 AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
12534 AvALLOC((const AV *)dstr) = dst_ary;
12535 if (AvREAL((const AV *)sstr)) {
12536 dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
12540 while (items-- > 0)
12541 *dst_ary++ = sv_dup(*src_ary++, param);
12543 items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
12544 while (items-- > 0) {
12545 *dst_ary++ = &PL_sv_undef;
12549 AvARRAY(MUTABLE_AV(dstr)) = NULL;
12550 AvALLOC((const AV *)dstr) = (SV**)NULL;
12551 AvMAX( (const AV *)dstr) = -1;
12552 AvFILLp((const AV *)dstr) = -1;
12556 if (HvARRAY((const HV *)sstr)) {
12558 const bool sharekeys = !!HvSHAREKEYS(sstr);
12559 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
12560 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
12562 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
12563 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
12565 HvARRAY(dstr) = (HE**)darray;
12566 while (i <= sxhv->xhv_max) {
12567 const HE * const source = HvARRAY(sstr)[i];
12568 HvARRAY(dstr)[i] = source
12569 ? he_dup(source, sharekeys, param) : 0;
12573 const struct xpvhv_aux * const saux = HvAUX(sstr);
12574 struct xpvhv_aux * const daux = HvAUX(dstr);
12575 /* This flag isn't copied. */
12578 if (saux->xhv_name_count) {
12579 HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
12581 = saux->xhv_name_count < 0
12582 ? -saux->xhv_name_count
12583 : saux->xhv_name_count;
12584 HEK **shekp = sname + count;
12586 Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *);
12587 dhekp = daux->xhv_name_u.xhvnameu_names + count;
12588 while (shekp-- > sname) {
12590 *dhekp = hek_dup(*shekp, param);
12594 daux->xhv_name_u.xhvnameu_name
12595 = hek_dup(saux->xhv_name_u.xhvnameu_name,
12598 daux->xhv_name_count = saux->xhv_name_count;
12600 daux->xhv_fill_lazy = saux->xhv_fill_lazy;
12601 daux->xhv_riter = saux->xhv_riter;
12602 daux->xhv_eiter = saux->xhv_eiter
12603 ? he_dup(saux->xhv_eiter,
12604 cBOOL(HvSHAREKEYS(sstr)), param) : 0;
12605 /* backref array needs refcnt=2; see sv_add_backref */
12606 daux->xhv_backreferences =
12607 (param->flags & CLONEf_JOIN_IN)
12608 /* when joining, we let the individual GVs and
12609 * CVs add themselves to backref as
12610 * needed. This avoids pulling in stuff
12611 * that isn't required, and simplifies the
12612 * case where stashes aren't cloned back
12613 * if they already exist in the parent
12616 : saux->xhv_backreferences
12617 ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
12618 ? MUTABLE_AV(SvREFCNT_inc(
12619 sv_dup_inc((const SV *)
12620 saux->xhv_backreferences, param)))
12621 : MUTABLE_AV(sv_dup((const SV *)
12622 saux->xhv_backreferences, param))
12625 daux->xhv_mro_meta = saux->xhv_mro_meta
12626 ? mro_meta_dup(saux->xhv_mro_meta, param)
12629 /* Record stashes for possible cloning in Perl_clone(). */
12631 av_push(param->stashes, dstr);
12635 HvARRAY(MUTABLE_HV(dstr)) = NULL;
12638 if (!(param->flags & CLONEf_COPY_STACKS)) {
12643 /* NOTE: not refcounted */
12644 SvANY(MUTABLE_CV(dstr))->xcv_stash =
12645 hv_dup(CvSTASH(dstr), param);
12646 if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
12647 Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
12648 if (!CvISXSUB(dstr)) {
12650 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
12652 CvSLABBED_off(dstr);
12653 } else if (CvCONST(dstr)) {
12654 CvXSUBANY(dstr).any_ptr =
12655 sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
12657 assert(!CvSLABBED(dstr));
12658 if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
12660 SvANY((CV *)dstr)->xcv_gv_u.xcv_hek =
12661 share_hek_hek(CvNAME_HEK((CV *)sstr));
12662 /* don't dup if copying back - CvGV isn't refcounted, so the
12663 * duped GV may never be freed. A bit of a hack! DAPM */
12665 SvANY(MUTABLE_CV(dstr))->xcv_gv_u.xcv_gv =
12667 ? gv_dup_inc(CvGV(sstr), param)
12668 : (param->flags & CLONEf_JOIN_IN)
12670 : gv_dup(CvGV(sstr), param);
12672 CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
12674 CvWEAKOUTSIDE(sstr)
12675 ? cv_dup( CvOUTSIDE(dstr), param)
12676 : cv_dup_inc(CvOUTSIDE(dstr), param);
12686 Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12688 PERL_ARGS_ASSERT_SV_DUP_INC;
12689 return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
12693 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12695 SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
12696 PERL_ARGS_ASSERT_SV_DUP;
12698 /* Track every SV that (at least initially) had a reference count of 0.
12699 We need to do this by holding an actual reference to it in this array.
12700 If we attempt to cheat, turn AvREAL_off(), and store only pointers
12701 (akin to the stashes hash, and the perl stack), we come unstuck if
12702 a weak reference (or other SV legitimately SvREFCNT() == 0 for this
12703 thread) is manipulated in a CLONE method, because CLONE runs before the
12704 unreferenced array is walked to find SVs still with SvREFCNT() == 0
12705 (and fix things up by giving each a reference via the temps stack).
12706 Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
12707 then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
12708 before the walk of unreferenced happens and a reference to that is SV
12709 added to the temps stack. At which point we have the same SV considered
12710 to be in use, and free to be re-used. Not good.
12712 if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
12713 assert(param->unreferenced);
12714 av_push(param->unreferenced, SvREFCNT_inc(dstr));
12720 /* duplicate a context */
12723 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
12725 PERL_CONTEXT *ncxs;
12727 PERL_ARGS_ASSERT_CX_DUP;
12730 return (PERL_CONTEXT*)NULL;
12732 /* look for it in the table first */
12733 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
12737 /* create anew and remember what it is */
12738 Newx(ncxs, max + 1, PERL_CONTEXT);
12739 ptr_table_store(PL_ptr_table, cxs, ncxs);
12740 Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
12743 PERL_CONTEXT * const ncx = &ncxs[ix];
12744 if (CxTYPE(ncx) == CXt_SUBST) {
12745 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
12748 ncx->blk_oldcop = (COP*)any_dup(ncx->blk_oldcop, param->proto_perl);
12749 switch (CxTYPE(ncx)) {
12751 ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
12752 ? cv_dup_inc(ncx->blk_sub.cv, param)
12753 : cv_dup(ncx->blk_sub.cv,param));
12754 ncx->blk_sub.argarray = (CxHASARGS(ncx)
12755 ? av_dup_inc(ncx->blk_sub.argarray,
12758 ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
12760 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
12761 ncx->blk_sub.oldcomppad);
12764 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
12766 ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
12767 ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param);
12769 case CXt_LOOP_LAZYSV:
12770 ncx->blk_loop.state_u.lazysv.end
12771 = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
12772 /* We are taking advantage of av_dup_inc and sv_dup_inc
12773 actually being the same function, and order equivalence of
12775 We can assert the later [but only at run time :-(] */
12776 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
12777 (void *) &ncx->blk_loop.state_u.lazysv.cur);
12779 ncx->blk_loop.state_u.ary.ary
12780 = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
12781 case CXt_LOOP_LAZYIV:
12782 case CXt_LOOP_PLAIN:
12783 if (CxPADLOOP(ncx)) {
12784 ncx->blk_loop.itervar_u.oldcomppad
12785 = (PAD*)ptr_table_fetch(PL_ptr_table,
12786 ncx->blk_loop.itervar_u.oldcomppad);
12788 ncx->blk_loop.itervar_u.gv
12789 = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
12794 ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
12795 ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
12796 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
12811 /* duplicate a stack info structure */
12814 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
12818 PERL_ARGS_ASSERT_SI_DUP;
12821 return (PERL_SI*)NULL;
12823 /* look for it in the table first */
12824 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
12828 /* create anew and remember what it is */
12829 Newxz(nsi, 1, PERL_SI);
12830 ptr_table_store(PL_ptr_table, si, nsi);
12832 nsi->si_stack = av_dup_inc(si->si_stack, param);
12833 nsi->si_cxix = si->si_cxix;
12834 nsi->si_cxmax = si->si_cxmax;
12835 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
12836 nsi->si_type = si->si_type;
12837 nsi->si_prev = si_dup(si->si_prev, param);
12838 nsi->si_next = si_dup(si->si_next, param);
12839 nsi->si_markoff = si->si_markoff;
12844 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
12845 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
12846 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
12847 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
12848 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
12849 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
12850 #define POPUV(ss,ix) ((ss)[--(ix)].any_uv)
12851 #define TOPUV(ss,ix) ((ss)[ix].any_uv)
12852 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
12853 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
12854 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
12855 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
12856 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
12857 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
12858 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
12859 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
12862 #define pv_dup_inc(p) SAVEPV(p)
12863 #define pv_dup(p) SAVEPV(p)
12864 #define svp_dup_inc(p,pp) any_dup(p,pp)
12866 /* map any object to the new equivent - either something in the
12867 * ptr table, or something in the interpreter structure
12871 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
12875 PERL_ARGS_ASSERT_ANY_DUP;
12878 return (void*)NULL;
12880 /* look for it in the table first */
12881 ret = ptr_table_fetch(PL_ptr_table, v);
12885 /* see if it is part of the interpreter structure */
12886 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
12887 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
12895 /* duplicate the save stack */
12898 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
12901 ANY * const ss = proto_perl->Isavestack;
12902 const I32 max = proto_perl->Isavestack_max;
12903 I32 ix = proto_perl->Isavestack_ix;
12916 void (*dptr) (void*);
12917 void (*dxptr) (pTHX_ void*);
12919 PERL_ARGS_ASSERT_SS_DUP;
12921 Newxz(nss, max, ANY);
12924 const UV uv = POPUV(ss,ix);
12925 const U8 type = (U8)uv & SAVE_MASK;
12927 TOPUV(nss,ix) = uv;
12929 case SAVEt_CLEARSV:
12930 case SAVEt_CLEARPADRANGE:
12932 case SAVEt_HELEM: /* hash element */
12933 sv = (const SV *)POPPTR(ss,ix);
12934 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12936 case SAVEt_ITEM: /* normal string */
12937 case SAVEt_GVSV: /* scalar slot in GV */
12938 case SAVEt_SV: /* scalar reference */
12939 sv = (const SV *)POPPTR(ss,ix);
12940 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12943 case SAVEt_MORTALIZESV:
12944 case SAVEt_READONLY_OFF:
12945 sv = (const SV *)POPPTR(ss,ix);
12946 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12948 case SAVEt_SHARED_PVREF: /* char* in shared space */
12949 c = (char*)POPPTR(ss,ix);
12950 TOPPTR(nss,ix) = savesharedpv(c);
12951 ptr = POPPTR(ss,ix);
12952 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12954 case SAVEt_GENERIC_SVREF: /* generic sv */
12955 case SAVEt_SVREF: /* scalar reference */
12956 sv = (const SV *)POPPTR(ss,ix);
12957 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12958 ptr = POPPTR(ss,ix);
12959 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
12961 case SAVEt_GVSLOT: /* any slot in GV */
12962 sv = (const SV *)POPPTR(ss,ix);
12963 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12964 ptr = POPPTR(ss,ix);
12965 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
12966 sv = (const SV *)POPPTR(ss,ix);
12967 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12969 case SAVEt_HV: /* hash reference */
12970 case SAVEt_AV: /* array reference */
12971 sv = (const SV *) POPPTR(ss,ix);
12972 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12974 case SAVEt_COMPPAD:
12976 sv = (const SV *) POPPTR(ss,ix);
12977 TOPPTR(nss,ix) = sv_dup(sv, param);
12979 case SAVEt_INT: /* int reference */
12980 ptr = POPPTR(ss,ix);
12981 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12982 intval = (int)POPINT(ss,ix);
12983 TOPINT(nss,ix) = intval;
12985 case SAVEt_LONG: /* long reference */
12986 ptr = POPPTR(ss,ix);
12987 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12988 longval = (long)POPLONG(ss,ix);
12989 TOPLONG(nss,ix) = longval;
12991 case SAVEt_I32: /* I32 reference */
12992 ptr = POPPTR(ss,ix);
12993 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12995 TOPINT(nss,ix) = i;
12997 case SAVEt_IV: /* IV reference */
12998 case SAVEt_STRLEN: /* STRLEN/size_t ref */
12999 ptr = POPPTR(ss,ix);
13000 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13002 TOPIV(nss,ix) = iv;
13004 case SAVEt_HPTR: /* HV* reference */
13005 case SAVEt_APTR: /* AV* reference */
13006 case SAVEt_SPTR: /* SV* reference */
13007 ptr = POPPTR(ss,ix);
13008 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13009 sv = (const SV *)POPPTR(ss,ix);
13010 TOPPTR(nss,ix) = sv_dup(sv, param);
13012 case SAVEt_VPTR: /* random* reference */
13013 ptr = POPPTR(ss,ix);
13014 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13016 case SAVEt_INT_SMALL:
13017 case SAVEt_I32_SMALL:
13018 case SAVEt_I16: /* I16 reference */
13019 case SAVEt_I8: /* I8 reference */
13021 ptr = POPPTR(ss,ix);
13022 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13024 case SAVEt_GENERIC_PVREF: /* generic char* */
13025 case SAVEt_PPTR: /* char* reference */
13026 ptr = POPPTR(ss,ix);
13027 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13028 c = (char*)POPPTR(ss,ix);
13029 TOPPTR(nss,ix) = pv_dup(c);
13031 case SAVEt_GP: /* scalar reference */
13032 gp = (GP*)POPPTR(ss,ix);
13033 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
13034 (void)GpREFCNT_inc(gp);
13035 gv = (const GV *)POPPTR(ss,ix);
13036 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
13039 ptr = POPPTR(ss,ix);
13040 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
13041 /* these are assumed to be refcounted properly */
13043 switch (((OP*)ptr)->op_type) {
13045 case OP_LEAVESUBLV:
13049 case OP_LEAVEWRITE:
13050 TOPPTR(nss,ix) = ptr;
13053 (void) OpREFCNT_inc(o);
13057 TOPPTR(nss,ix) = NULL;
13062 TOPPTR(nss,ix) = NULL;
13064 case SAVEt_FREECOPHH:
13065 ptr = POPPTR(ss,ix);
13066 TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr);
13068 case SAVEt_ADELETE:
13069 av = (const AV *)POPPTR(ss,ix);
13070 TOPPTR(nss,ix) = av_dup_inc(av, param);
13072 TOPINT(nss,ix) = i;
13075 hv = (const HV *)POPPTR(ss,ix);
13076 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
13078 TOPINT(nss,ix) = i;
13081 c = (char*)POPPTR(ss,ix);
13082 TOPPTR(nss,ix) = pv_dup_inc(c);
13084 case SAVEt_STACK_POS: /* Position on Perl stack */
13086 TOPINT(nss,ix) = i;
13088 case SAVEt_DESTRUCTOR:
13089 ptr = POPPTR(ss,ix);
13090 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
13091 dptr = POPDPTR(ss,ix);
13092 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
13093 any_dup(FPTR2DPTR(void *, dptr),
13096 case SAVEt_DESTRUCTOR_X:
13097 ptr = POPPTR(ss,ix);
13098 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
13099 dxptr = POPDXPTR(ss,ix);
13100 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
13101 any_dup(FPTR2DPTR(void *, dxptr),
13104 case SAVEt_REGCONTEXT:
13106 ix -= uv >> SAVE_TIGHT_SHIFT;
13108 case SAVEt_AELEM: /* array element */
13109 sv = (const SV *)POPPTR(ss,ix);
13110 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
13112 TOPINT(nss,ix) = i;
13113 av = (const AV *)POPPTR(ss,ix);
13114 TOPPTR(nss,ix) = av_dup_inc(av, param);
13117 ptr = POPPTR(ss,ix);
13118 TOPPTR(nss,ix) = ptr;
13121 ptr = POPPTR(ss,ix);
13122 ptr = cophh_copy((COPHH*)ptr);
13123 TOPPTR(nss,ix) = ptr;
13125 TOPINT(nss,ix) = i;
13126 if (i & HINT_LOCALIZE_HH) {
13127 hv = (const HV *)POPPTR(ss,ix);
13128 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
13131 case SAVEt_PADSV_AND_MORTALIZE:
13132 longval = (long)POPLONG(ss,ix);
13133 TOPLONG(nss,ix) = longval;
13134 ptr = POPPTR(ss,ix);
13135 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13136 sv = (const SV *)POPPTR(ss,ix);
13137 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
13139 case SAVEt_SET_SVFLAGS:
13141 TOPINT(nss,ix) = i;
13143 TOPINT(nss,ix) = i;
13144 sv = (const SV *)POPPTR(ss,ix);
13145 TOPPTR(nss,ix) = sv_dup(sv, param);
13147 case SAVEt_COMPILE_WARNINGS:
13148 ptr = POPPTR(ss,ix);
13149 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
13152 ptr = POPPTR(ss,ix);
13153 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
13157 "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
13165 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
13166 * flag to the result. This is done for each stash before cloning starts,
13167 * so we know which stashes want their objects cloned */
13170 do_mark_cloneable_stash(pTHX_ SV *const sv)
13172 const HEK * const hvname = HvNAME_HEK((const HV *)sv);
13174 GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
13175 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
13176 if (cloner && GvCV(cloner)) {
13183 mXPUSHs(newSVhek(hvname));
13185 call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
13192 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
13200 =for apidoc perl_clone
13202 Create and return a new interpreter by cloning the current one.
13204 perl_clone takes these flags as parameters:
13206 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
13207 without it we only clone the data and zero the stacks,
13208 with it we copy the stacks and the new perl interpreter is
13209 ready to run at the exact same point as the previous one.
13210 The pseudo-fork code uses COPY_STACKS while the
13211 threads->create doesn't.
13213 CLONEf_KEEP_PTR_TABLE -
13214 perl_clone keeps a ptr_table with the pointer of the old
13215 variable as a key and the new variable as a value,
13216 this allows it to check if something has been cloned and not
13217 clone it again but rather just use the value and increase the
13218 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
13219 the ptr_table using the function
13220 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
13221 reason to keep it around is if you want to dup some of your own
13222 variable who are outside the graph perl scans, example of this
13223 code is in threads.xs create.
13225 CLONEf_CLONE_HOST -
13226 This is a win32 thing, it is ignored on unix, it tells perls
13227 win32host code (which is c++) to clone itself, this is needed on
13228 win32 if you want to run two threads at the same time,
13229 if you just want to do some stuff in a separate perl interpreter
13230 and then throw it away and return to the original one,
13231 you don't need to do anything.
13236 /* XXX the above needs expanding by someone who actually understands it ! */
13237 EXTERN_C PerlInterpreter *
13238 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
13241 perl_clone(PerlInterpreter *proto_perl, UV flags)
13244 #ifdef PERL_IMPLICIT_SYS
13246 PERL_ARGS_ASSERT_PERL_CLONE;
13248 /* perlhost.h so we need to call into it
13249 to clone the host, CPerlHost should have a c interface, sky */
13251 if (flags & CLONEf_CLONE_HOST) {
13252 return perl_clone_host(proto_perl,flags);
13254 return perl_clone_using(proto_perl, flags,
13256 proto_perl->IMemShared,
13257 proto_perl->IMemParse,
13259 proto_perl->IStdIO,
13263 proto_perl->IProc);
13267 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
13268 struct IPerlMem* ipM, struct IPerlMem* ipMS,
13269 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
13270 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
13271 struct IPerlDir* ipD, struct IPerlSock* ipS,
13272 struct IPerlProc* ipP)
13274 /* XXX many of the string copies here can be optimized if they're
13275 * constants; they need to be allocated as common memory and just
13276 * their pointers copied. */
13279 CLONE_PARAMS clone_params;
13280 CLONE_PARAMS* const param = &clone_params;
13282 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
13284 PERL_ARGS_ASSERT_PERL_CLONE_USING;
13285 #else /* !PERL_IMPLICIT_SYS */
13287 CLONE_PARAMS clone_params;
13288 CLONE_PARAMS* param = &clone_params;
13289 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
13291 PERL_ARGS_ASSERT_PERL_CLONE;
13292 #endif /* PERL_IMPLICIT_SYS */
13294 /* for each stash, determine whether its objects should be cloned */
13295 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
13296 PERL_SET_THX(my_perl);
13299 PoisonNew(my_perl, 1, PerlInterpreter);
13302 PL_defstash = NULL; /* may be used by perl malloc() */
13305 PL_scopestack_name = 0;
13307 PL_savestack_ix = 0;
13308 PL_savestack_max = -1;
13309 PL_sig_pending = 0;
13311 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
13312 # ifdef DEBUG_LEAKING_SCALARS
13313 PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
13315 #else /* !DEBUGGING */
13316 Zero(my_perl, 1, PerlInterpreter);
13317 #endif /* DEBUGGING */
13319 #ifdef PERL_IMPLICIT_SYS
13320 /* host pointers */
13322 PL_MemShared = ipMS;
13323 PL_MemParse = ipMP;
13330 #endif /* PERL_IMPLICIT_SYS */
13333 param->flags = flags;
13334 /* Nothing in the core code uses this, but we make it available to
13335 extensions (using mg_dup). */
13336 param->proto_perl = proto_perl;
13337 /* Likely nothing will use this, but it is initialised to be consistent
13338 with Perl_clone_params_new(). */
13339 param->new_perl = my_perl;
13340 param->unreferenced = NULL;
13343 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
13345 PL_body_arenas = NULL;
13346 Zero(&PL_body_roots, 1, PL_body_roots);
13350 PL_sv_arenaroot = NULL;
13352 PL_debug = proto_perl->Idebug;
13354 /* dbargs array probably holds garbage */
13357 PL_compiling = proto_perl->Icompiling;
13359 /* pseudo environmental stuff */
13360 PL_origargc = proto_perl->Iorigargc;
13361 PL_origargv = proto_perl->Iorigargv;
13363 #if !NO_TAINT_SUPPORT
13364 /* Set tainting stuff before PerlIO_debug can possibly get called */
13365 PL_tainting = proto_perl->Itainting;
13366 PL_taint_warn = proto_perl->Itaint_warn;
13368 PL_tainting = FALSE;
13369 PL_taint_warn = FALSE;
13372 PL_minus_c = proto_perl->Iminus_c;
13374 PL_localpatches = proto_perl->Ilocalpatches;
13375 PL_splitstr = proto_perl->Isplitstr;
13376 PL_minus_n = proto_perl->Iminus_n;
13377 PL_minus_p = proto_perl->Iminus_p;
13378 PL_minus_l = proto_perl->Iminus_l;
13379 PL_minus_a = proto_perl->Iminus_a;
13380 PL_minus_E = proto_perl->Iminus_E;
13381 PL_minus_F = proto_perl->Iminus_F;
13382 PL_doswitches = proto_perl->Idoswitches;
13383 PL_dowarn = proto_perl->Idowarn;
13384 #ifdef PERL_SAWAMPERSAND
13385 PL_sawampersand = proto_perl->Isawampersand;
13387 PL_unsafe = proto_perl->Iunsafe;
13388 PL_perldb = proto_perl->Iperldb;
13389 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
13390 PL_exit_flags = proto_perl->Iexit_flags;
13392 /* XXX time(&PL_basetime) when asked for? */
13393 PL_basetime = proto_perl->Ibasetime;
13395 PL_maxsysfd = proto_perl->Imaxsysfd;
13396 PL_statusvalue = proto_perl->Istatusvalue;
13398 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
13400 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
13403 /* RE engine related */
13404 PL_regmatch_slab = NULL;
13405 PL_reg_curpm = NULL;
13407 PL_sub_generation = proto_perl->Isub_generation;
13409 /* funky return mechanisms */
13410 PL_forkprocess = proto_perl->Iforkprocess;
13412 /* internal state */
13413 PL_maxo = proto_perl->Imaxo;
13415 PL_main_start = proto_perl->Imain_start;
13416 PL_eval_root = proto_perl->Ieval_root;
13417 PL_eval_start = proto_perl->Ieval_start;
13419 PL_filemode = proto_perl->Ifilemode;
13420 PL_lastfd = proto_perl->Ilastfd;
13421 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
13424 PL_gensym = proto_perl->Igensym;
13426 PL_laststatval = proto_perl->Ilaststatval;
13427 PL_laststype = proto_perl->Ilaststype;
13430 PL_profiledata = NULL;
13432 PL_generation = proto_perl->Igeneration;
13434 PL_in_clean_objs = proto_perl->Iin_clean_objs;
13435 PL_in_clean_all = proto_perl->Iin_clean_all;
13437 PL_delaymagic_uid = proto_perl->Idelaymagic_uid;
13438 PL_delaymagic_euid = proto_perl->Idelaymagic_euid;
13439 PL_delaymagic_gid = proto_perl->Idelaymagic_gid;
13440 PL_delaymagic_egid = proto_perl->Idelaymagic_egid;
13441 PL_nomemok = proto_perl->Inomemok;
13442 PL_an = proto_perl->Ian;
13443 PL_evalseq = proto_perl->Ievalseq;
13444 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
13445 PL_origalen = proto_perl->Iorigalen;
13447 PL_sighandlerp = proto_perl->Isighandlerp;
13449 PL_runops = proto_perl->Irunops;
13451 PL_subline = proto_perl->Isubline;
13454 PL_cryptseen = proto_perl->Icryptseen;
13457 #ifdef USE_LOCALE_COLLATE
13458 PL_collation_ix = proto_perl->Icollation_ix;
13459 PL_collation_standard = proto_perl->Icollation_standard;
13460 PL_collxfrm_base = proto_perl->Icollxfrm_base;
13461 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
13462 #endif /* USE_LOCALE_COLLATE */
13464 #ifdef USE_LOCALE_NUMERIC
13465 PL_numeric_standard = proto_perl->Inumeric_standard;
13466 PL_numeric_local = proto_perl->Inumeric_local;
13467 #endif /* !USE_LOCALE_NUMERIC */
13469 /* Did the locale setup indicate UTF-8? */
13470 PL_utf8locale = proto_perl->Iutf8locale;
13471 /* Unicode features (see perlrun/-C) */
13472 PL_unicode = proto_perl->Iunicode;
13474 /* Pre-5.8 signals control */
13475 PL_signals = proto_perl->Isignals;
13477 /* times() ticks per second */
13478 PL_clocktick = proto_perl->Iclocktick;
13480 /* Recursion stopper for PerlIO_find_layer */
13481 PL_in_load_module = proto_perl->Iin_load_module;
13483 /* sort() routine */
13484 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
13486 /* Not really needed/useful since the reenrant_retint is "volatile",
13487 * but do it for consistency's sake. */
13488 PL_reentrant_retint = proto_perl->Ireentrant_retint;
13490 /* Hooks to shared SVs and locks. */
13491 PL_sharehook = proto_perl->Isharehook;
13492 PL_lockhook = proto_perl->Ilockhook;
13493 PL_unlockhook = proto_perl->Iunlockhook;
13494 PL_threadhook = proto_perl->Ithreadhook;
13495 PL_destroyhook = proto_perl->Idestroyhook;
13496 PL_signalhook = proto_perl->Isignalhook;
13498 PL_globhook = proto_perl->Iglobhook;
13501 PL_last_swash_hv = NULL; /* reinits on demand */
13502 PL_last_swash_klen = 0;
13503 PL_last_swash_key[0]= '\0';
13504 PL_last_swash_tmps = (U8*)NULL;
13505 PL_last_swash_slen = 0;
13507 PL_srand_called = proto_perl->Isrand_called;
13508 Copy(&(proto_perl->Irandom_state), &PL_random_state, 1, PL_RANDOM_STATE_TYPE);
13510 if (flags & CLONEf_COPY_STACKS) {
13511 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
13512 PL_tmps_ix = proto_perl->Itmps_ix;
13513 PL_tmps_max = proto_perl->Itmps_max;
13514 PL_tmps_floor = proto_perl->Itmps_floor;
13516 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13517 * NOTE: unlike the others! */
13518 PL_scopestack_ix = proto_perl->Iscopestack_ix;
13519 PL_scopestack_max = proto_perl->Iscopestack_max;
13521 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
13522 * NOTE: unlike the others! */
13523 PL_savestack_ix = proto_perl->Isavestack_ix;
13524 PL_savestack_max = proto_perl->Isavestack_max;
13527 PL_start_env = proto_perl->Istart_env; /* XXXXXX */
13528 PL_top_env = &PL_start_env;
13530 PL_op = proto_perl->Iop;
13533 PL_Xpv = (XPV*)NULL;
13534 my_perl->Ina = proto_perl->Ina;
13536 PL_statbuf = proto_perl->Istatbuf;
13537 PL_statcache = proto_perl->Istatcache;
13540 PL_timesbuf = proto_perl->Itimesbuf;
13543 #if !NO_TAINT_SUPPORT
13544 PL_tainted = proto_perl->Itainted;
13546 PL_tainted = FALSE;
13548 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
13550 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
13552 PL_restartjmpenv = proto_perl->Irestartjmpenv;
13553 PL_restartop = proto_perl->Irestartop;
13554 PL_in_eval = proto_perl->Iin_eval;
13555 PL_delaymagic = proto_perl->Idelaymagic;
13556 PL_phase = proto_perl->Iphase;
13557 PL_localizing = proto_perl->Ilocalizing;
13559 PL_hv_fetch_ent_mh = NULL;
13560 PL_modcount = proto_perl->Imodcount;
13561 PL_lastgotoprobe = NULL;
13562 PL_dumpindent = proto_perl->Idumpindent;
13564 PL_efloatbuf = NULL; /* reinits on demand */
13565 PL_efloatsize = 0; /* reinits on demand */
13569 PL_colorset = 0; /* reinits PL_colors[] */
13570 /*PL_colors[6] = {0,0,0,0,0,0};*/
13572 /* Pluggable optimizer */
13573 PL_peepp = proto_perl->Ipeepp;
13574 PL_rpeepp = proto_perl->Irpeepp;
13575 /* op_free() hook */
13576 PL_opfreehook = proto_perl->Iopfreehook;
13578 #ifdef USE_REENTRANT_API
13579 /* XXX: things like -Dm will segfault here in perlio, but doing
13580 * PERL_SET_CONTEXT(proto_perl);
13581 * breaks too many other things
13583 Perl_reentrant_init(aTHX);
13586 /* create SV map for pointer relocation */
13587 PL_ptr_table = ptr_table_new();
13589 /* initialize these special pointers as early as possible */
13591 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
13592 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
13593 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
13595 /* create (a non-shared!) shared string table */
13596 PL_strtab = newHV();
13597 HvSHAREKEYS_off(PL_strtab);
13598 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
13599 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
13601 Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
13603 /* This PV will be free'd special way so must set it same way op.c does */
13604 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
13605 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
13607 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
13608 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
13609 CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));
13610 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
13612 param->stashes = newAV(); /* Setup array of objects to call clone on */
13613 /* This makes no difference to the implementation, as it always pushes
13614 and shifts pointers to other SVs without changing their reference
13615 count, with the array becoming empty before it is freed. However, it
13616 makes it conceptually clear what is going on, and will avoid some
13617 work inside av.c, filling slots between AvFILL() and AvMAX() with
13618 &PL_sv_undef, and SvREFCNT_dec()ing those. */
13619 AvREAL_off(param->stashes);
13621 if (!(flags & CLONEf_COPY_STACKS)) {
13622 param->unreferenced = newAV();
13625 #ifdef PERLIO_LAYERS
13626 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
13627 PerlIO_clone(aTHX_ proto_perl, param);
13630 PL_envgv = gv_dup_inc(proto_perl->Ienvgv, param);
13631 PL_incgv = gv_dup_inc(proto_perl->Iincgv, param);
13632 PL_hintgv = gv_dup_inc(proto_perl->Ihintgv, param);
13633 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
13634 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
13635 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
13638 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
13639 PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
13640 PL_inplace = SAVEPV(proto_perl->Iinplace);
13641 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
13643 /* magical thingies */
13645 PL_encoding = sv_dup(proto_perl->Iencoding, param);
13647 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
13648 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
13649 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
13652 /* Clone the regex array */
13653 /* ORANGE FIXME for plugins, probably in the SV dup code.
13654 newSViv(PTR2IV(CALLREGDUPE(
13655 INT2PTR(REGEXP *, SvIVX(regex)), param))))
13657 PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
13658 PL_regex_pad = AvARRAY(PL_regex_padav);
13660 PL_stashpadmax = proto_perl->Istashpadmax;
13661 PL_stashpadix = proto_perl->Istashpadix ;
13662 Newx(PL_stashpad, PL_stashpadmax, HV *);
13665 for (; o < PL_stashpadmax; ++o)
13666 PL_stashpad[o] = hv_dup(proto_perl->Istashpad[o], param);
13669 /* shortcuts to various I/O objects */
13670 PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param);
13671 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
13672 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
13673 PL_defgv = gv_dup(proto_perl->Idefgv, param);
13674 PL_argvgv = gv_dup_inc(proto_perl->Iargvgv, param);
13675 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
13676 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
13678 /* shortcuts to regexp stuff */
13679 PL_replgv = gv_dup_inc(proto_perl->Ireplgv, param);
13681 /* shortcuts to misc objects */
13682 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
13684 /* shortcuts to debugging objects */
13685 PL_DBgv = gv_dup_inc(proto_perl->IDBgv, param);
13686 PL_DBline = gv_dup_inc(proto_perl->IDBline, param);
13687 PL_DBsub = gv_dup_inc(proto_perl->IDBsub, param);
13688 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
13689 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
13690 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
13692 /* symbol tables */
13693 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
13694 PL_curstash = hv_dup_inc(proto_perl->Icurstash, param);
13695 PL_debstash = hv_dup(proto_perl->Idebstash, param);
13696 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
13697 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
13699 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
13700 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
13701 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
13702 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
13703 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
13704 PL_endav = av_dup_inc(proto_perl->Iendav, param);
13705 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
13706 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
13708 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
13710 /* subprocess state */
13711 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
13713 if (proto_perl->Iop_mask)
13714 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
13717 /* PL_asserting = proto_perl->Iasserting; */
13719 /* current interpreter roots */
13720 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
13722 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
13725 /* runtime control stuff */
13726 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
13728 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
13730 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
13732 /* interpreter atexit processing */
13733 PL_exitlistlen = proto_perl->Iexitlistlen;
13734 if (PL_exitlistlen) {
13735 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
13736 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
13739 PL_exitlist = (PerlExitListEntry*)NULL;
13741 PL_my_cxt_size = proto_perl->Imy_cxt_size;
13742 if (PL_my_cxt_size) {
13743 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
13744 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
13745 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13746 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
13747 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
13751 PL_my_cxt_list = (void**)NULL;
13752 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13753 PL_my_cxt_keys = (const char**)NULL;
13756 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
13757 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
13758 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
13759 PL_custom_ops = hv_dup_inc(proto_perl->Icustom_ops, param);
13761 PL_compcv = cv_dup(proto_perl->Icompcv, param);
13763 PAD_CLONE_VARS(proto_perl, param);
13765 #ifdef HAVE_INTERP_INTERN
13766 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
13769 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
13771 #ifdef PERL_USES_PL_PIDSTATUS
13772 PL_pidstatus = newHV(); /* XXX flag for cloning? */
13774 PL_osname = SAVEPV(proto_perl->Iosname);
13775 PL_parser = parser_dup(proto_perl->Iparser, param);
13777 /* XXX this only works if the saved cop has already been cloned */
13778 if (proto_perl->Iparser) {
13779 PL_parser->saved_curcop = (COP*)any_dup(
13780 proto_perl->Iparser->saved_curcop,
13784 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
13786 #ifdef USE_LOCALE_COLLATE
13787 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
13788 #endif /* USE_LOCALE_COLLATE */
13790 #ifdef USE_LOCALE_NUMERIC
13791 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
13792 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
13793 #endif /* !USE_LOCALE_NUMERIC */
13795 /* Unicode inversion lists */
13796 PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
13797 PL_UpperLatin1 = sv_dup_inc(proto_perl->IUpperLatin1, param);
13798 PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
13800 PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);
13801 PL_HasMultiCharFold= sv_dup_inc(proto_perl->IHasMultiCharFold, param);
13803 /* utf8 character class swashes */
13804 for (i = 0; i < POSIX_SWASH_COUNT; i++) {
13805 PL_utf8_swash_ptrs[i] = sv_dup_inc(proto_perl->Iutf8_swash_ptrs[i], param);
13807 for (i = 0; i < POSIX_CC_COUNT; i++) {
13808 PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param);
13810 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
13811 PL_utf8_X_regular_begin = sv_dup_inc(proto_perl->Iutf8_X_regular_begin, param);
13812 PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
13813 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
13814 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
13815 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
13816 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
13817 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
13818 PL_utf8_xidstart = sv_dup_inc(proto_perl->Iutf8_xidstart, param);
13819 PL_utf8_perl_idstart = sv_dup_inc(proto_perl->Iutf8_perl_idstart, param);
13820 PL_utf8_perl_idcont = sv_dup_inc(proto_perl->Iutf8_perl_idcont, param);
13821 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
13822 PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
13823 PL_utf8_foldable = sv_dup_inc(proto_perl->Iutf8_foldable, param);
13824 PL_utf8_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param);
13825 PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param);
13827 if (proto_perl->Ipsig_pend) {
13828 Newxz(PL_psig_pend, SIG_SIZE, int);
13831 PL_psig_pend = (int*)NULL;
13834 if (proto_perl->Ipsig_name) {
13835 Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
13836 sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
13838 PL_psig_ptr = PL_psig_name + SIG_SIZE;
13841 PL_psig_ptr = (SV**)NULL;
13842 PL_psig_name = (SV**)NULL;
13845 if (flags & CLONEf_COPY_STACKS) {
13846 Newx(PL_tmps_stack, PL_tmps_max, SV*);
13847 sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
13848 PL_tmps_ix+1, param);
13850 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
13851 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
13852 Newxz(PL_markstack, i, I32);
13853 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
13854 - proto_perl->Imarkstack);
13855 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
13856 - proto_perl->Imarkstack);
13857 Copy(proto_perl->Imarkstack, PL_markstack,
13858 PL_markstack_ptr - PL_markstack + 1, I32);
13860 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13861 * NOTE: unlike the others! */
13862 Newxz(PL_scopestack, PL_scopestack_max, I32);
13863 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
13866 Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
13867 Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
13869 /* reset stack AV to correct length before its duped via
13870 * PL_curstackinfo */
13871 AvFILLp(proto_perl->Icurstack) =
13872 proto_perl->Istack_sp - proto_perl->Istack_base;
13874 /* NOTE: si_dup() looks at PL_markstack */
13875 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
13877 /* PL_curstack = PL_curstackinfo->si_stack; */
13878 PL_curstack = av_dup(proto_perl->Icurstack, param);
13879 PL_mainstack = av_dup(proto_perl->Imainstack, param);
13881 /* next PUSHs() etc. set *(PL_stack_sp+1) */
13882 PL_stack_base = AvARRAY(PL_curstack);
13883 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
13884 - proto_perl->Istack_base);
13885 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
13887 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
13888 PL_savestack = ss_dup(proto_perl, param);
13892 ENTER; /* perl_destruct() wants to LEAVE; */
13895 PL_statgv = gv_dup(proto_perl->Istatgv, param);
13896 PL_statname = sv_dup_inc(proto_perl->Istatname, param);
13898 PL_rs = sv_dup_inc(proto_perl->Irs, param);
13899 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
13900 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
13901 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
13902 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
13903 PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
13905 PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
13907 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
13908 PL_firstgv = gv_dup_inc(proto_perl->Ifirstgv, param);
13909 PL_secondgv = gv_dup_inc(proto_perl->Isecondgv, param);
13911 PL_stashcache = newHV();
13913 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
13914 proto_perl->Iwatchaddr);
13915 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
13916 if (PL_debug && PL_watchaddr) {
13917 PerlIO_printf(Perl_debug_log,
13918 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
13919 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
13920 PTR2UV(PL_watchok));
13923 PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
13924 PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param);
13925 PL_utf8_foldclosures = hv_dup_inc(proto_perl->Iutf8_foldclosures, param);
13927 /* Call the ->CLONE method, if it exists, for each of the stashes
13928 identified by sv_dup() above.
13930 while(av_len(param->stashes) != -1) {
13931 HV* const stash = MUTABLE_HV(av_shift(param->stashes));
13932 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
13933 if (cloner && GvCV(cloner)) {
13938 mXPUSHs(newSVhek(HvNAME_HEK(stash)));
13940 call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
13946 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
13947 ptr_table_free(PL_ptr_table);
13948 PL_ptr_table = NULL;
13951 if (!(flags & CLONEf_COPY_STACKS)) {
13952 unreferenced_to_tmp_stack(param->unreferenced);
13955 SvREFCNT_dec(param->stashes);
13957 /* orphaned? eg threads->new inside BEGIN or use */
13958 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
13959 SvREFCNT_inc_simple_void(PL_compcv);
13960 SAVEFREESV(PL_compcv);
13967 S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
13969 PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
13971 if (AvFILLp(unreferenced) > -1) {
13972 SV **svp = AvARRAY(unreferenced);
13973 SV **const last = svp + AvFILLp(unreferenced);
13977 if (SvREFCNT(*svp) == 1)
13979 } while (++svp <= last);
13981 EXTEND_MORTAL(count);
13982 svp = AvARRAY(unreferenced);
13985 if (SvREFCNT(*svp) == 1) {
13986 /* Our reference is the only one to this SV. This means that
13987 in this thread, the scalar effectively has a 0 reference.
13988 That doesn't work (cleanup never happens), so donate our
13989 reference to it onto the save stack. */
13990 PL_tmps_stack[++PL_tmps_ix] = *svp;
13992 /* As an optimisation, because we are already walking the
13993 entire array, instead of above doing either
13994 SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
13995 release our reference to the scalar, so that at the end of
13996 the array owns zero references to the scalars it happens to
13997 point to. We are effectively converting the array from
13998 AvREAL() on to AvREAL() off. This saves the av_clear()
13999 (triggered by the SvREFCNT_dec(unreferenced) below) from
14000 walking the array a second time. */
14001 SvREFCNT_dec(*svp);
14004 } while (++svp <= last);
14005 AvREAL_off(unreferenced);
14007 SvREFCNT_dec_NN(unreferenced);
14011 Perl_clone_params_del(CLONE_PARAMS *param)
14013 /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
14015 PerlInterpreter *const to = param->new_perl;
14017 PerlInterpreter *const was = PERL_GET_THX;
14019 PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
14025 SvREFCNT_dec(param->stashes);
14026 if (param->unreferenced)
14027 unreferenced_to_tmp_stack(param->unreferenced);
14037 Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
14040 /* Need to play this game, as newAV() can call safesysmalloc(), and that
14041 does a dTHX; to get the context from thread local storage.
14042 FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
14043 a version that passes in my_perl. */
14044 PerlInterpreter *const was = PERL_GET_THX;
14045 CLONE_PARAMS *param;
14047 PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
14053 /* Given that we've set the context, we can do this unshared. */
14054 Newx(param, 1, CLONE_PARAMS);
14057 param->proto_perl = from;
14058 param->new_perl = to;
14059 param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
14060 AvREAL_off(param->stashes);
14061 param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
14069 #endif /* USE_ITHREADS */
14072 Perl_init_constants(pTHX)
14074 SvREFCNT(&PL_sv_undef) = SvREFCNT_IMMORTAL;
14075 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
14076 SvANY(&PL_sv_undef) = NULL;
14078 SvANY(&PL_sv_no) = new_XPVNV();
14079 SvREFCNT(&PL_sv_no) = SvREFCNT_IMMORTAL;
14080 SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY
14081 |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
14084 SvANY(&PL_sv_yes) = new_XPVNV();
14085 SvREFCNT(&PL_sv_yes) = SvREFCNT_IMMORTAL;
14086 SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY
14087 |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
14090 SvPV_set(&PL_sv_no, (char*)PL_No);
14091 SvCUR_set(&PL_sv_no, 0);
14092 SvLEN_set(&PL_sv_no, 0);
14093 SvIV_set(&PL_sv_no, 0);
14094 SvNV_set(&PL_sv_no, 0);
14096 SvPV_set(&PL_sv_yes, (char*)PL_Yes);
14097 SvCUR_set(&PL_sv_yes, 1);
14098 SvLEN_set(&PL_sv_yes, 0);
14099 SvIV_set(&PL_sv_yes, 1);
14100 SvNV_set(&PL_sv_yes, 1);
14104 =head1 Unicode Support
14106 =for apidoc sv_recode_to_utf8
14108 The encoding is assumed to be an Encode object, on entry the PV
14109 of the sv is assumed to be octets in that encoding, and the sv
14110 will be converted into Unicode (and UTF-8).
14112 If the sv already is UTF-8 (or if it is not POK), or if the encoding
14113 is not a reference, nothing is done to the sv. If the encoding is not
14114 an C<Encode::XS> Encoding object, bad things will happen.
14115 (See F<lib/encoding.pm> and L<Encode>.)
14117 The PV of the sv is returned.
14122 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
14126 PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
14128 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
14137 if (SvPADTMP(nsv)) {
14138 nsv = sv_newmortal();
14139 SvSetSV_nosteal(nsv, sv);
14148 Passing sv_yes is wrong - it needs to be or'ed set of constants
14149 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
14150 remove converted chars from source.
14152 Both will default the value - let them.
14154 XPUSHs(&PL_sv_yes);
14157 call_method("decode", G_SCALAR);
14161 s = SvPV_const(uni, len);
14162 if (s != SvPVX_const(sv)) {
14163 SvGROW(sv, len + 1);
14164 Move(s, SvPVX(sv), len + 1, char);
14165 SvCUR_set(sv, len);
14170 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
14171 /* clear pos and any utf8 cache */
14172 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
14175 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
14176 magic_setutf8(sv,mg); /* clear UTF8 cache */
14181 return SvPOKp(sv) ? SvPVX(sv) : NULL;
14185 =for apidoc sv_cat_decode
14187 The encoding is assumed to be an Encode object, the PV of the ssv is
14188 assumed to be octets in that encoding and decoding the input starts
14189 from the position which (PV + *offset) pointed to. The dsv will be
14190 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
14191 when the string tstr appears in decoding output or the input ends on
14192 the PV of the ssv. The value which the offset points will be modified
14193 to the last input position on the ssv.
14195 Returns TRUE if the terminator was found, else returns FALSE.
14200 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
14201 SV *ssv, int *offset, char *tstr, int tlen)
14206 PERL_ARGS_ASSERT_SV_CAT_DECODE;
14208 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
14219 offsv = newSViv(*offset);
14221 mPUSHp(tstr, tlen);
14223 call_method("cat_decode", G_SCALAR);
14225 ret = SvTRUE(TOPs);
14226 *offset = SvIV(offsv);
14232 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
14237 /* ---------------------------------------------------------------------
14239 * support functions for report_uninit()
14242 /* the maxiumum size of array or hash where we will scan looking
14243 * for the undefined element that triggered the warning */
14245 #define FUV_MAX_SEARCH_SIZE 1000
14247 /* Look for an entry in the hash whose value has the same SV as val;
14248 * If so, return a mortal copy of the key. */
14251 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
14257 PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
14259 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
14260 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
14263 array = HvARRAY(hv);
14265 for (i=HvMAX(hv); i>=0; i--) {
14267 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
14268 if (HeVAL(entry) != val)
14270 if ( HeVAL(entry) == &PL_sv_undef ||
14271 HeVAL(entry) == &PL_sv_placeholder)
14275 if (HeKLEN(entry) == HEf_SVKEY)
14276 return sv_mortalcopy(HeKEY_sv(entry));
14277 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
14283 /* Look for an entry in the array whose value has the same SV as val;
14284 * If so, return the index, otherwise return -1. */
14287 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
14291 PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
14293 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
14294 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
14297 if (val != &PL_sv_undef) {
14298 SV ** const svp = AvARRAY(av);
14301 for (i=AvFILLp(av); i>=0; i--)
14308 /* varname(): return the name of a variable, optionally with a subscript.
14309 * If gv is non-zero, use the name of that global, along with gvtype (one
14310 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
14311 * targ. Depending on the value of the subscript_type flag, return:
14314 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
14315 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
14316 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
14317 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
14320 Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
14321 const SV *const keyname, I32 aindex, int subscript_type)
14324 SV * const name = sv_newmortal();
14325 if (gv && isGV(gv)) {
14327 buffer[0] = gvtype;
14330 /* as gv_fullname4(), but add literal '^' for $^FOO names */
14332 gv_fullname4(name, gv, buffer, 0);
14334 if ((unsigned int)SvPVX(name)[1] <= 26) {
14336 buffer[1] = SvPVX(name)[1] + 'A' - 1;
14338 /* Swap the 1 unprintable control character for the 2 byte pretty
14339 version - ie substr($name, 1, 1) = $buffer; */
14340 sv_insert(name, 1, 1, buffer, 2);
14344 CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL);
14348 assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
14350 if (!cv || !CvPADLIST(cv))
14352 av = *PadlistARRAY(CvPADLIST(cv));
14353 sv = *av_fetch(av, targ, FALSE);
14354 sv_setsv_flags(name, sv, 0);
14357 if (subscript_type == FUV_SUBSCRIPT_HASH) {
14358 SV * const sv = newSV(0);
14359 *SvPVX(name) = '$';
14360 Perl_sv_catpvf(aTHX_ name, "{%s}",
14361 pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL,
14362 PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT ));
14363 SvREFCNT_dec_NN(sv);
14365 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
14366 *SvPVX(name) = '$';
14367 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
14369 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
14370 /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
14371 Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
14379 =for apidoc find_uninit_var
14381 Find the name of the undefined variable (if any) that caused the operator
14382 to issue a "Use of uninitialized value" warning.
14383 If match is true, only return a name if its value matches uninit_sv.
14384 So roughly speaking, if a unary operator (such as OP_COS) generates a
14385 warning, then following the direct child of the op may yield an
14386 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
14387 other hand, with OP_ADD there are two branches to follow, so we only print
14388 the variable name if we get an exact match.
14390 The name is returned as a mortal SV.
14392 Assumes that PL_op is the op that originally triggered the error, and that
14393 PL_comppad/PL_curpad points to the currently executing pad.
14399 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
14405 const OP *o, *o2, *kid;
14407 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
14408 uninit_sv == &PL_sv_placeholder)))
14411 switch (obase->op_type) {
14418 const bool pad = ( obase->op_type == OP_PADAV
14419 || obase->op_type == OP_PADHV
14420 || obase->op_type == OP_PADRANGE
14423 const bool hash = ( obase->op_type == OP_PADHV
14424 || obase->op_type == OP_RV2HV
14425 || (obase->op_type == OP_PADRANGE
14426 && SvTYPE(PAD_SVl(obase->op_targ)) == SVt_PVHV)
14430 int subscript_type = FUV_SUBSCRIPT_WITHIN;
14432 if (pad) { /* @lex, %lex */
14433 sv = PAD_SVl(obase->op_targ);
14437 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
14438 /* @global, %global */
14439 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
14442 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
14444 else if (obase == PL_op) /* @{expr}, %{expr} */
14445 return find_uninit_var(cUNOPx(obase)->op_first,
14447 else /* @{expr}, %{expr} as a sub-expression */
14451 /* attempt to find a match within the aggregate */
14453 keysv = find_hash_subscript((const HV*)sv, uninit_sv);
14455 subscript_type = FUV_SUBSCRIPT_HASH;
14458 index = find_array_subscript((const AV *)sv, uninit_sv);
14460 subscript_type = FUV_SUBSCRIPT_ARRAY;
14463 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
14466 return varname(gv, hash ? '%' : '@', obase->op_targ,
14467 keysv, index, subscript_type);
14471 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
14473 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
14474 if (!gv || !GvSTASH(gv))
14476 if (match && (GvSV(gv) != uninit_sv))
14478 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
14481 return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1);
14484 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
14486 return varname(NULL, '$', obase->op_targ,
14487 NULL, 0, FUV_SUBSCRIPT_NONE);
14490 gv = cGVOPx_gv(obase);
14491 if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))
14493 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
14495 case OP_AELEMFAST_LEX:
14498 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
14499 if (!av || SvRMAGICAL(av))
14501 svp = av_fetch(av, (I32)obase->op_private, FALSE);
14502 if (!svp || *svp != uninit_sv)
14505 return varname(NULL, '$', obase->op_targ,
14506 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
14509 gv = cGVOPx_gv(obase);
14514 AV *const av = GvAV(gv);
14515 if (!av || SvRMAGICAL(av))
14517 svp = av_fetch(av, (I32)obase->op_private, FALSE);
14518 if (!svp || *svp != uninit_sv)
14521 return varname(gv, '$', 0,
14522 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
14527 o = cUNOPx(obase)->op_first;
14528 if (!o || o->op_type != OP_NULL ||
14529 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
14531 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
14536 bool negate = FALSE;
14538 if (PL_op == obase)
14539 /* $a[uninit_expr] or $h{uninit_expr} */
14540 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
14543 o = cBINOPx(obase)->op_first;
14544 kid = cBINOPx(obase)->op_last;
14546 /* get the av or hv, and optionally the gv */
14548 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
14549 sv = PAD_SV(o->op_targ);
14551 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
14552 && cUNOPo->op_first->op_type == OP_GV)
14554 gv = cGVOPx_gv(cUNOPo->op_first);
14558 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
14563 if (kid && kid->op_type == OP_NEGATE) {
14565 kid = cUNOPx(kid)->op_first;
14568 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
14569 /* index is constant */
14572 kidsv = sv_2mortal(newSVpvs("-"));
14573 sv_catsv(kidsv, cSVOPx_sv(kid));
14576 kidsv = cSVOPx_sv(kid);
14580 if (obase->op_type == OP_HELEM) {
14581 HE* he = hv_fetch_ent(MUTABLE_HV(sv), kidsv, 0, 0);
14582 if (!he || HeVAL(he) != uninit_sv)
14586 SV * const opsv = cSVOPx_sv(kid);
14587 const IV opsviv = SvIV(opsv);
14588 SV * const * const svp = av_fetch(MUTABLE_AV(sv),
14589 negate ? - opsviv : opsviv,
14591 if (!svp || *svp != uninit_sv)
14595 if (obase->op_type == OP_HELEM)
14596 return varname(gv, '%', o->op_targ,
14597 kidsv, 0, FUV_SUBSCRIPT_HASH);
14599 return varname(gv, '@', o->op_targ, NULL,
14600 negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)),
14601 FUV_SUBSCRIPT_ARRAY);
14604 /* index is an expression;
14605 * attempt to find a match within the aggregate */
14606 if (obase->op_type == OP_HELEM) {
14607 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
14609 return varname(gv, '%', o->op_targ,
14610 keysv, 0, FUV_SUBSCRIPT_HASH);
14614 = find_array_subscript((const AV *)sv, uninit_sv);
14616 return varname(gv, '@', o->op_targ,
14617 NULL, index, FUV_SUBSCRIPT_ARRAY);
14622 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
14624 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
14630 /* only examine RHS */
14631 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
14634 o = cUNOPx(obase)->op_first;
14635 if ( o->op_type == OP_PUSHMARK
14636 || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
14640 if (!o->op_sibling) {
14641 /* one-arg version of open is highly magical */
14643 if (o->op_type == OP_GV) { /* open FOO; */
14645 if (match && GvSV(gv) != uninit_sv)
14647 return varname(gv, '$', 0,
14648 NULL, 0, FUV_SUBSCRIPT_NONE);
14650 /* other possibilities not handled are:
14651 * open $x; or open my $x; should return '${*$x}'
14652 * open expr; should return '$'.expr ideally
14658 /* ops where $_ may be an implicit arg */
14663 if ( !(obase->op_flags & OPf_STACKED)) {
14664 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
14665 ? PAD_SVl(obase->op_targ)
14668 sv = sv_newmortal();
14669 sv_setpvs(sv, "$_");
14678 match = 1; /* print etc can return undef on defined args */
14679 /* skip filehandle as it can't produce 'undef' warning */
14680 o = cUNOPx(obase)->op_first;
14681 if ((obase->op_flags & OPf_STACKED)
14683 ( o->op_type == OP_PUSHMARK
14684 || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)))
14685 o = o->op_sibling->op_sibling;
14689 case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
14690 case OP_CUSTOM: /* XS or custom code could trigger random warnings */
14692 /* the following ops are capable of returning PL_sv_undef even for
14693 * defined arg(s) */
14712 case OP_GETPEERNAME:
14760 case OP_SMARTMATCH:
14769 /* XXX tmp hack: these two may call an XS sub, and currently
14770 XS subs don't have a SUB entry on the context stack, so CV and
14771 pad determination goes wrong, and BAD things happen. So, just
14772 don't try to determine the value under those circumstances.
14773 Need a better fix at dome point. DAPM 11/2007 */
14779 GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
14780 if (gv && GvSV(gv) == uninit_sv)
14781 return newSVpvs_flags("$.", SVs_TEMP);
14786 /* def-ness of rval pos() is independent of the def-ness of its arg */
14787 if ( !(obase->op_flags & OPf_MOD))
14792 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
14793 return newSVpvs_flags("${$/}", SVs_TEMP);
14798 if (!(obase->op_flags & OPf_KIDS))
14800 o = cUNOPx(obase)->op_first;
14806 /* This loop checks all the kid ops, skipping any that cannot pos-
14807 * sibly be responsible for the uninitialized value; i.e., defined
14808 * constants and ops that return nothing. If there is only one op
14809 * left that is not skipped, then we *know* it is responsible for
14810 * the uninitialized value. If there is more than one op left, we
14811 * have to look for an exact match in the while() loop below.
14812 * Note that we skip padrange, because the individual pad ops that
14813 * it replaced are still in the tree, so we work on them instead.
14816 for (kid=o; kid; kid = kid->op_sibling) {
14818 const OPCODE type = kid->op_type;
14819 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
14820 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
14821 || (type == OP_PUSHMARK)
14822 || (type == OP_PADRANGE)
14826 if (o2) { /* more than one found */
14833 return find_uninit_var(o2, uninit_sv, match);
14835 /* scan all args */
14837 sv = find_uninit_var(o, uninit_sv, 1);
14849 =for apidoc report_uninit
14851 Print appropriate "Use of uninitialized variable" warning.
14857 Perl_report_uninit(pTHX_ const SV *uninit_sv)
14861 SV* varname = NULL;
14862 if (uninit_sv && PL_curpad) {
14863 varname = find_uninit_var(PL_op, uninit_sv,0);
14865 sv_insert(varname, 0, 0, " ", 1);
14867 /* PL_warn_uninit_sv is constant */
14868 GCC_DIAG_IGNORE(-Wformat-nonliteral);
14869 /* diag_listed_as: Use of uninitialized value%s */
14870 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
14871 SVfARG(varname ? varname : &PL_sv_no),
14872 " in ", OP_DESC(PL_op));
14876 /* PL_warn_uninit is constant */
14877 GCC_DIAG_IGNORE(-Wformat-nonliteral);
14878 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
14886 * c-indentation-style: bsd
14887 * c-basic-offset: 4
14888 * indent-tabs-mode: nil
14891 * ex: set ts=8 sts=4 sw=4 et: